diff --git a/Distribution/ShellHarness.hs b/Distribution/ShellHarness.hs --- a/Distribution/ShellHarness.hs +++ b/Distribution/ShellHarness.hs @@ -4,16 +4,18 @@ import Prelude hiding( catch ) import System.Directory ( getCurrentDirectory, setPermissions, Permissions(..), getDirectoryContents, - findExecutable, createDirectoryIfMissing ) + findExecutable, createDirectoryIfMissing, + renameFile, removeFile ) import System.Environment ( getEnv, getEnvironment ) import System.Exit ( ExitCode (..) ) import System.FilePath import System.IO +import System( system ) import System.Process ( ProcessHandle, runInteractiveProcess, waitForProcess, getProcessExitCode ) import Data.Maybe -import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy ) +import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy, isSuffixOf ) import Control.Concurrent #if __GLASGOW_HASKELL__ >= 610 import Control.OldException @@ -40,12 +42,15 @@ return True run :: Maybe FilePath -> [String] -> IO [String] -run set_darcs_path tests= do +run set_darcs_path tests = do cwd <- getCurrentDirectory path <- getEnv "PATH" env <- getEnvironment + bash <- find_bash darcs_path <- case set_darcs_path of - Nothing -> get_darcs_path + Nothing -> case lookup "DARCS" env of + Nothing -> return (cwd ++ "/..") + Just d -> return $ takeDirectory d Just x -> return x let myenv = [("HOME",cwd) ,("TESTS_WD",cwd) @@ -55,40 +60,48 @@ ,("PATH",(darcs_path++":"++path)) ,("DARCS_DONT_COLOR","1") ,("DARCS_DONT_ESCAPE_ANYTHING","1")] - bash <- find_bash - let shell = takeWhile (/= '\n') bash + shell = takeWhile (/= '\n') bash putStrLn $ "Using bash shell in '"++shell++"'" - set_prefs + catch (appendFile (".darcs/defaults") "\nALL --ignore-times\n") + (\e -> fail $ "Unable to set preferences: " ++ show e) run_helper shell tests [] (set_env myenv env) - where get_darcs_path = do - env <- getEnvironment - cwd <- getCurrentDirectory - case lookup "DARCS" env of - Nothing -> return (cwd ++ "/..") - Just d -> return $ takeDirectory d - set_prefs = do - finally (catch (appendFile ".darcs/defaults" "\nALL --ignore-times\n") - (\e -> fail $ "Unable to set preferences: " - ++ show e)) - (createDirectoryIfMissing False ".darcs") + +data Status = Success | Failed | Skipped + run_helper :: String -> [String] -> [String] -> [(String,String)] -> IO [String] run_helper _ [] fails _ = return fails run_helper shell (test:ts) fails env = do putStr $ "Running " ++ test ++ " ..." ++ (replicate (36 - (length test)) ' ') - (output,success) <- backtick shell test env - if success then do putStrLn " passed." - cleanup_dirs - run_helper shell ts fails env - else do putStrLn " failed." - putStrLn $ "Probable reason :" ++ output - cleanup_dirs - run_helper shell ts (fails++[test]) env - where cleanup_dirs :: IO () - cleanup_dirs = + (output,result) <- backtick shell test env + cleanup + case result of + Skipped -> do putStrLn " skipped." + run_helper shell ts fails env + Success -> do putStrLn " passed." + run_helper shell ts fails env + Failed -> do putStrLn " failed." + putStrLn $ "Probable reason :" ++ output + run_helper shell ts (fails++[test]) env + where cleanup :: IO () + cleanup = do dirfiles <- getDirectoryContents (fromJust $ lookup "TESTS_WD" env) let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) ++ (filter ("tmp" `isPrefixOf`) dirfiles) + when (isJust $ lookup "HPCTIXDIR" env) $ do + let tixdir = fromJust $ lookup "HPCTIXDIR" env + tixlist <- getDirectoryContents tixdir + oldsum <- if ("sum.tix" `elem` tixlist) + then do renameFile (tixdir "sum.tix") + (tixdir "oldsum.tix") + return [tixdir "oldsum.tix"] + else return [] + let tixfiles = oldsum ++ [ tixdir f | f <- tixlist + , "darcs-" `isPrefixOf` f + , ".tix" `isSuffixOf` f ] + system $ "hpc sum --union --output=" ++ tixdir "sum.tix" ++ " " ++ unwords tixfiles + forM tixfiles $ \f -> removeFile f + return () mapM_ (\x-> setPermissions x (Permissions {readable = True @@ -98,12 +111,13 @@ ) ) tempfiles -backtick :: String -> String -> [(String, String)]-> IO (String,Bool) +backtick :: String -> String -> [(String, String)]-> IO (String,Status) backtick cmd args env = do (exitcode,res) <- backtick_helper cmd args env case exitcode of - ExitSuccess -> return (res, True) - ExitFailure _ -> return (res, False) + ExitSuccess -> return (res, Success) + ExitFailure 200 -> return (res, Skipped) + ExitFailure _ -> return (res, Failed) backtick_helper :: String -> String -> [(String,String)] -> IO (ExitCode, String) diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 --- /dev/null +++ b/GNUmakefile @@ -0,0 +1,62 @@ +### XXX we eventually want building of the manual to be part of Setup.lhs + +# hardcode some bits +RUBBER=rubber + +DARCS = dist/build/darcs/darcs +PREPROC=./dist/build/darcs/darcs --preprocess-manual +PREPROCHTML=--html +TEXSOURCES = src/darcs.tex $(wildcard src/*.tex) $(filter %.lhs,$(DARCS_FILES)) +doc/manual/darcs.tex: $(TEXSOURCES) $(DARCS) + $(PREPROC) darcs.tex $(PREPROCHTML) >$@ +doc/manual/darcs_print.tex: $(TEXSOURCES) $(DARCS) + $(PREPROC) darcs.tex >$@ +doc/manual/patch-theory.tex: $(TEXSOURCES) $(UNIT_FILES) $(DARCS) + $(PREPROC) Darcs/Patch/Properties.lhs >$@ + +%.pdf: %.tex + cd $(), splitDirectories, isAbsolute ) import Foreign.Marshal.Utils ( with ) @@ -99,7 +101,7 @@ "bugs-darcs-2.dir", "bugs-hashed.dir", "bugs-old-fashioned-inventory.dir", - "tests_network-.dir"], + "tests-network.dir"], sDistHook = \ pkg lbi hooks flags -> do let pkgVer = packageVersion pkg @@ -108,8 +110,13 @@ y <- context verb pkgVer rewriteFile "release/distributed-version" $ show x rewriteFile "release/distributed-context" $ show y + putStrLn "about to hand over" + let pkg' = pkg { library = sanity (library pkg) } + sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib } + sanity _ = error "eh" + sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] } - sDistHook simpleUserHooks pkg lbi hooks flags + sDistHook simpleUserHooks pkg' lbi hooks flags } -- | For @./Setup build@ and @./Setup haddock@, do some unusual @@ -117,17 +124,13 @@ commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a) -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a commonBuildHook runHook pkg lbi hooks verbosity = do - -- Autoconf may have generated a context file. Remove it before - -- building, as its existence inexplicably breaks Cabal. - removeFile "src/Context.hs" - `catch` (\e -> unless (isDoesNotExistError e) (ioError e)) + (version, state) <- determineVersion verbosity pkg -- Create our own context file. - writeGeneratedModules verbosity pkg lbi + generateVersionModule verbosity pkg lbi version state -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c) -- invocations, doing a dance to make the base hook aware of them. - (version, state) <- determineVersion verbosity pkg littleEndian <- testEndianness let args = ("-DPACKAGE_VERSION=" ++ show' version) : ("-DPACKAGE_VERSION_STATE=" ++ show' state) : @@ -168,14 +171,6 @@ (mandir (absoluteInstallDirs pkg lbi copy) "man1") [(buildDir lbi "darcs", "darcs.1")] -writeGeneratedModules :: Verbosity - -> PackageDescription -> LocalBuildInfo -> IO () -writeGeneratedModules verbosity pkg lbi = do - createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) - - let contextModulePath = autogenModulesDir lbi "Context.hs" - generateContextModule verbosity contextModulePath pkg - determineVersion :: Verbosity -> PackageDescription -> IO (String, String) determineVersion verbosity pkg = do let darcsVersion = packageVersion pkg @@ -216,12 +211,16 @@ where versionFile = "release/distributed-version" -generateContextModule :: (Package pkg) => Verbosity -> FilePath -> pkg -> IO () -generateContextModule verbosity targetFile pkg = do +generateVersionModule :: Verbosity -> PackageDescription -> LocalBuildInfo + -> String -> String -> IO () +generateVersionModule verbosity pkg lbi version state = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir ctx <- context verbosity (packageVersion pkg) - rewriteFile targetFile $ unlines - ["module Context where" - ,"context :: String" + rewriteFile (dir "Version.hs") $ unlines + ["module Version where" + ,"version, context :: String" + ,"version = \"" ++ version ++ " (" ++ state ++ ")\"" ,"context = " ++ case ctx of Just x -> show x Nothing -> show "context not available" @@ -263,36 +262,41 @@ data TestKind = Bug | Test | Network deriving Eq -instance Show TestKind where - show Bug = "bugs" - show Test = "tests" - show Network = "tests/network" +testDir :: TestKind -> String +testDir Bug = "tests" +testDir Test = "tests" +testDir Network = "tests/network" -flat :: (Show a) => a -> String -flat a = [ if x == '/' then '_' else x | x <- show a ] +deslash :: Char -> Char +deslash '/' = '-' +deslash x = x -isTest :: FilePath -> Bool -isTest = (".sh" `isSuffixOf`) +isSh :: FilePath -> Bool +isSh = (".sh" `isSuffixOf`) +-- | By convention, a test script starts with "failing-" iff it is +-- expected to fail, i.e. it is a bug that hasn't been fixed yet. +isTest :: TestKind -> FilePath -> Bool +isTest Bug = ("failing-" `isPrefixOf`) +isTest _ = not . isTest Bug + execTests :: FilePath -> TestKind -> String -> [String] -> IO () execTests darcs_path k fmt tests = do - let dir = (flat k) ++ "-" ++ fmt ++ ".dir" + let dir = map deslash (testDir k) ++ (if null fmt then fmt else "-" ++ fmt) ++ ".dir" rmRf dir - cloneTree (show k) dir + cloneTree (testDir k) dir withCurrentDirectory dir $ do createDirectory ".darcs" when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n" putStrLn $ "Running tests for format: " ++ fmt - exec - where exec = do - fs <- case tests of - [] -> sort `fmap` getDirectoryContents "." - x -> return x - cwd <- getCurrentDirectory - let run = filter isTest fs - res <- Harness.runTests (Just darcs_path) cwd run - when ((not res) && (k /= Bug)) $ fail "Tests failed" - return () + fs <- case tests of + [] -> sort `fmap` getDirectoryContents "." + x -> return x + let run = filter (\f -> isSh f && isTest k f) fs + cwd <- getCurrentDirectory + res <- Harness.runTests (Just darcs_path) cwd run + when ((not res) && (k /= Bug)) $ fail "Tests failed" + return () individualTests :: FilePath -> [String] -> IO () individualTests darcs_path tests = do @@ -303,19 +307,18 @@ exec _ [] = return () exec kind to_run = allTests darcs_path kind to_run find t = do - let c = [t, t ++ ".sh"] ++ tryin "tests" t ++ tryin "bugs" t + let c = [t, t ++ ".sh"] ++ tryin "tests" t ++ tryin "network" t run <- map kindify `fmap` filterM doesFileExist c return $ take 1 run kindify test = case splitDirectories test of - [p, y] -> (parse_kind p, y) + [p, y] -> (parse_kind p y, y) _ -> error $ "Bad format in " ++ test ++ ": expected type/test" - parse_kind "tests" = Test - parse_kind "bugs" = Bug - parse_kind "network" = Network - parse_kind x = error $ "Test prefix must be one of " ++ - "[tests, bugs, network] in " ++ x + parse_kind "tests" y = if isTest Bug y then Bug else Test + parse_kind "network" _ = Network + parse_kind x _ = error $ "Test prefix must be one of " ++ + "[tests, network] in " ++ x allTests :: FilePath -> TestKind -> [String] -> IO () diff --git a/bugs/add_permissions.sh b/bugs/add_permissions.sh deleted file mode 100644 --- a/bugs/add_permissions.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/env bash -## Darcs should refuse to add an unreadable file, because unreadable -## files aren't recordable. -## -## Copyright (C) 2005 Mark Stosberg -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -abort_windows # does not work on Windows. -rm -rf temp1 # Another script may have left a mess. -darcs initialize --repodir temp1 -touch temp1/unreadable -chmod a-r temp1/unreadable # Make the file unreadable. -not darcs add --repodir temp1 no_perms.txt 2>temp1/log -fgrep -i 'permission denied' temp1/log -rm -rf temp1 diff --git a/bugs/dist-v.sh b/bugs/dist-v.sh deleted file mode 100644 --- a/bugs/dist-v.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -set -ev - -# tests for "darcs dist" - -not () { "$@" && exit 1 || :; } - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -# needs fixed on FreeBSD -darcs dist -v 2> log -not grep error log -cd .. - -rm -rf temp1 - diff --git a/bugs/emailformat.sh b/bugs/emailformat.sh deleted file mode 100644 --- a/bugs/emailformat.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env bash - -# This appears to hang on Windows - -set -ev -# TODO: is this really enough to make all commands interpret the given strings -# as latin1? -export LANG="en_US.ISO-8859-1" - -rm -rf temp1 -rm -rf temp2 -mkdir temp1 -mkdir temp2 -cd temp1 - -seventysevenaddy="" - -darcs init - -echo "Have you seen the smørrebrød of René Çavésant?" > non_ascii_file -darcs add non_ascii_file -darcs record -am "non-ascii file add" -A test - -cd ../temp2 -darcs init -cd ../temp1 - -# long email adress: check that email adresses of <= 77 chars don't get split up -darcs send --from="Kjålt Überström $seventysevenaddy" \ - --subject "Un patch pour le répositoire" \ - --to="Un garçon français " \ - --sendmail-command='cp /dev/stdin mail_as_file %<' \ - -a ../temp2 - -cat mail_as_file -# The long mail address should be in there as a whole -grep $seventysevenaddy mail_as_file - -# Check that there are no non-ASCII characters in the mail -ghc -e 'getContents >>= return . not . any (> Data.Char.chr 127)' < mail_as_file | grep '^True$' - - -cd .. -rm -rf temp1 -rm -rf temp2 - diff --git a/bugs/issue1013_either_dependency.sh b/bugs/issue1013_either_dependency.sh deleted file mode 100644 --- a/bugs/issue1013_either_dependency.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/env bash -set -ev -export DARCS_EMAIL=test -rm -rf tmp_d1 tmp_d2 tmp_d -# Preparations: -# Set up two repos, each with a patch (d1 and d2 respectively) with both -# an individual change and a change that is identical in both repos, -# and thus auto-merge, i.e., they don't conflict in darcs2. Pull them -# together and record a patch (problem) on top of the auto-merged change, -# so that it depends on EITHER of two patches. - -mkdir tmp_d1; cd tmp_d1 -darcs init --darcs-2 -echo a > a -echo b > b -echo c > c -darcs rec -alm init -echo a-independent > a -echo c-common > c -darcs rec -am d1 -cd .. -darcs get --to-patch init tmp_d1 tmp_d2 -cd tmp_d2 -echo b-independent > b -echo c-common > c -darcs rec -am d2 -darcs pull -a ../tmp_d1 -# no conflicts -- c-common is identical -echo c-problem > c -darcs rec -am problem -cd .. - -# I want to pull the 'problem' patch, but expect darcs to get confused -# because it doesn't know how to select one of the two dependent patches. - -darcs get --to-patch init tmp_d2 tmp_d -cd tmp_d -echo n/n/y |tr / \\012 |darcs pull ../tmp_d2 -darcs cha - -# This is weird, we got d2 though we said No. I would have expected -# darcs to skip the 'problem' patch in this case. - -# Try to pull d1 and unpull d2. - -darcs pull -a ../tmp_d1 -exit 1 # darcs hangs here (2.0.2+77)! -echo n/y/d |tr / \\012 |darcs obl -p d2 - -# The obliterate fails with: patches to commute_to_end does not commutex (1) - -cd .. -rm -rf tmp_d1 tmp_d2 tmp_d diff --git a/bugs/issue1014_identical_patches.sh b/bugs/issue1014_identical_patches.sh deleted file mode 100644 --- a/bugs/issue1014_identical_patches.sh +++ /dev/null @@ -1,60 +0,0 @@ -#!/usr/bin/env bash -set -ev - -# Set up a base repo. Our experiment will start from this point -mkdir base -cd base -darcs init --darcs-2 -printf "Line1\nLine2\nLine3\n" > foo -darcs rec -alm Base -cd .. - -# Now we want to record patch A, which will turn "Line2" into "Hello" -darcs get base a -cd a -printf "Line1\nHello\nLine3\n" > foo -darcs rec --ignore-times -am A -cd .. - -# Make B the same as A -darcs get base b -cd b -printf "Line1\nHello\nLine3\n" > foo -darcs rec --ignore-times -am B -cd .. - -# Now we make a patch C that depends on A -darcs get a ac -cd ac -printf "Line1\nWorld\nLine3\n" > foo -darcs rec --ignore-times -am C -cd .. - -# Merge A and B -darcs get a ab -cd ab -darcs pull -a ../b -darcs revert -a -cd .. - -# And merge in C too -darcs get ab abc -cd abc -darcs pull -a ../ac -darcs revert -a -cd .. - -# Now we can pull just B and C into base -darcs get base bc -cd bc -darcs pull ../abc -ap 'B|C' -cd .. - -# Now we have base, B and C in a repository. At this point we're correct. - -# Let's try merging AC with BC now, here we discover a bug. - -darcs get ac abc2 -cd abc2 -darcs pull -a ../bc - diff --git a/bugs/issue1190_unmarked_hunk_replace_conflict.sh b/bugs/issue1190_unmarked_hunk_replace_conflict.sh deleted file mode 100644 --- a/bugs/issue1190_unmarked_hunk_replace_conflict.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1190 - conflicts between HUNK and REPLACE are not -## marked by --mark-conflicts. -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -rm -rf d e # Another script may have left a mess. -darcs init --repo d/ -printf %s\\n foo bar baz >d/f -darcs record --repo d/ -lam f1 -darcs get d/ e/ -darcs replace --repo e/ --force bar baz f -darcs record --repo e/ -lam replacement -printf %s\\n foo bar quux >d/f # replace baz with quux -darcs record --repo d/ -am f2 - -## There ought to be a conflict here, and there is. -darcs pull --repo e/ d/ -a --mark-conflicts -## The file ought to now have conflict markers in it. -grep 'v v v' e/f -rm -rf d/ e/ # Clean up after ourselves. diff --git a/bugs/issue1196_whatsnew_falsely_lists_all_changes.sh b/bugs/issue1196_whatsnew_falsely_lists_all_changes.sh deleted file mode 100644 --- a/bugs/issue1196_whatsnew_falsely_lists_all_changes.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash -set -ev - -not () { "$@" && exit 1 || :; } - -rm -rf temp1 -mkdir temp1 -cd temp1 - -darcs init -touch aargh -darcs add aargh -echo utrecht > aargh - -darcs wh foo foo/../foo/. > out -cat out -not grep utrecht out - -cd .. -rm -rf temp1 - diff --git a/bugs/issue1266_init_inside_a_repo.sh b/bugs/issue1266_init_inside_a_repo.sh deleted file mode 100644 --- a/bugs/issue1266_init_inside_a_repo.sh +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1266 - attempting to initialize a repository inside -## another repository should cause a warning, because while perfectly -## legitimate, it is likely to be accidental. -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -rm -rf temp1 out # Another script may have left a mess. -darcs init --repodir temp1 -darcs init --repodir temp1/temp2 2>&1 | tee out -grep -i WARNING out # A warning should be printed. diff --git a/bugs/issue1327.sh b/bugs/issue1327.sh deleted file mode 100644 --- a/bugs/issue1327.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/env bash -set -ev - -# See issue1327. -# results in the error: -# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452 - - -rm -rf temp1 temp2 -mkdir temp1 -cd temp1 -darcs init -echo fileA version 1 > fileA -echo fileB version 1 > fileB -darcs add fileA fileB -darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB" -echo fileA version 2 > fileA -darcs record --author foo@bar --ignore-times --all -m "Modify fileA" -cd .. -darcs get temp1 temp2 -cd temp2 -darcs obliterate -p "Modify fileA" --all -darcs unrecord -p "Add fileA and fileB" --all -darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA" -cd ../temp1 -darcs pull --all ../temp2 -echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB" diff --git a/bugs/issue1337_darcs_changes_false_positives.sh b/bugs/issue1337_darcs_changes_false_positives.sh deleted file mode 100644 --- a/bugs/issue1337_darcs_changes_false_positives.sh +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1337 - darcs changes shows unrelated patches -## Asking "darcs changes" about an unrecorded file d/f will list the -## patch that creates the parent directory d/ (instead of no patches). -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -rm -rf temp1 -darcs init --repodir temp1 -cd temp1 -mkdir d -darcs record -lam d d -# We use --match 'touch d/f' instead of simply d/f because the latter -# prints "Changes to d/f:\n" before the count. -test 0 -eq "$(darcs changes --count --match 'touch d/f')" diff --git a/bugs/issue1396_changepref-conflict.sh b/bugs/issue1396_changepref-conflict.sh deleted file mode 100644 --- a/bugs/issue1396_changepref-conflict.sh +++ /dev/null @@ -1,32 +0,0 @@ -#!/usr/bin/env bash -set -ev - -. ../tests/lib - -rm -rf temp1 temp1a temp1b - -mkdir temp1 -cd temp1 -darcs init -darcs setpref test 'echo nothing' -darcs record -am 'null pref' -cd .. - -darcs get temp1 temp1a -cd temp1a -darcs setpref test 'echo a' -darcs record -am 'pref a' -cd .. - -darcs get temp1 temp1b -cd temp1b -darcs setpref test 'echo b' -darcs record -am 'pref b' -cd .. - -cd temp1 -darcs pull -a ../temp1a --dont-allow-conflicts -not darcs pull -a ../temp1b --dont-allow-conflicts -cd .. - -rm -rf temp1 temp1a temp1b diff --git a/bugs/issue1401_bug_in_get_extra.sh b/bugs/issue1401_bug_in_get_extra.sh deleted file mode 100644 --- a/bugs/issue1401_bug_in_get_extra.sh +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1401 - when two repos share a HUNK patch, but that -## patch's ADDFILE dependency is met by different patches in each -## repo, it becomes impossible to pull between the two repos. -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -## This bug only affects darcs-2 repositories. -fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0 - -rm -rf d e # Another script may have left a mess. -darcs initialize --repodir d/ -darcs initialize --repodir e/ -touch d/f d/g e/f -darcs record --repodir d/ -lam 'Add f and g' -darcs record --repodir e/ -lam 'Add f' -echo >d/f -darcs record --repodir d/ -am 'Change f' -darcs pull --repodir e/ -a d/ -darcs obliterate --repodir e/ -ap 'Add f and g' -darcs pull --repodir e/ -a d/ -rm -rf d/ e/ # Clean up after ourselves. diff --git a/bugs/issue1406.sh b/bugs/issue1406.sh deleted file mode 100644 --- a/bugs/issue1406.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh -rm -rf temp1 -darcs init --repodir temp1 - -cd temp1 - -echo "test exit 1" > _darcs/prefs/prefs -echo "name" > _darcs/prefs/author -echo "a" > a -darcs record --look-for-adds --no-test --all --patch-name=p1 -echo "b" >> a -echo "y" | darcs amend-record --all --patch=p1 - -# There should be one patch in the repo -test 1 -eq `darcs changes --count` || exit 1 - -# Another check: there should be nothing new after a is restored -echo "a" > a -darcs whatsnew -l && exit 1 || exit 0 diff --git a/bugs/issue1442_encoding_round-trip.sh b/bugs/issue1442_encoding_round-trip.sh deleted file mode 100644 --- a/bugs/issue1442_encoding_round-trip.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env bash -## -*- coding: utf-8 -*- -## Test for issue1442 - if we disable Darcs escaping and don't change -## our encoding, the bytes in a filename should be the same bytes that -## "darcs changes -v" prints to the right of "addfile" and "hunk". -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -rm -rf R # Another script may have left a mess. - -## Use the first UTF-8 locale we can find. -export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1) -export DARCS_DONT_ESCAPE_ANYTHING=True - -## If LC_ALL is the empty string, this system doesn't support UTF-8. -if test -z "$LC_ALL" -then exit 1 -fi - -darcs init --repo R -echo '首頁 = א₀' >R/'首頁 = א₀' -darcs record --repo R -lam '首頁 = א₀' '首頁 = א₀' -darcs changes --repo R -v '首頁 = א₀' >R/log -#cat R/log # Show the humans what the output was. -grep -c '首頁 = א₀' R/log >R/count -echo 5 >R/expected-count -cmp R/count R/expected-count # Both count files should contain "5\n". -rm -rf R # Clean up after ourselves. diff --git a/bugs/issue1461_case_folding.sh b/bugs/issue1461_case_folding.sh deleted file mode 100644 --- a/bugs/issue1461_case_folding.sh +++ /dev/null @@ -1,83 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1461 - patches to files whose names only differ by -## case can be wrongly applied to the same file in the working directory. -## -## Copyright (C) 2009 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib # Load some portability helpers. -rm -rf lower upper joint # Another script may have left a mess. -mkdir lower upper - -cd lower -darcs init -cat > a << EOF -1 -2 -3 -EOF -darcs add a -darcs record -am 'lower init a' -cd .. - -cd upper -darcs init -cat > A << EOF -1 -2 -3 -EOF -darcs add A -darcs record -am 'upper init A' -cd .. - -darcs get lower joint -cd joint -darcs pull -a ../upper -cd .. - -cd lower -cat > a << EOF -one lower -2 -3 -EOF -darcs record -am 'lower modify' -cd .. - -cd upper -cat > A << EOF -1 -2 -three upper -EOF -darcs record -am 'upper modify' -cd .. - -cd joint -darcs pull ../lower -a -darcs pull ../upper -a -grep one a && not grep three a -grep three A && not grep one A -cd .. -# clean up after ourselves -rm -rf lower upper joint diff --git a/bugs/issue1473_annotate_repodir.sh b/bugs/issue1473_annotate_repodir.sh deleted file mode 100644 --- a/bugs/issue1473_annotate_repodir.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash -set -ev - -. ../tests/lib -rm -rf temp -mkdir temp -cd temp -darcs init -mkdir a b -touch a/a b/b -darcs add --rec . -darcs record -a -m ab -A test -darcs annotate a/a -# annotate --repodir=something '.' should work -cd .. -darcs annotate --repodir temp '.' -cd temp - -cd .. -rm -rf temp - diff --git a/bugs/issue27.sh b/bugs/issue27.sh deleted file mode 100644 --- a/bugs/issue27.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh - -set -ev - -rm -rf temp1 temp2 -mkdir temp1 temp2 -cd temp1 -darcs init -echo first > a -darcs add a -darcs record --pipe --all --patch-name=first < b -darcs add b -darcs record --pipe --all --patch-name=first <> a -darcs record --pipe --all --patch-name=second <> b -darcs record --pipe --all --patch-name=second < file1 -date > file2 -darcs add file* -darcs record -am "test" - -strace darcs whatsnew file1 &> out -# we should be accessing file1 -grep file1 out -# but shouldn't be accessing file2 -if grep file2 out -then - echo A whatsnew for file1 should not involve a 'stat' call to file2 - exit 1 -else - echo Yay. We pass. -fi - -rm -rf temp diff --git a/bugs/issue558_broken_pipe.sh b/bugs/issue558_broken_pipe.sh deleted file mode 100644 --- a/bugs/issue558_broken_pipe.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env bash - -# For issue588, "amend-record --look-for-adds end up with two "addfile" entries" - -set -ev -rm -rf temp1 -darcs init --repodir temp1 - -export EMAIL=me - -cd temp1 - -date > f -darcs add f -darcs rec -am p1 -for (( i=0 ; i < 500; i=i+1 )); do - echo $i >> f; - darcs rec -am p$i -done - -darcs changes 2> err | head - -touch correcterr - -diff correcterr err - -cd .. - -rm -rf temp1 diff --git a/bugs/issue944_partial_inventory.sh b/bugs/issue944_partial_inventory.sh deleted file mode 100644 --- a/bugs/issue944_partial_inventory.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env bash - -set -ev - -test $DARCS || DARCS=$PWD/../darcs -ACTUAL_DARCS=`which $DARCS` -DARCSPATH=`dirname $ACTUAL_DARCS` -PATH="$DARCSPATH:$PATH" -export PATH - -# create base repository -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init - -echo first > a -darcs add a -darcs record -am first -darcs tag --checkpoint 'Tag 1' - -echo second > b -darcs add b -darcs record -am second -darcs tag --checkpoint 'Tag 2' - -echo third > c -darcs add c -darcs record -am third -darcs tag --checkpoint 'Tag 3' - -# create a partial copy of the base repository and modify it -cd .. -rm -rf temp2 -darcs get --partial temp1 temp2 -cd temp2 - -# instead of the following three commands one could also use darcs optimize -echo mistake > a -darcs record -am mistake -darcs unrecord -ap mistake - -# now check the repository -darcs check -# => darcs: failed to read patch: ... - diff --git a/bugs/merging_newlines.sh b/bugs/merging_newlines.sh deleted file mode 100644 --- a/bugs/merging_newlines.sh +++ /dev/null @@ -1,47 +0,0 @@ -#!/usr/bin/env bash -set -ev - -# Note that this is fixed, the lines marked # BUG HERE -# should be moved back into merging_newlines.sh - -# trick: requiring something to fail -not () { "$@" && exit 1 || :; } - -rm -rf temp1 temp2 - -# set up the repository -mkdir temp1 -cd temp1 -darcs init -cd .. - -cd temp1 -echo "apply allow-conflicts" > _darcs/prefs/defaults -# note: to make this pass, change echo to echo -n -# is that right? -echo "from temp1" > one.txt -darcs add one.txt -darcs record -A bar -am "add one.txt" -echo >> one.txt -darcs wh -u -cd .. - -darcs get temp1 temp2 -cd temp2 -# reality check -darcs show files | grep one.txt -echo "in tmp2" >> one.txt -darcs whatsnew -s | grep M -darcs record -A bar -am "add extra line" -darcs annotate -p . -u -darcs push -av > log -cat log -not grep -i conflicts log -# BUG HERE -# after a conflict, darcs resolve should report a conflict -darcs mark-conflicts > log 2>&1 -cat log -not grep -i 'no conflicts' log -cd .. - -rm -rf temp1 temp2 diff --git a/bugs/newlines.sh b/bugs/newlines.sh deleted file mode 100644 --- a/bugs/newlines.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash -set -ev - -rm -rf temp1 temp2 - -# set up the repository -mkdir temp1 -cd temp1 -darcs init -cd .. - -cd temp1 -echo -n "from temp1" > one.txt -darcs add one.txt -darcs record -A bar -am "add one.txt" -echo >> one.txt -cd .. - -darcs get temp1 temp2 -cd temp2 -echo "in tmp2" >> one.txt -darcs record -A bar -am "add extra line" -lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l` -echo $lines_added -test $lines_added -eq 1 -cd .. - -rm -rf temp1 temp2 diff --git a/bugs/nfs-failure.sh b/bugs/nfs-failure.sh deleted file mode 100644 --- a/bugs/nfs-failure.sh +++ /dev/null @@ -1,35 +0,0 @@ -#!/bin/sh - -set -ev - -rm -rf temp1 temp2 -mkdir temp1 -cd temp1 -darcs init -echo first > a -darcs add a -darcs record --pipe --all --patch-name=first < b -darcs add b -darcs record --pipe --all --patch-name=first < foobar -darcs add foobar -sleep 2 # so the time stamps won't accidentally be identical -darcs record -am 'add foobar' - -HASHVAL=0000000025-4cbbfd8ce543076b132b13b60ae06d0189ee80b4d5908abb5e060d331d25eb5c - -if test -d _darcs/pristine.hashed; -then - ls _darcs/pristine.hashed - test -f _darcs/pristine.hashed/$HASHVAL - # verify that the modification time of the file in the pristine cache - # is identical to the modification time of the file in the working - # directory. - not test foobar -ot _darcs/pristine.hashed/$HASHVAL - not test foobar -nt _darcs/pristine.hashed/$HASHVAL -else - not test foobar -ot _darcs/pristine/foobar - not test foobar -nt _darcs/pristine/foobar -fi - -# Now let's verify that the test actually works... - -sleep 1 -touch foobar - -if test -d _darcs/pristine.hashed; -then - not test foobar -ot _darcs/pristine.hashed/$HASHVAL - test foobar -nt _darcs/pristine.hashed/$HASHVAL -else - not test foobar -ot _darcs/pristine/foobar - test foobar -nt _darcs/pristine/foobar -fi - - -cd .. - -rm -rf temp diff --git a/contrib/cgi/README.in b/contrib/cgi/README.in deleted file mode 100644 --- a/contrib/cgi/README.in +++ /dev/null @@ -1,42 +0,0 @@ -darcs.cgi is the darcs repository viewer. It provides a web interface -for viewing darcs repositories, using XSLT to transform darcs' XML -output into XHTML. It is written in perl and is more featureful than -the older haskell cgi program darcs_cgi.lhs (seen in URLs as "darcs"). - -dependencies - - darcs.cgi requires with the following tools and has been tested with - the version mentioned: - - darcs-1.0.1 http://www.darcs.net - libxslt-1.1.6 http://xmlsoft.org/XSLT/ - perl-5.8.0 http://www.perl.com - -installation - - 1) copy darcs.cgi to your webserver's cgi directory, eg - /usr/lib/cgi-bin. A symlink probably won't do. Make - sure it's executable. - 2) copy cgi.conf to @sysconfdir@/darcs/cgi.conf and edit appropriately. - You can overwrite the cgi.conf used by the old darcs cgi script. - You probably don't need to change anything here. - 3) copy the xslt directory to @datadir@/darcs/xslt - 4) copy xslt/styles.css to @sysconfdir@/darcs/styles.css - - Test by browsing "http:///cgi-bin/darcs.cgi/". - -troubleshooting - - if the configuration is incorrect error messages will be printed to - the webserver's error log, for example "/var/log/apache/error.log". - - you can also double check the configuration by running darcs.cgi - from the command line and supplying a --check argument: - - $ ./darcs.cgi --check - -character encodings - - if your repositories contain files with characters encoded in - something other than ASCII or UTF-8, change the 'xml_encoding' - setting in cgi.conf to the appropriate encoding. diff --git a/contrib/cgi/cgi.conf.in b/contrib/cgi/cgi.conf.in deleted file mode 100644 --- a/contrib/cgi/cgi.conf.in +++ /dev/null @@ -1,31 +0,0 @@ -# This is an example for cgi.conf - -# reposdir is the directory containing the repositories - -reposdir = /var/www/repos - -# cachedir is a directory writable by www-data (or whatever user your cgi -# scripts run as) which is used to cache the web pages. - -cachedir = /var/cache/darcs - -# The following are used by darcs.cgi (not darcs_cgi) -PATH = /bin:/usr/bin:/usr/local/bin - -# paths to executables, or just the executables if they are in 'PATH' -#darcs = darcs -#xsltproc = xsltproc - -# Path to XSLT templates (default is /usr/local/share/darcs/xslt) -xslt_dir = @datadir@/darcs/xslt - -# HTTP request path of the style sheet, the default will magically read -# @sysconfdir@/darcs/styles.css -#stylesheet = /cgi-bin/darcs.cgi/styles.css - -css_styles = @sysconfdir@/darcs/styles.css - -# encoding to include in XML declaration. Set this to the encoding used -# by the files in your repositories. - -xml_encoding = UTF-8 diff --git a/contrib/cgi/darcs.cgi.in b/contrib/cgi/darcs.cgi.in deleted file mode 100644 --- a/contrib/cgi/darcs.cgi.in +++ /dev/null @@ -1,491 +0,0 @@ -#!/usr/bin/perl -T -# -# darcs.cgi - the darcs repository viewer -# -# Copyright (c) 2004 Will Glozer -# -# Permission is hereby granted, free of charge, to any person obtaining -# a copy of this software and associated documentation files (the -# "Software"), to deal in the Software without restriction, including -# without limitation the rights to use, copy, modify, merge, publish, -# distribute, sublicense, and/or sell copies of the Software, and to -# permit persons to whom the Software is furnished to do so, subject to -# the following conditions -# -# The above copyright notice and this permission notice shall be -# included in all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -# LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -# OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -# -# This program calls darcs (or its own subroutines) to generate XML -# which is rendered into HTML by XSLT. It is capable of displaying -# the files in a repository, various patch histories, annotations, etc. -# - -use strict; - -use CGI qw( :standard ); -use CGI::Util; -use File::Basename; -use File::stat; -use IO::File; -use POSIX; - -## the following variables can be customized to reflect your system -## configuration by defining them appropriately in the file -## "@sysconfdir@/darcs/cgi.conf". The syntax accepts equals signs or simply -## blanks separating values from assignments. - -$ENV{'PATH'} = read_conf('PATH', $ENV{'PATH'}); - -# path to executables, or just the executable if they are in $ENV{'PATH'} -my $darcs_program = read_conf("darcs", "darcs"); -my $xslt_program = read_conf("xsltproc", "xsltproc"); - -# directory containing repositories -my $repository_root = read_conf("reposdir", "/var/www"); - -# XSLT template locations -my $template_root = read_conf("xslt_dir", '@datadir@/darcs/xslt'); - -my $xslt_annotate = "$template_root/annotate.xslt"; -my $xslt_browse = "$template_root/browse.xslt"; -my $xslt_patches = "$template_root/patches.xslt"; -my $xslt_repos = "$template_root/repos.xslt"; -my $xslt_rss = "$template_root/rss.xslt"; - -my $xslt_errors = "$template_root/errors.xslt"; - -# CSS stylesheet that XSLT templates refer to. This is a HTTP request -# path, not a local file system path. The default will cause darcs.cgi -# to serve the stylesheet rather than the web server. -my $stylesheet = read_conf("stylesheet", "/cgi-bin/darcs.cgi/styles.css"); - -# location of the CSS stylesheet that darcs.cgi will serve if it -# receives a request for '/styles.css' -my $css_styles = read_conf("css_styles", '@sysconfdir@/darcs/styles.css'); - -# location of the favicon that darcs.cgi will serve if it -# receives a request for '/[\w\-]+/favicon.ico' -my $favicon = read_conf("favicon", "/cgi-bin/favicon.ico"); - -# XML source for the error pages -my $xml_errors = "$template_root/errors.xml"; - -# encoding to include in XML declaration -my $xml_encoding = read_conf("xml_encoding", "UTF-8"); - -## end customization - -# ---------------------------------------------------------------------- - -# read a value from the cgi.conf file. -{ - my(%conf); - - sub read_conf { - my ($flag, $val) = @_; - $val = "" if !defined($val); - - if (!%conf && open(CGI_CONF, '@sysconfdir@/darcs/cgi.conf')) { - while () { - chomp; - next if /^\s*(?:\#.*)?$/; # Skip blank lines and comment lines - if (/^\s*(\S+)\s*(?:\=\s*)?(\S+)\s*$/) { - $conf{$1} = $2; - # print "read_conf: $1 = $2\n"; - } else { - warn "read_conf: $_\n"; - } - } - close(CGI_CONF); - } - - $val = $conf{$flag} if exists($conf{$flag}); - - return $val; - } -} - -# open xsltproc to transform and output `xml' with stylesheet file `xslt' -sub transform { - my ($xslt, $args, $content_type) = @_; - - $| = 1; - printf "Content-type: %s\r\n\r\n", $content_type || "text/html"; - my $pipe = new IO::File "| $xslt_program $args $xslt -"; - $pipe->autoflush(0); - return $pipe; -} - -sub pristine_dir { - my ($repo) = @_; - my $pristine = "current"; - if (! -d "${repository_root}/${repo}/_darcs/$pristine") { - $pristine = "pristine"; - } - return "${repository_root}/${repo}/_darcs/$pristine"; -} - -# begin an XML document with a root element and the repository path -sub make_xml { - my ($fh, $repo, $dir, $file) = @_; - my ($full_path, $path) = '/'; - - printf $fh qq(\n); - - printf $fh qq(\n), - $repo, ($dir ? "$dir/" : ''), ($file ? "$file" : ''); - - print $fh qq(\n); - foreach $path (split('/', "$repo/$dir")) { - $full_path .= "$path/"; - print $fh qq($path\n); - } - if ($file) { - print $fh qq($file\n) if $file; - } - print $fh qq(\n\n); -} - -# finish XML output -sub finish_xml { - my ($fh) = @_; - print $fh "\n\n"; - $fh->flush; -} - -# run darcs and wrap the output in an XML document -sub darcs_xml { - my ($fh, $repo, $cmd, $args, $dir, $file) = @_; - - make_xml($fh, $repo, $dir, $file); - - push(@$args, '--xml-output'); - darcs($fh, $repo, $cmd, $args, $dir, $file); - - finish_xml($fh); -} - -# run darcs with output redirected to the specified file handle -sub darcs { - my ($fh, $repo, $cmd, $args, $dir, $file) = @_; - my (@darcs_argv) = ($darcs_program, $cmd, @$args); - - # push target only if there is one, otherwise darcs will get an empty param - if ($dir || $file) { - push(@darcs_argv, sprintf("%s%s%s", $dir, ($dir ? '/' : ''), $file)); - } - - my($pid) = fork; - if ($pid) { - # in the parent process - my($status) = waitpid($pid, 0); - die "$darcs_program exited with status $?\n" if $?; - } elsif(defined($pid)) { - # in the child process - open(STDIN, '/dev/null'); - if (defined($fh)) { - open(STDOUT, '>&', $fh) - || die "can't dup to stdout: $!\n"; - } - chdir "$repository_root/$repo" - || die "chdir: $repository_root/$repo: $!\n"; - exec @darcs_argv; - die "can't exec ".$darcs_argv[0].": $!\n"; - } else { - # fork failed - die "can't fork: $!\n"; - } -} - -# get a directory listing as XML output -sub dir_listing { - my ($fh, $repo, $dir) = @_; - make_xml($fh, $repo, $dir, ''); - - print $fh "\n"; - my $dir_ = pristine_dir ($repo) . "/$dir"; - opendir(DH, $dir_); - while( defined (my $file_ = readdir(DH)) ) { - next if $file_ =~ /^\.\.?$/; - my $file = "$dir_/$file_"; - my $secs = stat($file)->mtime; - my $mtime = localtime($secs); - my $ts = POSIX::strftime("%Y%m%d%H%M%S", gmtime $secs); - - my ($name, $type); - - if (-d $file) { - ($name, $type) = (basename($file) . '/', 'directory'); - } else { - ($name, $type) = (basename($file), 'file'); - } - print $fh qq( <$type name="$name" modified="$mtime" ts="$ts" />\n); - } - closedir(DH); - print $fh "\n"; - - finish_xml($fh); -} - -# get a repository listing as XML output -sub repo_listing { - my($fh) = @_; - - make_xml($fh, "", "", ""); - - print $fh "\n"; - opendir(DH, $repository_root); - while( defined (my $name = readdir(DH)) ) { - next if $name =~ /^\.\.?$/; - if (-d "$repository_root/$name/_darcs") { - print $fh qq( \n); - } - } - closedir(DH); - print $fh "\n"; - - finish_xml($fh); - return $fh; -} - -# show an error page -sub show_error { - my ($type, $code, $message) = @_; - my $xml; - - # set the xslt processing arguments - my $xslt_args = qq { - --stringparam error-type '$type' - --stringparam stylesheet '$stylesheet' - }; - $xslt_args =~ s/\s+/ /gm; - - print "Status: $code $message\r\n\r\n"; - system("$xslt_program $xslt_args $xslt_errors $xml_errors"); -} - -# check if the requested resource has been modified since the client last -# saw it. If not send HTTP status code 304, otherwise set the Last-modified -# and Cache-control headers. -sub is_cached { - my ($path) = @_; - my ($stat) = stat($path); - - # stat may fail because the path was renamed or deleted but still referred - # to by older darcs patches - if ($stat) { - my $last_modified = CGI::expires($stat->mtime); - - if (http('If-Modified-Since') eq $last_modified) { - print("Status: 304 Not Modified\r\n\r\n"); - return 1; - } - - print("Cache-control: max-age=0, must-revalidate\r\n"); - print("Last-modified: $last_modified\r\n"); - } - return 0; -} - -# safely extract a parameter from the http request. This applies a regexp -# to the parameter which should group only the appropriate parameter value -sub safe_param { - my ($param, $regex, $default) = @_; - my $value = CGI::Util::unescape(param($param)); - return ($value =~ $regex) ? $1 : $default; -} - -# common regular expressions for validating passed parameters -my $hash_regex = qr/^([\w\-.]+)$/; -my $path_regex = qr@^([^\\!\$\^&*()\[\]{}<>`|';"?\r\n]+)$@; - -# respond to a CGI request -sub respond { - # untaint the full URL to this CGI - my $cgi_url = CGI::Util::unescape(url()); - $cgi_url =~ $path_regex or die qq(bad url "$cgi_url"); - $cgi_url = $1; - - # untaint script_name, reasonable to expect only \w, -, /, and . in the name - my $script_name = CGI::Util::unescape(script_name()); - $script_name =~ qr~^([\w/.\-\~]+)$~ or die qq(bad script_name "$script_name"); - $script_name = $1; - - # untaint simple parameters, which can only have chars matching \w+ - my $cmd = safe_param('c', '^(\w+)$', 'browse'); - my $sort = safe_param('s', '^(\w+)$', ''); - - # set the xslt processing arguments - my $xslt_args = qq { - --stringparam cgi-program '$script_name' - --stringparam cgi-url '$cgi_url' - --stringparam sort-by '$sort' - --stringparam stylesheet '$stylesheet' - }; - $xslt_args =~ s/\s+/ /gm; - - my ($path) = CGI::Util::unescape(path_info()); - # don't allow ./ or ../ in paths - $path =~ s|[.]+/||g; - - # check whether we're asking for styles.css - if ($path eq '/styles.css') { - return if is_cached($css_styles); - - open (STYLES_CSS, $css_styles) or die qq(couldn't open "${css_styles}"); - my $size = stat($css_styles)->size; - - print "Content-length: $size\r\n"; - print "Content-type: text/css\r\n\r\n"; - - while () { - print $_; - } - close (STYLES_CSS); - return; - } - - # check whether we're asking for favicon.ico - if ($path =~ '/[\w\-]+/favicon.ico') { - return if is_cached($favicon); - - open (FAVICON, $favicon) or die qq(couldn't open "${favicon}"); - my $size = stat($favicon)->size; - - print "Content-length: $size\r\n"; - print "Content-type: image/x-icon\r\n\r\n"; - - while () { - print $_; - } - close (FAVICON); - return; - } - - # when no repository is requested display available repositories - if (length($path) < 2) { - my $fh = transform($xslt_repos, $xslt_args); - repo_listing($fh); - return; - } - - # don't allow any shell meta characters in paths - $path =~ $path_regex or die qq(bad path_info "$path"); - my @path = split('/', substr($1, 1)); - - # split the path into a repository, directory, and file - my ($repo, $dir, $file, @bits) = ('', '', ''); - while (@path > 0) { - $repo = join('/', @path); - # check if remaining path elements refer to a repo - if (-d "${repository_root}/${repo}/_darcs") { - if (@bits > 1) { - $dir = join('/', @bits[0..$#bits - 1]); - } - $file = $bits[$#bits]; - # check if last element of path, stored in $file, is really a dir - if (-d (pristine_dir ($repo) . "/${dir}/${file}")) { - $dir = ($dir ? "$dir/$file" : $file); - $file = ''; - } - last; - } else { - $repo = ''; - unshift(@bits, pop @path); - } - } - - # make sure the repository exists - unless ($repo) { - show_error('invalid-repository', '404', 'Invalid repository'); - return; - } - - # don't generate output unless the requested path has been - # modified since the client last saw it. - return if is_cached(pristine_dir ($repo) . "/$dir/$file"); - - # untaint patches and tags. Tags can have arbitrary values, so - # never pass these unquoted, on pain of pain! - my $patch = safe_param('p', $hash_regex); - my $tag = safe_param('t', '^(.+)$'); - - my @darcs_args; - push(@darcs_args, '--match', "hash $patch") if $patch; - push(@darcs_args, '-t', $tag) if $tag; - - # process the requested command - if ($cmd eq 'browse') { - my $fh = transform($xslt_browse, $xslt_args); - dir_listing($fh, $repo, $dir); - } elsif ($cmd eq 'patches') { - # patches as an option is used to support "--patches" - if (my $patches = safe_param('patches','^(.+)$')) { - push @darcs_args, '--patches', $patches; - } - - my $fh = transform($xslt_patches, $xslt_args); - darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file); - } elsif ($cmd eq 'annotate') { - push(@darcs_args, '--summary'); - - my $creator_hash = safe_param('ch', $hash_regex); - my $original_path = safe_param('o', $path_regex); - my $fh = transform($xslt_annotate, $xslt_args); - - # use the creator hash and original file name when available so - # annotations can span renames - if ($creator_hash ne '' && $original_path ne '') { - push(@darcs_args, '--creator-hash', $creator_hash); - darcs_xml($fh, $repo, "annotate", \@darcs_args, '', $original_path); - } else { - darcs_xml($fh, $repo, "annotate", \@darcs_args, $dir, $file); - } - } elsif ($cmd eq 'diff') { - push(@darcs_args, '-u'); - print "Content-type: text/plain\r\n\r\n"; - darcs(undef, $repo, "diff", \@darcs_args, $dir, $file); - } elsif ($cmd eq 'rss') { - push(@darcs_args, '--last', '25'); - - my $fh = transform($xslt_rss, $xslt_args, "application/rss+xml"); - darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file); - } else { - show_error('invalid-command', '400', 'Invalid command'); - } -} - -# run a self-test when the --check argument is supplied -if ($ARGV[0] eq '--check') { - (read_conf("css_styles", "abc") ne "abc") || - die "cannot read config file: $!\n"; - - (`$darcs_program`) || - die "cannot execute darcs as '$darcs_program': $!\n"; - (`$xslt_program`) || - die "cannot execute xstlproc as '$xslt_program': $!\n"; - - (-d $repository_root && -r $repository_root) || - die "cannot read repository root directory '$repository_root': $!\n"; - (-d $template_root && -r $template_root) || - die "cannot read template root directory '$template_root': $!\n"; - (-f $css_styles) || - die "cannot read css stylesheet '$css_styles': $!\n"; - (-f $xml_errors) || - die "cannot read error messages '$xml_errors': $!\n"; - - exit 0; -} - -# handle the CGI request -respond(); - diff --git a/contrib/cgi/xslt/annotate.xslt b/contrib/cgi/xslt/annotate.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/annotate.xslt +++ /dev/null @@ -1,390 +0,0 @@ - - - - - - - - - -

- annotations for projects / -

- - - - - - - - - - - - - - - - - - - - - - - - -
filechange
- -
-

- - -

-
- - - - - - - - - - - - +/ - - - - - lines - - - annotate - patches - - - - - - - - - - added file - annotate - patches - - - - - - - - - - - moved from - annotate - patches - - - - - - - - - - removed file - annotate - patches - - - - - - - - - - added directory - annotate - patches - - - - - - - - - - removed directory - annotate - patches - - - - - - - - - - - - - - - - - - -
filechange
- - - - - - - - - - - - - - / - - - - - - - - added directory - moved directory - removed directory - - - - annotate - - patches - - - - - - - - - - - - - added file - moved file - removed file - - - annotate - patches - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
filechange
- - added file - moved file - removed file - - annotatepatches
- - - - 

-      
-
- - - - - - - - - - - - - -
- - - - - - - - - - - - - - - -
- - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

- patch " - - - - " -

- - - -

- comment " - - " -

- - - - -

- by - - - - - on - - - -

- - - - - - - - - - - - ?c=annotate&p=&ch=&o= - - - - - - - - diff --git a/contrib/cgi/xslt/browse.xslt b/contrib/cgi/xslt/browse.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/browse.xslt +++ /dev/null @@ -1,110 +0,0 @@ - - - - - - - -

- files in projects / -

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- name - (rev) - - modified - (rev) -
- - - - - - - - - - - - - annotate - - - patches - - - - - - - - - - - - - annotate - patches - - - - - diff --git a/contrib/cgi/xslt/common.xslt b/contrib/cgi/xslt/common.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/common.xslt +++ /dev/null @@ -1,66 +0,0 @@ - - - - / - - - - - - - - darcs repository - - - - - - - -
-

- - - rss - - - darcs.cgi - v1.0 - -

-
- - - - - - - - - - / - - - - - - - diff --git a/contrib/cgi/xslt/errors.xml b/contrib/cgi/xslt/errors.xml deleted file mode 100644 --- a/contrib/cgi/xslt/errors.xml +++ /dev/null @@ -1,22 +0,0 @@ - - - -

Invalid command

- -

- The requested command is invalid. -

- - - -

Invalid repository

- -

- The requested repository does not exist on this server. -

- - diff --git a/contrib/cgi/xslt/errors.xslt b/contrib/cgi/xslt/errors.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/errors.xslt +++ /dev/null @@ -1,36 +0,0 @@ - - - - - - - - - <xsl:value-of select="@title"/> - - - - - - - - - - - - - diff --git a/contrib/cgi/xslt/patches.xslt b/contrib/cgi/xslt/patches.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/patches.xslt +++ /dev/null @@ -1,125 +0,0 @@ - - - - - - - - -

- patches applied to projects / -

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- name - (rev) - - date - (rev) - - author - (rev) - -
- - - - - - - - - - - - - - ?c=annotate&p= - - &ch= - &o= - - - - - - - - - - detail - - - - - - - - - - diff --git a/contrib/cgi/xslt/repos.xslt b/contrib/cgi/xslt/repos.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/repos.xslt +++ /dev/null @@ -1,59 +0,0 @@ - - - - - - / - - - - - - darcs repository viewer - - - - -

Available Repositories

- - - -
- - - - - - - - - - - - - - - - - - - - - - - diff --git a/contrib/cgi/xslt/rss.xslt b/contrib/cgi/xslt/rss.xslt deleted file mode 100644 --- a/contrib/cgi/xslt/rss.xslt +++ /dev/null @@ -1,92 +0,0 @@ - - - - - - - - - / - - - - - - changes to <xsl:value-of select="$repo"/> - - - Recent patches applied to the darcs repository named - "". - - - - - - - - - - - - - - - - - - ?c=annotate&p= - - &ch= - &o= - - - - - - - 0 - - - - - - - - - - - - - <xsl:value-of select="name"/> - - - - - - - - - - - - - diff --git a/contrib/cgi/xslt/styles.css b/contrib/cgi/xslt/styles.css deleted file mode 100644 --- a/contrib/cgi/xslt/styles.css +++ /dev/null @@ -1,91 +0,0 @@ -/** - stylesheet for darcs repository browser -**/ - -a:link, a:visited { - color: blue; - text-decoration: none; -} - -a:hover { text-decoration: underline; } -a.sort { color: black; } -a.revsort { - color: black; - font-size: 75%; -} -a.home { color: #9292C9; } - -body { margin: 10px 10px 10px 10px; } - -h1.target { - font-size: 150%; - font-weight: bold; -} - -h2.patch { - font-size: 125%; - font-weight: bold; - margin-top: -10px; - padding-left: 10px; -} - -h2.author { - font-size: smaller; - margin-top: -10px; - font-weight: bold; - padding-left: 30px; -} - -input.patches { margin-right: 20px; } -label.tag { margin-right: 5px; } - -span.path, span.path > a { color: #2A2A6B; } - -span.version { - color: #9292C9; - margin-left: 75px; -} - -span.comment { - color: #2A2A6B; - white-space: pre; -} - -th,td { - text-align: left; - padding: 5px 10px 5px 10px; -} - -tr.annotate { background-color: #FFAAAA; } -tr.browse { background-color: #FFFF99; } -tr.patches { background-color: #AAFFAA; } -tr.directory { background-color: #CFCFCF; } -tr.file, tr.patch, tr.modified-file { background-color: #DCDCDA; } -tr.modified-file, tr.add-remove-file { background-color: #DCDCDA; } - -pre { - margin: 0 0 0 0; -} - -a.added-line { - color: #00AA00; - float: left; -} - -a.normal-line { - color: #000000; - float: left; -} - -a.removed-line { - color: #CC0000; - float: left; - text-decoration: line-through; -} - -a.removed-by { - clear: right; - color: #CC0000; - float: right; - font-size: 125%; -} diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.3.1 +version: 2.4 License: GPL License-file: COPYING Author: David Roundy , @@ -44,13 +44,12 @@ -- The contrib directory would make a sensible 'darcs-contrib' package contrib/_darcs.zsh, contrib/darcs_completion, contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi, - contrib/cgi/darcs.cgi.in, contrib/cgi/cgi.conf.in, contrib/cgi/README.in - contrib/cgi/xslt/*.xslt, contrib/cgi/xslt/*.xml, contrib/cgi/xslt/*.css, -- documentation files src/best_practices.tex, src/building_darcs.tex, src/configuring_darcs.tex, - src/features.tex, src/gpl.tex, src/switching.tex, - contrib/cgi/README.in + src/features.tex, src/formats.tex, src/gpl.tex, src/switching.tex, src/darcs.tex + doc/manual/images.tex, doc/manual/bigimages.tex, doc/manual/patch-theory.tex, + doc/darcs.css README, NEWS @@ -65,8 +64,9 @@ tests/network/*.sh tests/lib tests/example_binary.png - bugs/*.sh + GNUmakefile + source-repository head type: darcs location: http://darcs.net/ @@ -83,21 +83,17 @@ flag http description: Use the pure Haskell HTTP package for HTTP support. --- SUNSET: this should be mandatory after the 2009-07 release is out -flag bytestring - description: Use the external bytestring package. - -flag zlib - description: Use the external zlib binding package. - default: True - --- SUNSET: this should be mandatory after the 2009-07 release is out -flag utf8-string - description: Use the external utf8-string binding package. +flag static + description: Build static binary + default: False flag terminfo description: Use the terminfo package for enhanced console support. +flag threaded + description: Use threading and SMP support. + default: True + flag type-witnesses description: Use GADT type witnesses. default: False @@ -112,6 +108,13 @@ description: Compile unit tests (requires QuickCheck >= 2.1.0.0). default: False +flag hpc + default: False + +flag deps-only + default: False + description: A cunning trick to have cabal install build dependencies + Executable witnesses main-is: witnesses.hs hs-source-dirs: src @@ -120,16 +123,21 @@ -- FIXME... c-sources: src/atomic_create.c src/fpstring.c - src/c_compat.c src/maybe_relink.c src/umask.c src/Crypt/sha2.c + + extensions: + CPP + UndecidableInstances + ScopedTypeVariables + RankNTypes + GADTs + ImpredicativeTypes + if !flag(type-witnesses) buildable: False - if !flag(zlib) - extra-libraries: z - if os(windows) hs-source-dirs: src/win32 include-dirs: src/win32 @@ -205,16 +213,14 @@ Darcs.FilePathMonad Darcs.Flags Darcs.Global - Darcs.Gorsvet Darcs.Hopefully Darcs.IO Darcs.Lock Darcs.Match - Darcs.Ordered + Darcs.Witnesses.Ordered Darcs.Patch Darcs.Patch.Apply Darcs.Patch.Bundle - Darcs.Patch.Check Darcs.Patch.Choices Darcs.Patch.Commute Darcs.Patch.Core @@ -224,6 +230,7 @@ Darcs.Patch.Match Darcs.Patch.MatchData Darcs.Patch.Non + Darcs.Patch.OldDate Darcs.Patch.Patchy Darcs.Patch.Permutations Darcs.Patch.Prim @@ -231,8 +238,10 @@ Darcs.Patch.Read Darcs.Patch.ReadMonads Darcs.Patch.Real + Darcs.Patch.RegChars Darcs.Patch.Set Darcs.Patch.Show + Darcs.Patch.Split Darcs.Patch.TouchesFiles Darcs.Patch.Viewing Darcs.Population @@ -250,20 +259,24 @@ Darcs.Repository.HashedIO Darcs.Repository.HashedRepo Darcs.Repository.Internal + Darcs.Repository.LowLevel + Darcs.Repository.Merge Darcs.Repository.InternalTypes Darcs.Repository.Motd Darcs.Repository.Prefs Darcs.Repository.Pristine Darcs.Repository.Repair + Darcs.Repository.State Darcs.Resolution Darcs.RunCommand - Darcs.Sealed + Darcs.Witnesses.Sealed Darcs.SelectChanges - Darcs.Show + Darcs.Witnesses.Show Darcs.SignalHandler Darcs.SlurpDirectory Darcs.SlurpDirectory.Internal Darcs.Test + Darcs.Test.Patch.Check Darcs.TheCommands Darcs.URL Darcs.Utils @@ -274,21 +287,18 @@ HTTP IsoDate Lcs - OldDate Printer Progress - RegChars + Ratified SHA1 Ssh URL - UTF8 Workaround - other-modules: ThisVersion + other-modules: Version c-sources: src/atomic_create.c src/fpstring.c - src/c_compat.c src/maybe_relink.c src/umask.c src/Crypt/sha2.c @@ -313,23 +323,29 @@ html == 1.0.*, filepath == 1.1.*, haskeline >= 0.6.1 && < 0.7, - hashed-storage >= 0.3.8 && < 0.4 + hashed-storage >= 0.4.7 && < 0.5 if !os(windows) - build-depends: unix >= 1.0 && < 2.4 + build-depends: unix >= 1.0 && < 2.5 build-depends: base >= 3, + bytestring >= 0.9.0 && < 0.10, + utf8-string == 0.3.*, old-time == 1.0.*, directory == 1.0.*, process == 1.0.*, - containers >= 0.1 && < 0.3, - array >= 0.1 && < 0.3, + containers >= 0.1 && < 0.4, + array >= 0.1 && < 0.4, random == 1.0.* + -- We need optimizations, regardless of what Hackage says - ghc-options: -Wall -O2 -funbox-strict-fields + ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs ghc-prof-options: -prof -auto-all + if flag(hpc) + ghc-prof-options: -fhpc + if flag(curl) extra-libraries: curl includes: curl/curl.h @@ -349,26 +365,14 @@ cpp-options: -DHAVE_HTTP x-have-http: - if !flag(curl) && !flag(http) + if (!flag(curl) && !flag(http)) || flag(deps-only) buildable: False if flag(mmap) && !os(windows) build-depends: mmap >= 0.2 cpp-options: -DHAVE_MMAP - if flag(bytestring) - build-depends: bytestring >= 0.9.0 && < 0.10 - cpp-options: -DHAVE_BYTESTRING - - if flag(zlib) - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 - cpp-options: -DHAVE_HASKELL_ZLIB - else - extra-libraries: z - - if flag(utf8-string) - build-depends: utf8-string == 0.3.* - cpp-options: -DHAVE_UTF8STRING + build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) @@ -387,6 +391,7 @@ UndecidableInstances, DeriveDataTypeable, GADTs, + ImpredicativeTypes, TypeOperators, ExistentialQuantification, FlexibleContexts, @@ -409,18 +414,22 @@ include-dirs: src c-sources: src/atomic_create.c src/fpstring.c - src/c_compat.c src/maybe_relink.c src/umask.c src/Crypt/sha2.c -- We need optimizations, regardless of what Hackage says - ghc-options: -Wall -O2 -funbox-strict-fields -threaded + ghc-options: -Wall -O2 -funbox-strict-fields ghc-prof-options: -prof -auto-all + if flag(threaded) + ghc-options: -threaded - if !flag(zlib) - extra-libraries: z + if flag(static) + ghc-options: -static -optl-static -optl-pthread + if flag(hpc) + ghc-prof-options: -fhpc + cc-options: -D_REENTRANT if os(windows) @@ -444,17 +453,19 @@ html == 1.0.*, filepath == 1.1.*, haskeline >= 0.6.1 && < 0.7, - hashed-storage >= 0.3.8 && < 0.4 + hashed-storage >= 0.4.4 && < 0.5 if !os(windows) - build-depends: unix >= 1.0 && < 2.4 + build-depends: unix >= 1.0 && < 2.5 build-depends: base >= 3, + bytestring >= 0.9.0 && < 0.10, + utf8-string == 0.3.*, old-time == 1.0.*, directory == 1.0.*, process == 1.0.*, - containers >= 0.1 && < 0.3, - array >= 0.1 && < 0.3, + containers >= 0.1 && < 0.4, + array >= 0.1 && < 0.4, random == 1.0.* if flag(curl) @@ -476,26 +487,14 @@ cpp-options: -DHAVE_HTTP x-have-http: - if !flag(curl) && !flag(http) + if (!flag(curl) && !flag(http)) || flag(deps-only) buildable: False if flag(mmap) && !os(windows) build-depends: mmap >= 0.2 cpp-options: -DHAVE_MMAP - if flag(bytestring) - build-depends: bytestring >= 0.9.0 && < 0.10 - cpp-options: -DHAVE_BYTESTRING - - if flag(zlib) - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 - cpp-options: -DHAVE_HASKELL_ZLIB - else - extra-libraries: z - - if flag(utf8-string) - build-depends: utf8-string == 0.3.* - cpp-options: -DHAVE_UTF8STRING + build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) @@ -514,6 +513,7 @@ UndecidableInstances, DeriveDataTypeable, GADTs, + ImpredicativeTypes, TypeOperators, ExistentialQuantification, FlexibleContexts, @@ -536,14 +536,15 @@ include-dirs: src c-sources: src/atomic_create.c src/fpstring.c - src/c_compat.c src/maybe_relink.c src/umask.c src/Crypt/sha2.c -- We need optimizations, regardless of what Hackage says - ghc-options: -Wall -O2 -funbox-strict-fields -threaded + ghc-options: -Wall -O2 -funbox-strict-fields ghc-prof-options: -prof -auto-all + if flag(threaded) + ghc-options: -threaded if !flag(test) buildable: False @@ -562,9 +563,6 @@ test-framework-quickcheck2 >= 0.2.2 - if !flag(zlib) - extra-libraries: z - cc-options: -D_REENTRANT if os(windows) @@ -581,29 +579,22 @@ cc-options: -DHAVE_SIGINFO_H if !os(windows) - build-depends: unix >= 1.0 && < 2.4 + build-depends: unix >= 1.0 && < 2.5 build-depends: base >= 3, + bytestring >= 0.9.0 && < 0.10, old-time == 1.0.*, directory == 1.0.*, process == 1.0.*, - containers >= 0.1 && < 0.3, - array >= 0.1 && < 0.3, + containers >= 0.1 && < 0.4, + array >= 0.1 && < 0.4, random == 1.0.* if flag(mmap) && !os(windows) build-depends: mmap >= 0.2 cpp-options: -DHAVE_MMAP - if flag(bytestring) - build-depends: bytestring >= 0.9.0 && < 0.10 - cpp-options: -DHAVE_BYTESTRING - - if flag(zlib) - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 - cpp-options: -DHAVE_HASKELL_ZLIB - else - extra-libraries: z + build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) diff --git a/doc/darcs.css b/doc/darcs.css new file mode 100644 --- /dev/null +++ b/doc/darcs.css @@ -0,0 +1,94 @@ +BODY { + background: white; + color: black; + font-family: arial,sans-serif; + margin: 0; + padding: 1em; +} + +A:link { + background: transparent; + color: #494a82; +} + +A:visited { + background: transparent; + color: #8081b3 +} + +IMG.thanks-left { + float: left; + margin-right: 5px; + height: 50px; +} + +IMG.thanks-right { + float: right; + margin-left: 5px; + height: 50px; +} + +PRE { + background: #eeeeee; + border: 1px solid #888888; + color: black; + padding: 1em; + white-space: pre; +} + +H1 { + color: #494a82; + font-size: 24px ; +} + +H2 { + color: #494a82; + font-size: 18px; +} + +H3 { + color: #494a82; + font-size: 16px; +} + +H4 { + color: #494a82; + font-size: 14px; +} + +/* headers for darcs command options */ +.cmd-opt-hdr { + color: #494a82; + font-size: 14px; + font-weight: bold; +} + +/* begin styles for RSS Feed This is the most basic style to use for a list with no bullets */ + +.rss_title, rss_title a { + margin: 0px 0; + padding: 0; +} + +.rss_items { + list-style:none; + margin:0; + padding:0; +} + +.rss_item { +/* font-size: x-small; */ + margin-bottom: 1em;; +} + +.rss_item a:link, .rss_item a:visited, .rss_item a:active { + + } + +.rss_item a:hover { + + } + +.rss_date { + font-size: xx-small; + } diff --git a/doc/manual/bigimages.tex b/doc/manual/bigimages.tex new file mode 100644 --- /dev/null +++ b/doc/manual/bigimages.tex @@ -0,0 +1,605 @@ +\batchmode + + +\documentclass{book} +\RequirePackage{ifthen} + + + + +\usepackage{verbatim} +\usepackage{html} +\usepackage{fancyvrb} + +% +\newenvironment{code}{\comment}{\endcomment} + + + + +\usepackage[dvips]{color} + + +\pagecolor[gray]{.7} + +\usepackage[latin1]{inputenc} + + + +\makeatletter + +\makeatletter +\count@=\the\catcode`\_ \catcode`\_=8 +\newenvironment{tex2html_wrap}{}{}% +\catcode`\<=12\catcode`\_=\count@ +\newcommand{\providedcommand}[1]{\expandafter\providecommand\csname #1\endcsname}% +\newcommand{\renewedcommand}[1]{\expandafter\providecommand\csname #1\endcsname{}% + \expandafter\renewcommand\csname #1\endcsname}% +\newcommand{\newedenvironment}[1]{\newenvironment{#1}{}{}\renewenvironment{#1}}% +\let\newedcommand\renewedcommand +\let\renewedenvironment\newedenvironment +\makeatother +\let\mathon=$ +\let\mathoff=$ +\ifx\AtBeginDocument\undefined \newcommand{\AtBeginDocument}[1]{}\fi +\newbox\sizebox +\setlength{\hoffset}{0pt}\setlength{\voffset}{0pt} +\addtolength{\textheight}{\footskip}\setlength{\footskip}{0pt} +\addtolength{\textheight}{\topmargin}\setlength{\topmargin}{0pt} +\addtolength{\textheight}{\headheight}\setlength{\headheight}{0pt} +\addtolength{\textheight}{\headsep}\setlength{\headsep}{0pt} +\setlength{\textwidth}{349pt} +\newwrite\lthtmlwrite +\makeatletter +\let\realnormalsize=\normalsize +\global\topskip=2sp +\def\preveqno{}\let\real@float=\@float \let\realend@float=\end@float +\def\@float{\let\@savefreelist\@freelist\real@float} +\def\liih@math{\ifmmode$\else\bad@math\fi} +\def\end@float{\realend@float\global\let\@freelist\@savefreelist} +\let\real@dbflt=\@dbflt \let\end@dblfloat=\end@float +\let\@largefloatcheck=\relax +\let\if@boxedmulticols=\iftrue +\def\@dbflt{\let\@savefreelist\@freelist\real@dbflt} +\def\adjustnormalsize{\def\normalsize{\mathsurround=0pt \realnormalsize + \parindent=0pt\abovedisplayskip=0pt\belowdisplayskip=0pt}% + \def\phantompar{\csname par\endcsname}\normalsize}% +\def\lthtmltypeout#1{{\let\protect\string \immediate\write\lthtmlwrite{#1}}}% +\newcommand\lthtmlhboxmathA{\adjustnormalsize\setbox\sizebox=\hbox\bgroup\kern.05em }% +\newcommand\lthtmlhboxmathB{\adjustnormalsize\setbox\sizebox=\hbox to\hsize\bgroup\hfill }% +\newcommand\lthtmlvboxmathA{\adjustnormalsize\setbox\sizebox=\vbox\bgroup % + \let\ifinner=\iffalse \let\)\liih@math }% +\newcommand\lthtmlboxmathZ{\@next\next\@currlist{}{\def\next{\voidb@x}}% + \expandafter\box\next\egroup}% +\newcommand\lthtmlmathtype[1]{\gdef\lthtmlmathenv{#1}}% +\newcommand\lthtmllogmath{\dimen0\ht\sizebox \advance\dimen0\dp\sizebox + \ifdim\dimen0>.95\vsize + \lthtmltypeout{% +*** image for \lthtmlmathenv\space is too tall at \the\dimen0, reducing to .95 vsize ***}% + \ht\sizebox.95\vsize \dp\sizebox\z@ \fi + \lthtmltypeout{l2hSize % +:\lthtmlmathenv:\the\ht\sizebox::\the\dp\sizebox::\the\wd\sizebox.\preveqno}}% +\newcommand\lthtmlfigureA[1]{\let\@savefreelist\@freelist + \lthtmlmathtype{#1}\lthtmlvboxmathA}% +\newcommand\lthtmlpictureA{\bgroup\catcode`\_=8 \lthtmlpictureB}% +\newcommand\lthtmlpictureB[1]{\lthtmlmathtype{#1}\egroup + \let\@savefreelist\@freelist \lthtmlhboxmathB}% +\newcommand\lthtmlpictureZ[1]{\hfill\lthtmlfigureZ}% +\newcommand\lthtmlfigureZ{\lthtmlboxmathZ\lthtmllogmath\copy\sizebox + \global\let\@freelist\@savefreelist}% +\newcommand\lthtmldisplayA{\bgroup\catcode`\_=8 \lthtmldisplayAi}% +\newcommand\lthtmldisplayAi[1]{\lthtmlmathtype{#1}\egroup\lthtmlvboxmathA}% +\newcommand\lthtmldisplayB[1]{\edef\preveqno{(\theequation)}% + \lthtmldisplayA{#1}\let\@eqnnum\relax}% +\newcommand\lthtmldisplayZ{\lthtmlboxmathZ\lthtmllogmath\lthtmlsetmath}% +\newcommand\lthtmlinlinemathA{\bgroup\catcode`\_=8 \lthtmlinlinemathB} +\newcommand\lthtmlinlinemathB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA + \vrule height1.5ex width0pt }% +\newcommand\lthtmlinlineA{\bgroup\catcode`\_=8 \lthtmlinlineB}% +\newcommand\lthtmlinlineB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA}% +\newcommand\lthtmlinlineZ{\egroup\expandafter\ifdim\dp\sizebox>0pt % + \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetinline} +\newcommand\lthtmlinlinemathZ{\egroup\expandafter\ifdim\dp\sizebox>0pt % + \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetmath} +\newcommand\lthtmlindisplaymathZ{\egroup % + \centerinlinemath\lthtmllogmath\lthtmlsetmath} +\def\lthtmlsetinline{\hbox{\vrule width.1em \vtop{\vbox{% + \kern.1em\copy\sizebox}\ifdim\dp\sizebox>0pt\kern.1em\else\kern.3pt\fi + \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}} +\def\lthtmlsetmath{\hbox{\vrule width.1em\kern-.05em\vtop{\vbox{% + \kern.1em\kern0.8 pt\hbox{\hglue.17em\copy\sizebox\hglue0.8 pt}}\kern.3pt% + \ifdim\dp\sizebox>0pt\kern.1em\fi \kern0.8 pt% + \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}} +\def\centerinlinemath{% + \dimen1=\ifdim\ht\sizebox<\dp\sizebox \dp\sizebox\else\ht\sizebox\fi + \advance\dimen1by.5pt \vrule width0pt height\dimen1 depth\dimen1 + \dp\sizebox=\dimen1\ht\sizebox=\dimen1\relax} + +\def\lthtmlcheckvsize{\ifdim\ht\sizebox<\vsize + \ifdim\wd\sizebox<\hsize\expandafter\hfill\fi \expandafter\vfill + \else\expandafter\vss\fi}% +\providecommand{\selectlanguage}[1]{}% +\makeatletter \tracingstats = 1 + + +\begin{document} +\pagestyle{empty}\thispagestyle{empty}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength hsize=\the\hsize}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength vsize=\the\vsize}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength hoffset=\the\hoffset}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength voffset=\the\voffset}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength topmargin=\the\topmargin}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength topskip=\the\topskip}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength headheight=\the\headheight}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength headsep=\the\headsep}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength parskip=\the\parskip}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength oddsidemargin=\the\oddsidemargin}\lthtmltypeout{}% +\makeatletter +\if@twoside\lthtmltypeout{latex2htmlLength evensidemargin=\the\evensidemargin}% +\else\lthtmltypeout{latex2htmlLength evensidemargin=\the\oddsidemargin}\fi% +\lthtmltypeout{}% +\makeatother +\setcounter{page}{1} +\onecolumn + +% !!! IMAGES START HERE !!! + +\stepcounter{chapter} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2771}% +$<$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2773}% +$>$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{section} +\stepcounter{chapter} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2775}% +$+$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2777}% +$R_{c}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2779}% +$f_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2781}% +$R_c$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2783}% +$R_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2787}% +$f_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2795}% +$R_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2835}% +$R_p$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2839}% +$R_l$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{chapter} +\stepcounter{chapter} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{subsection} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2841}% +$\backslash$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2847}% +$ R_1 \bigcup R_2 +\bigcup R_3 \ldots$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2849}% +$ R_1 \bigcap R_2 \bigcap R_3 \ldots$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2851}% +$ S +\backslash S \rightarrow \emptyset $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2853}% +$ R_1 +\backslash (R_2 \bigcup R_3 \bigcup \ldots$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} + +% +\providecommand{\pullwarning}[1]{ +\textbf{WARNING:} #1 should not be run when there is a possibility +that another user may be pulling from the same repository. Attempting to do so +may cause repository corruption.}% + +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsubsection} +\stepcounter{subsection} +\appendix +\stepcounter{section} +\stepcounter{paragraph} + + +\addtolength{\itemsep}{-0.5\baselineskip}% + +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} + + +\addtolength{\itemsep}{-0.5\baselineskip}% + +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{section} +\stepcounter{section} +\stepcounter{chapter} + + +\newtheorem{thm}{Theorem}% + + + +\newtheorem{dfn}{Definition}% + +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2863}% +$P_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2865}% +$P_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2867}% +$P_2P_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2873}% +$P_1\parallel P_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2875}% +$P^{ -1}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2877}% +$P$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2759}% +\( P^{ -1} P \)% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmldisplayA{displaymath2763}% +\begin{displaymath} (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2881}% +$O(n)$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{subsection} + +% +\providecommand{\commutex}{\longleftrightarrow}% + + +% +\providecommand{\commutes}{\longleftrightarrow}% + +{\newpage\clearpage +\lthtmldisplayA{displaymath2764}% +\begin{displaymath} P_2 P_1 \longleftrightarrow {P_1}' {P_2}'. \end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2887}% +$P_1'$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2893}% +$P_2'$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2897}% +$\longleftrightarrow $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2899}% +$==$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2901}% +$\ddot\frown$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{paragraph} + +% +\providecommand{\merge}{\Longrightarrow}% + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2760}% +\( \Longrightarrow \)% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmldisplayA{displaymath2765}% +\begin{displaymath} P_2 \parallel P_1 \Longrightarrow {P_2}' P_1 \longleftrightarrow {P_1}' P_2. \end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2911}% +$ P_2' P_1 \longleftrightarrow P_1' P_2 $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2913}% +$ P_1'^{ -1} +P_2' \longleftrightarrow P_2 P_1^{ -1} $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2915}% +$P_1'^{ -1}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2917}% +$P_1^{ -1}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmldisplayA{displaymath2766}% +\begin{displaymath} +A^{ -1} C \longleftrightarrow C' A'^{ -1} +\end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{chapter} +\addtocounter{enumi}{-1} +\stepcounter{section} + +\end{document} diff --git a/doc/manual/images.tex b/doc/manual/images.tex new file mode 100644 --- /dev/null +++ b/doc/manual/images.tex @@ -0,0 +1,605 @@ +\batchmode + + +\documentclass{book} +\RequirePackage{ifthen} + + + + +\usepackage{verbatim} +\usepackage{html} +\usepackage{fancyvrb} + +% +\newenvironment{code}{\comment}{\endcomment} + + + + +\usepackage[dvips]{color} + + +\pagecolor[gray]{.7} + +\usepackage[latin1]{inputenc} + + + +\makeatletter + +\makeatletter +\count@=\the\catcode`\_ \catcode`\_=8 +\newenvironment{tex2html_wrap}{}{}% +\catcode`\<=12\catcode`\_=\count@ +\newcommand{\providedcommand}[1]{\expandafter\providecommand\csname #1\endcsname}% +\newcommand{\renewedcommand}[1]{\expandafter\providecommand\csname #1\endcsname{}% + \expandafter\renewcommand\csname #1\endcsname}% +\newcommand{\newedenvironment}[1]{\newenvironment{#1}{}{}\renewenvironment{#1}}% +\let\newedcommand\renewedcommand +\let\renewedenvironment\newedenvironment +\makeatother +\let\mathon=$ +\let\mathoff=$ +\ifx\AtBeginDocument\undefined \newcommand{\AtBeginDocument}[1]{}\fi +\newbox\sizebox +\setlength{\hoffset}{0pt}\setlength{\voffset}{0pt} +\addtolength{\textheight}{\footskip}\setlength{\footskip}{0pt} +\addtolength{\textheight}{\topmargin}\setlength{\topmargin}{0pt} +\addtolength{\textheight}{\headheight}\setlength{\headheight}{0pt} +\addtolength{\textheight}{\headsep}\setlength{\headsep}{0pt} +\setlength{\textwidth}{349pt} +\newwrite\lthtmlwrite +\makeatletter +\let\realnormalsize=\normalsize +\global\topskip=2sp +\def\preveqno{}\let\real@float=\@float \let\realend@float=\end@float +\def\@float{\let\@savefreelist\@freelist\real@float} +\def\liih@math{\ifmmode$\else\bad@math\fi} +\def\end@float{\realend@float\global\let\@freelist\@savefreelist} +\let\real@dbflt=\@dbflt \let\end@dblfloat=\end@float +\let\@largefloatcheck=\relax +\let\if@boxedmulticols=\iftrue +\def\@dbflt{\let\@savefreelist\@freelist\real@dbflt} +\def\adjustnormalsize{\def\normalsize{\mathsurround=0pt \realnormalsize + \parindent=0pt\abovedisplayskip=0pt\belowdisplayskip=0pt}% + \def\phantompar{\csname par\endcsname}\normalsize}% +\def\lthtmltypeout#1{{\let\protect\string \immediate\write\lthtmlwrite{#1}}}% +\newcommand\lthtmlhboxmathA{\adjustnormalsize\setbox\sizebox=\hbox\bgroup\kern.05em }% +\newcommand\lthtmlhboxmathB{\adjustnormalsize\setbox\sizebox=\hbox to\hsize\bgroup\hfill }% +\newcommand\lthtmlvboxmathA{\adjustnormalsize\setbox\sizebox=\vbox\bgroup % + \let\ifinner=\iffalse \let\)\liih@math }% +\newcommand\lthtmlboxmathZ{\@next\next\@currlist{}{\def\next{\voidb@x}}% + \expandafter\box\next\egroup}% +\newcommand\lthtmlmathtype[1]{\gdef\lthtmlmathenv{#1}}% +\newcommand\lthtmllogmath{\dimen0\ht\sizebox \advance\dimen0\dp\sizebox + \ifdim\dimen0>.95\vsize + \lthtmltypeout{% +*** image for \lthtmlmathenv\space is too tall at \the\dimen0, reducing to .95 vsize ***}% + \ht\sizebox.95\vsize \dp\sizebox\z@ \fi + \lthtmltypeout{l2hSize % +:\lthtmlmathenv:\the\ht\sizebox::\the\dp\sizebox::\the\wd\sizebox.\preveqno}}% +\newcommand\lthtmlfigureA[1]{\let\@savefreelist\@freelist + \lthtmlmathtype{#1}\lthtmlvboxmathA}% +\newcommand\lthtmlpictureA{\bgroup\catcode`\_=8 \lthtmlpictureB}% +\newcommand\lthtmlpictureB[1]{\lthtmlmathtype{#1}\egroup + \let\@savefreelist\@freelist \lthtmlhboxmathB}% +\newcommand\lthtmlpictureZ[1]{\hfill\lthtmlfigureZ}% +\newcommand\lthtmlfigureZ{\lthtmlboxmathZ\lthtmllogmath\copy\sizebox + \global\let\@freelist\@savefreelist}% +\newcommand\lthtmldisplayA{\bgroup\catcode`\_=8 \lthtmldisplayAi}% +\newcommand\lthtmldisplayAi[1]{\lthtmlmathtype{#1}\egroup\lthtmlvboxmathA}% +\newcommand\lthtmldisplayB[1]{\edef\preveqno{(\theequation)}% + \lthtmldisplayA{#1}\let\@eqnnum\relax}% +\newcommand\lthtmldisplayZ{\lthtmlboxmathZ\lthtmllogmath\lthtmlsetmath}% +\newcommand\lthtmlinlinemathA{\bgroup\catcode`\_=8 \lthtmlinlinemathB} +\newcommand\lthtmlinlinemathB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA + \vrule height1.5ex width0pt }% +\newcommand\lthtmlinlineA{\bgroup\catcode`\_=8 \lthtmlinlineB}% +\newcommand\lthtmlinlineB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA}% +\newcommand\lthtmlinlineZ{\egroup\expandafter\ifdim\dp\sizebox>0pt % + \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetinline} +\newcommand\lthtmlinlinemathZ{\egroup\expandafter\ifdim\dp\sizebox>0pt % + \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetmath} +\newcommand\lthtmlindisplaymathZ{\egroup % + \centerinlinemath\lthtmllogmath\lthtmlsetmath} +\def\lthtmlsetinline{\hbox{\vrule width.1em \vtop{\vbox{% + \kern.1em\copy\sizebox}\ifdim\dp\sizebox>0pt\kern.1em\else\kern.3pt\fi + \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}} +\def\lthtmlsetmath{\hbox{\vrule width.1em\kern-.05em\vtop{\vbox{% + \kern.1em\kern0.8 pt\hbox{\hglue.17em\copy\sizebox\hglue0.8 pt}}\kern.3pt% + \ifdim\dp\sizebox>0pt\kern.1em\fi \kern0.8 pt% + \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}} +\def\centerinlinemath{% + \dimen1=\ifdim\ht\sizebox<\dp\sizebox \dp\sizebox\else\ht\sizebox\fi + \advance\dimen1by.5pt \vrule width0pt height\dimen1 depth\dimen1 + \dp\sizebox=\dimen1\ht\sizebox=\dimen1\relax} + +\def\lthtmlcheckvsize{\ifdim\ht\sizebox<\vsize + \ifdim\wd\sizebox<\hsize\expandafter\hfill\fi \expandafter\vfill + \else\expandafter\vss\fi}% +\providecommand{\selectlanguage}[1]{}% +\makeatletter \tracingstats = 1 + + +\begin{document} +\pagestyle{empty}\thispagestyle{empty}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength hsize=\the\hsize}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength vsize=\the\vsize}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength hoffset=\the\hoffset}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength voffset=\the\voffset}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength topmargin=\the\topmargin}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength topskip=\the\topskip}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength headheight=\the\headheight}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength headsep=\the\headsep}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength parskip=\the\parskip}\lthtmltypeout{}% +\lthtmltypeout{latex2htmlLength oddsidemargin=\the\oddsidemargin}\lthtmltypeout{}% +\makeatletter +\if@twoside\lthtmltypeout{latex2htmlLength evensidemargin=\the\evensidemargin}% +\else\lthtmltypeout{latex2htmlLength evensidemargin=\the\oddsidemargin}\fi% +\lthtmltypeout{}% +\makeatother +\setcounter{page}{1} +\onecolumn + +% !!! IMAGES START HERE !!! + +\stepcounter{chapter} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2771}% +$<$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2773}% +$>$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{section} +\stepcounter{chapter} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2775}% +$+$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2777}% +$R_{c}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2779}% +$f_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2781}% +$R_c$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2783}% +$R_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2787}% +$f_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2795}% +$R_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2835}% +$R_p$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2839}% +$R_l$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{chapter} +\stepcounter{chapter} +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{subsection} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2841}% +$\backslash$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2847}% +$ R_1 \bigcup R_2 +\bigcup R_3 \ldots$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2849}% +$ R_1 \bigcap R_2 \bigcap R_3 \ldots$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2851}% +$ S +\backslash S \rightarrow \emptyset $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2853}% +$ R_1 +\backslash (R_2 \bigcup R_3 \bigcup \ldots$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} + +% +\providecommand{\pullwarning}[1]{ +\textbf{WARNING:} #1 should not be run when there is a possibility +that another user may be pulling from the same repository. Attempting to do so +may cause repository corruption.}% + +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{subsubsection} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{subsubsection} +\stepcounter{subsection} +\appendix +\stepcounter{section} +\stepcounter{paragraph} + + +\addtolength{\itemsep}{-0.5\baselineskip}% + +\stepcounter{paragraph} +\stepcounter{section} +\stepcounter{paragraph} + + +\addtolength{\itemsep}{-0.5\baselineskip}% + +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{section} +\stepcounter{section} +\stepcounter{chapter} + + +\newtheorem{thm}{Theorem}% + + + +\newtheorem{dfn}{Definition}% + +\stepcounter{section} +\stepcounter{section} +\stepcounter{section} +\stepcounter{subsection} +\stepcounter{subsection} +\stepcounter{section} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2863}% +$P_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2865}% +$P_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2867}% +$P_2P_1$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2873}% +$P_1\parallel P_2$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2875}% +$P^{ -1}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2877}% +$P$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2759}% +\( P^{ -1} P \)% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmldisplayA{displaymath2763}% +\begin{displaymath} (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{subsection} +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2881}% +$O(n)$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{subsection} + +% +\providecommand{\commutex}{\longleftrightarrow}% + + +% +\providecommand{\commutes}{\longleftrightarrow}% + +{\newpage\clearpage +\lthtmldisplayA{displaymath2764}% +\begin{displaymath} P_2 P_1 \longleftrightarrow {P_1}' {P_2}'. \end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2887}% +$P_1'$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2893}% +$P_2'$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2897}% +$\longleftrightarrow $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2899}% +$==$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2901}% +$\ddot\frown$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{paragraph} + +% +\providecommand{\merge}{\Longrightarrow}% + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2760}% +\( \Longrightarrow \)% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmldisplayA{displaymath2765}% +\begin{displaymath} P_2 \parallel P_1 \Longrightarrow {P_2}' P_1 \longleftrightarrow {P_1}' P_2. \end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{subsection} +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2911}% +$ P_2' P_1 \longleftrightarrow P_1' P_2 $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2913}% +$ P_1'^{ -1} +P_2' \longleftrightarrow P_2 P_1^{ -1} $% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2915}% +$P_1'^{ -1}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmlinlinemathA{tex2html_wrap_inline2917}% +$P_1^{ -1}$% +\lthtmlinlinemathZ +\lthtmlcheckvsize\clearpage} + +{\newpage\clearpage +\lthtmldisplayA{displaymath2766}% +\begin{displaymath} +A^{ -1} C \longleftrightarrow C' A'^{ -1} +\end{displaymath}% +\lthtmldisplayZ +\lthtmlcheckvsize\clearpage} + +\stepcounter{section} +\stepcounter{section} +\stepcounter{paragraph} +\stepcounter{paragraph} +\stepcounter{chapter} +\stepcounter{chapter} +\addtocounter{enumi}{-1} +\stepcounter{section} + +\end{document} diff --git a/doc/manual/patch-theory.tex b/doc/manual/patch-theory.tex new file mode 100644 --- /dev/null +++ b/doc/manual/patch-theory.tex @@ -0,0 +1,79 @@ +%% This file was automatically generated by preproc. +% Copyright (C) 2007 David Roundy +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2, or (at your option) +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; see the file COPYING. If not, write to +% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +% Boston, MA 02110-1301, USA. + +\documentclass{article} +%\usepackage{color} + +\usepackage{verbatim} +\usepackage{hyperref} +\usepackage{fancyvrb} +\newenvironment{code}{\comment}{\endcomment} +% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim} + +\newcommand{\commutes}{\longleftrightarrow} + +\begin{document} + + +\section{Patch properties} + +Darcs is built on a hierarchy of patch types. At the lowest level are +``primitive'' patches, and from these building blocks, a whole hierarchy of +patch types are built. Each of these patch types must support a number of +functions, which must obey a number of laws. + +\subsection{Properties of identity} + +\newtheorem{prp}{Property} + +\begin{prp}[Identity commutes trivially] + The identity patch must commute with any patch without modifying said patch. +\end{prp} + + +\begin{prp}[Inverse doesn't commute] + A patch and its inverse will always commute, unless that patch is an + identity patch (or an identity-like patch that has no effect). +\end{prp} + + +\subsection{Commute properties} + +\begin{prp}[Recommute] + $AB \commutes B'A'$ if and only if $B'A' \commutes AB$ +\end{prp} + + +\begin{prp}[Commute inverses] + $AB \commutes B'A'$ if and only if $B^{-1}A^{-1} \commutes A'^{-1}B'^{-1}$ +\end{prp} + + +\begin{prp}[Patch and inverse] + If $AB \commutes B'A'$ then $A^{-1}B' \commutes BA'^{-1}$ +\end{prp} + +This property is only true of primitive patches. + + +\begin{prp}[Permutivity] + (to be added...) +\end{prp} + + +\end{document} 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.3.1\nReinier Lamers **20090920174331\n Ignore-this: a5da37b9925e1dfe3e81f0b67183ef1f\n] \n" +Just "\nContext:\n\n[TAG 2.4\nReinier Lamers **20100226180900\n Ignore-this: 36ce0456c214345f55a7bc5fc142e985\n] \n" diff --git a/src/ByteStringUtils.hs b/src/ByteStringUtils.hs --- a/src/ByteStringUtils.hs +++ b/src/ByteStringUtils.hs @@ -18,7 +18,6 @@ module ByteStringUtils ( unsafeWithInternals, - unpackPSfromUTF8, -- IO with mmap or gzip gzReadFilePS, @@ -28,9 +27,7 @@ -- gzip handling isGZFile, -#ifdef HAVE_HASKELL_ZLIB gzDecompress, -#endif -- list utilities ifHeadThenTail, @@ -59,27 +56,22 @@ import Data.ByteString (intercalate, uncons) import Data.ByteString.Internal (fromForeignPtr) -#if defined (HAVE_MMAP) || ! defined (HAVE_HASKELL_ZLIB) +#if defined (HAVE_MMAP) import Control.Exception ( catch ) #endif import System.IO import System.IO.Unsafe ( unsafePerformIO ) import Foreign.Storable ( peekElemOff, peek ) -import Foreign.Marshal.Alloc ( free ) -import Foreign.Marshal.Array ( mallocArray, peekArray, advancePtr ) +import Foreign.Marshal.Array ( advancePtr ) import Foreign.C.Types ( CInt ) import Data.Bits ( rotateL ) -import Data.Char ( chr, ord, isSpace ) +import Data.Char ( ord, isSpace ) import Data.Word ( Word8 ) import Data.Int ( Int32 ) import Control.Monad ( when ) -#ifndef HAVE_HASKELL_ZLIB -import Foreign.Ptr ( nullPtr ) -import Foreign.ForeignPtr ( ForeignPtr ) -#endif import Foreign.Ptr ( plusPtr, Ptr ) import Foreign.ForeignPtr ( withForeignPtr ) @@ -88,14 +80,10 @@ import Foreign.Ptr ( FunPtr ) #endif -#if HAVE_HASKELL_ZLIB import qualified Data.ByteString.Lazy as BL import qualified Codec.Compression.GZip as GZ import qualified Codec.Compression.Zlib.Internal as ZI import Darcs.Global ( addCRCWarning ) -#else -import Foreign.C.String ( CString, withCString ) -#endif #ifdef HAVE_MMAP import System.IO.MMap( mmapFileByteString ) @@ -106,22 +94,6 @@ -- ----------------------------------------------------------------------------- -- obsolete debugging code -# ifndef HAVE_HASKELL_ZLIB -debugForeignPtr :: ForeignPtr a -> String -> IO () -#ifdef DEBUG_PS -foreign import ccall unsafe "static fpstring.h debug_alloc" debug_alloc - :: Ptr a -> CString -> IO () -foreign import ccall unsafe "static fpstring.h & debug_free" debug_free - :: FunPtr (Ptr a -> IO ()) -debugForeignPtr fp n = - withCString n $ \cname-> withForeignPtr fp $ \p-> - do debug_alloc p cname - addForeignPtrFinalizer debug_free fp -#else -debugForeignPtr _ _ = return () -#endif -#endif - -- ----------------------------------------------------------------------------- -- unsafeWithInternals @@ -142,26 +114,6 @@ readIntPS = BC.readInt . BC.dropWhile isSpace -- ----------------------------------------------------------------------------- --- Destructor functions (taking PackedStrings apart) - -unpackPSfromUTF8 :: B.ByteString -> String -unpackPSfromUTF8 ps = - case BI.toForeignPtr ps of - (_,_, 0) -> "" - (x,s,l) -> - unsafePerformIO $ withForeignPtr x $ \p-> - do outbuf <- mallocArray l - lout <- fromIntegral `fmap` - utf8_to_ints outbuf (p `plusPtr` s) (fromIntegral l) - when (lout < 0) $ error "Bad UTF8!" - str <- (map (chr . fromIntegral)) `fmap` peekArray lout outbuf - free outbuf - return str - -foreign import ccall unsafe "static fpstring.h utf8_to_ints" utf8_to_ints - :: Ptr Int -> Ptr Word8 -> CInt -> IO CInt - --- ----------------------------------------------------------------------------- -- List-mimicking functions for PackedStrings {-# INLINE ifHeadThenTail #-} @@ -343,8 +295,6 @@ -- ----------------------------------------------------------------------------- -- gzReadFilePS -#ifdef HAVE_HASKELL_ZLIB - -- |Decompress the given bytestring into a lazy list of chunks, along with a boolean -- flag indicating (if True) that the CRC was corrupted. -- Inspecting the flag will cause the entire list of chunks to be evaluated (but if @@ -353,7 +303,7 @@ gzDecompress mbufsize = -- This is what the code would be without the bad CRC recovery logic: -- return . BL.toChunks . GZ.decompressWith decompressParams - toListWarn . ZI.decompressWithErrors ZI.GZip decompressParams + toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams where decompressParams = case mbufsize of Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize } @@ -378,19 +328,6 @@ handleBad ZI.DataError "incorrect data check" = ([], True) handleBad _ msg = error msg -#else - -foreign import ccall unsafe "static zlib.h gzopen" c_gzopen - :: CString -> CString -> IO (Ptr ()) -foreign import ccall unsafe "static zlib.h gzclose" c_gzclose - :: Ptr () -> IO () -foreign import ccall unsafe "static zlib.h gzread" c_gzread - :: Ptr () -> Ptr Word8 -> CInt -> IO CInt -foreign import ccall unsafe "static zlib.h gzwrite" c_gzwrite - :: Ptr () -> Ptr Word8 -> CInt -> IO CInt - -#endif - isGZFile :: FilePath -> IO (Maybe Int) isGZFile f = do h <- openBinaryFile f ReadMode @@ -411,7 +348,6 @@ case mlen of Nothing -> mmapFilePS f Just len -> -#ifdef HAVE_HASKELL_ZLIB do -- Passing the length to gzDecompress means that it produces produces one chunk, -- which in turn means that B.concat won't need to copy data. -- If the length is wrong this will just affect efficiency, not correctness @@ -420,19 +356,6 @@ return res compressed <- (BL.fromChunks . return) `fmap` mmapFilePS f B.concat `fmap` doDecompress compressed -#else - withCString f $ \fstr-> withCString "rb" $ \rb-> do - gzf <- c_gzopen fstr rb - when (gzf == nullPtr) $ fail $ "problem opening file "++f - fp <- BI.mallocByteString len - debugForeignPtr fp $ "gzReadFilePS "++f - lread <- withForeignPtr fp $ \p -> - c_gzread gzf p (fromIntegral len) - c_gzclose gzf - when (fromIntegral lread /= len) $ - fail $ "problem gzreading file "++f - return $ fromForeignPtr fp 0 len -#endif hGetLittleEndInt :: Handle -> IO Int hGetLittleEndInt h = do @@ -447,26 +370,7 @@ gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO () gzWriteFilePSs f pss = -#ifdef HAVE_HASKELL_ZLIB BL.writeFile f $ GZ.compress $ BL.fromChunks pss -#else - withCString f $ \fstr -> withCString "wb" $ \wb -> do - gzf <- c_gzopen fstr wb - when (gzf == nullPtr) $ fail $ "problem gzopening file for write: "++f - mapM_ (gzWriteToGzf gzf) pss `catch` - \_ -> fail $ "problem gzwriting file: "++f - c_gzclose gzf - -gzWriteToGzf :: Ptr () -> B.ByteString -> IO () -gzWriteToGzf gzf ps = case BI.toForeignPtr ps of - (_,_,0) -> return () -- avoid calling gzwrite with 0 length this would - -- trouble on some versions of zlib, and is always - -- unnecessary. - (x,s,l) -> do - lw <- withForeignPtr x $ \p -> c_gzwrite gzf (p `plusPtr` s) - (fromIntegral l) - when (fromIntegral lw /= l) $ fail $ "problem in gzWriteToGzf" -#endif -- ----------------------------------------------------------------------------- -- mmapFilePS diff --git a/src/CommandLine.hs b/src/CommandLine.hs --- a/src/CommandLine.hs +++ b/src/CommandLine.hs @@ -109,7 +109,7 @@ parseCmd ftable s = parse (commandline ftable) "" s urlEncode :: String -> String -urlEncode s = concat $ map escapeC s +urlEncode s = concatMap escapeC s where escapeC x = if allowed x then [x] else '%':(intToHex $ ord x) intToHex i = map intToDigit [i `div` 16, i `mod` 16] allowed x = x `elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] diff --git a/src/Darcs/ArgumentDefaults.lhs b/src/Darcs/ArgumentDefaults.lhs --- a/src/Darcs/ArgumentDefaults.lhs +++ b/src/Darcs/ArgumentDefaults.lhs @@ -22,10 +22,10 @@ import Darcs.Arguments ( DarcsFlag, DarcsOption( DarcsArgOption, DarcsNoArgOption, DarcsMultipleChoiceOption ), arein, isin ) -import Darcs.Commands ( CommandControl( Command_data ), - command_alloptions ) -import Darcs.Commands.Help ( command_control_list ) -import Darcs.Repository.Prefs ( get_global, get_preflist ) +import Darcs.Commands ( CommandControl( CommandData ), + commandAlloptions ) +import Darcs.Commands.Help ( commandControlList ) +import Darcs.Repository.Prefs ( getGlobal, getPreflist ) \end{code} \paragraph{defaults}\label{defaults} @@ -118,8 +118,8 @@ \begin{code} get_default_flags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag] get_default_flags com com_opts already = do - repo_defs <- default_content $ get_preflist "defaults" - global_defs <- default_content $ get_global "defaults" + repo_defs <- default_content $ getPreflist "defaults" + global_defs <- default_content $ getGlobal "defaults" let repo_flags = get_flags_from com com_opts already repo_defs global_flags = get_flags_from com com_opts (already++repo_flags) global_defs @@ -132,8 +132,8 @@ where com_defs = filter (\ (c,_,_) -> c == com) defs all_defs = filter (\ (c,_,_) -> c == "ALL") defs options_for d o ao = concatMap (find_option o ao already) d - all_opts = concatMap get_opts command_control_list - get_opts (Command_data c) = let (o1, o2) = command_alloptions c + all_opts = concatMap get_opts commandControlList + get_opts (CommandData c) = let (o1, o2) = commandAlloptions c in o1 ++ o2 get_opts _ = [] diff --git a/src/Darcs/Arguments.lhs b/src/Darcs/Arguments.lhs --- a/src/Darcs/Arguments.lhs +++ b/src/Darcs/Arguments.lhs @@ -16,8 +16,8 @@ % Boston, MA 02110-1301, USA. \begin{code} -{-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp -XPatternGuards #-} +{-# LANGUAGE CPP, PatternGuards #-} #include "gadts.h" @@ -27,87 +27,96 @@ definePatches, defineChanges, fixFilePathOrStd, fixUrl, fixSubPaths, areFileArgs, - DarcsOption( .. ), option_from_darcsoption, - help, list_options, list_files, - any_verbosity, disable, restrict_paths, - notest, test, working_repo_dir, + DarcsOption( .. ), optionFromDarcsoption, + help, listOptions, listFiles, + anyVerbosity, disable, restrictPaths, + notest, test, workingRepoDir, testByDefault, - remote_repo, - leave_test_dir, - possibly_remote_repo_dir, get_repourl, - list_registered_files, list_unregistered_files, - author, get_author, get_easy_author, get_sendmail_cmd, - patchname_option, distname_option, - logfile, rmlogfile, from_opt, subject, get_subject, - in_reply_to, get_in_reply_to, - target, cc, get_cc, output, output_auto_name, - recursive, inventory_choices, get_inventory_choices, + remoteRepo, + leaveTestDir, + possiblyRemoteRepoDir, getRepourl, + listRegisteredFiles, listUnregisteredFiles, + author, getAuthor, getEasyAuthor, getSendmailCmd, + fileHelpAuthor, environmentHelpEmail, + patchnameOption, distnameOption, + logfile, rmlogfile, fromOpt, subject, getSubject, + inReplyTo, getInReplyTo, + target, ccSend, ccApply, getCc, output, outputAutoName, + recursive, inventoryChoices, getInventoryChoices, + upgradeFormat, askdeps, ignoretimes, lookforadds, - ask_long_comment, sendmail_cmd, + askLongComment, sendmailCmd, environmentHelpSendmail, - sign, verify, edit_description, - reponame, tagname, creatorhash, - apply_conflict_options, reply, - pull_conflict_options, use_external_merge, - deps_sel, nocompress, - uncompress_nocompress, repo_combinator, - options_latex, reorder_patches, - noskip_boring, allow_problematic_filenames, - applyas, human_readable, - changes_reverse, only_to_files, - changes_format, match_one_context, match_one_nontag, - match_maxcount, - send_to_context, - get_context, - pipe_interactive, all_interactive, - all_pipe_interactive, + sign, verify, editDescription, + reponame, creatorhash, + applyConflictOptions, reply, + pullConflictOptions, useExternalMerge, + depsSel, nocompress, + uncompressNocompress, repoCombinator, + optionsLatex, reorderPatches, + noskipBoring, allowProblematicFilenames, + applyas, humanReadable, + changesReverse, onlyToFiles, + changesFormat, matchOneContext, matchOneNontag, + matchMaxcount, + sendToContext, + getContext, + pipeInteractive, allInteractive, + allPipeInteractive, summary, unified, tokens, - checkpoint, partial, partial_check, - diff_cmd_flag, diffflags, unidiff, xmloutput, - force_replace, dry_run, dry_run_noxml, - print_dry_run_message_and_exit, showFriendly, - match_one, match_several, match_range, - match_several_or_range, happy_forwarding, - match_several_or_last, - set_default, - fancy_move_add, - set_scripts_executable, - sibling, flagsToSiblings, relink, relink_pristine, nolinks, + partial, partialCheck, + diffCmdFlag, diffflags, unidiff, xmloutput, + forceReplace, dryRun, dryRunNoxml, + printDryRunMessageAndExit, showFriendly, + matchOne, matchSeveral, matchRange, + matchSeveralOrRange, happyForwarding, + matchSeveralOrLast, + setDefault, + fancyMoveAdd, + setScriptsExecutableOption, + sibling, flagsToSiblings, relink, relinkPristine, nolinks, files, directories, pending, - posthook_cmd, posthook_prompt, - get_posthook_cmd, - prehook_cmd, prehook_prompt, - get_prehook_cmd, nullFlag, - umask_option, - store_in_memory, - patch_select_flag, - network_options, no_cache, - allow_unrelated_repos, - check_or_repair, just_this_repo + posthookCmd, posthookPrompt, + getPosthookCmd, + prehookCmd, prehookPrompt, + getPrehookCmd, nullFlag, + umaskOption, + storeInMemory, + patchSelectFlag, + networkOptions, noCache, + allowUnrelatedRepos, + checkOrRepair, justThisRepo, optimizePristine ) where import System.Console.GetOpt import System.Directory ( doesDirectoryExist ) + +import Storage.Hashed.AnchoredPath( anchorPath ) +import Storage.Hashed.Plain( readPlainTree ) +import Storage.Hashed.Tree( list, expand, emptyTree ) + import Data.List ( (\\), nub ) import Data.Maybe ( fromMaybe, listToMaybe ) import System.Exit ( ExitCode(ExitSuccess), exitWith ) import Data.Maybe ( catMaybes ) import Control.Monad ( when, unless ) +import Control.Applicative( (<$>) ) import Data.Char ( isDigit ) #ifndef WIN32 import Printer ( renderString ) import System.Posix.Env ( setEnv ) -import Darcs.Patch ( list_touched_files ) +import Darcs.Patch ( listTouchedFiles ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) #endif import Darcs.Hopefully ( PatchInfoAnd, info, hopefullyM ) -import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xml_summary ) +import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xmlSummary ) import Darcs.Patch.Info ( to_xml ) -import Darcs.Ordered ( FL, mapFL ) +import Darcs.Witnesses.Ordered ( FL, mapFL ) import qualified Darcs.Patch ( summary ) import Darcs.Utils ( askUser, maybeGetEnv, firstNotBlank, firstJustIO, withCurrentDirectory ) -import Darcs.Repository.Prefs ( boring_file_filter, get_preflist, get_global ) +import Darcs.Repository.Prefs ( getPreflist, getGlobal ) +import Darcs.Repository.State ( restrictBoring, readRecordedAndPending ) import Darcs.URL ( is_file ) import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath, makeSubPathOf, simpleSubPath, @@ -115,9 +124,7 @@ makeAbsolute, makeAbsoluteOrStd, rootDirectory ) import Darcs.Patch.MatchData ( patch_match ) import Darcs.Flags ( DarcsFlag(..), maxCount ) -import Darcs.Repository ( slurp_pending, withRepository, ($-) ) -import Darcs.Repository.HashedRepo ( slurp_all_but_darcs ) -import Darcs.SlurpDirectory ( list_slurpy ) +import Darcs.Repository ( withRepository ) import Darcs.Global ( darcsdir ) import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insert_before_lastline, prefix ) @@ -132,7 +139,7 @@ -- guarantees that isAnAbsolute, isa, flagToString, etc also work -- properly) --- | 'get_content' returns the content of a flag, if any. +-- | 'getContentString' returns the content of a flag, if any. -- For instance, the content of @Author \"Louis Aragon\"@ is @StringContent -- \"Louis Aragon\"@, while the content of @Pipe@ is @NoContent@ getContent :: DarcsFlag -> FlagContent @@ -144,6 +151,7 @@ getContent Test = NoContent getContent NoTest = NoContent getContent OnlyChangesToFiles = NoContent +getContent ChangesToAllFiles = NoContent getContent LeaveTestDir = NoContent getContent NoLeaveTestDir = NoContent getContent Timings = NoContent @@ -183,6 +191,7 @@ getContent AskDeps = NoContent getContent NoAskDeps = NoContent getContent RmLogFile = NoContent +getContent DontRmLogFile = NoContent getContent (DistName s) = StringContent s getContent (CreatorHash s) = StringContent s getContent (SignAs s) = StringContent s @@ -190,18 +199,22 @@ getContent (Verify s) = AbsoluteContent s getContent (VerifySSL s) = AbsoluteContent s getContent IgnoreTimes = NoContent +getContent DontIgnoreTimes = NoContent getContent LookForAdds = NoContent getContent NoLookForAdds = NoContent getContent AnyOrder = NoContent getContent Intersection = NoContent getContent Unified = NoContent +getContent NonUnified = NoContent getContent Union = NoContent getContent Complement = NoContent getContent Sign = NoContent getContent NoSign = NoContent getContent HappyForwarding = NoContent +getContent NoHappyForwarding = NoContent getContent SSHControlMaster = NoContent getContent NoSSHControlMaster = NoContent +getContent (RemoteDarcs s) = StringContent s getContent (Toks s) = StringContent s getContent (WorkRepoDir s) = StringContent s getContent (WorkRepoUrl s) = StringContent s @@ -216,9 +229,13 @@ getContent AllowConflicts = NoContent getContent MarkConflicts = NoContent getContent NoAllowConflicts = NoContent +getContent SkipConflicts = NoContent getContent Boring = NoContent +getContent SkipBoring = NoContent getContent AllowCaseOnly = NoContent +getContent DontAllowCaseOnly = NoContent getContent AllowWindowsReserved = NoContent +getContent DontAllowWindowsReserved = NoContent getContent DontGrabDeps = NoContent getContent DontPromptForDependencies = NoContent getContent PromptForDependencies = NoContent @@ -240,7 +257,7 @@ getContent (UpToPattern _) = NoContent -- FIXME!!! getContent (AfterPattern _) = NoContent -- FIXME!!! getContent Reverse = NoContent -getContent CheckPoint = NoContent +getContent Forward = NoContent getContent Partial = NoContent getContent Complete = NoContent getContent Lazy = NoContent @@ -265,6 +282,7 @@ getContent PristinePlain = NoContent getContent PristineNone = NoContent getContent NoUpdateWorking = NoContent +getContent UpgradeFormat = NoContent getContent Relink = NoContent getContent RelinkPristine = NoContent getContent NoLinks = NoContent @@ -283,6 +301,7 @@ getContent RunPrehook = NoContent getContent AskPrehook = NoContent getContent StoreInMemory = NoContent +getContent ApplyOnDisk = NoContent getContent HTTPPipelining = NoContent getContent NoHTTPPipelining = NoContent getContent NoCache = NoContent @@ -293,16 +312,18 @@ getContent Check = NoContent getContent Repair = NoContent getContent JustThisRepo = NoContent +getContent OptimizePristine = NoContent -get_content :: DarcsFlag -> Maybe String -get_content f = do StringContent s <- Just $ getContent f - return s +getContentString :: DarcsFlag -> Maybe String +getContentString f = + do StringContent s <- Just $ getContent f + return s -- | @a `'isa'` b@ tests whether @a@ is flag @b@ with a string argument. -- @b@ typically is a Flag constructor expecting a string -- For example, @(Author \"Ted Hughes\") `isa` Author@ returns true. isa :: DarcsFlag -> (String -> DarcsFlag) -> Bool -a `isa` b = case get_content a of +a `isa` b = case getContentString a of Nothing -> False Just s -> a == b s @@ -378,35 +399,35 @@ -- ^ A constructor for grouping related options together, such as -- @--hashed@, @--darcs-2@ and @--old-fashioned-inventory@. -option_from_darcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag] -option_from_darcsoption _ (DarcsNoArgOption a b c h) = [Option a b (NoArg c) h] -option_from_darcsoption _ (DarcsArgOption a b c n h) = [Option a b (ReqArg c n) h] -option_from_darcsoption wd (DarcsMultipleChoiceOption os) = concatMap (option_from_darcsoption wd) os -option_from_darcsoption wd (DarcsAbsPathOrStdOption a b c n h) = [Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h] -option_from_darcsoption wd (DarcsAbsPathOption a b c n h) = [Option a b (ReqArg (c . makeAbsolute wd) n) h] -option_from_darcsoption wd (DarcsOptAbsPathOption a b d c n h) = [Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h] +optionFromDarcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag] +optionFromDarcsoption _ (DarcsNoArgOption a b c h) = [Option a b (NoArg c) h] +optionFromDarcsoption _ (DarcsArgOption a b c n h) = [Option a b (ReqArg c n) h] +optionFromDarcsoption wd (DarcsMultipleChoiceOption os) = concatMap (optionFromDarcsoption wd) os +optionFromDarcsoption wd (DarcsAbsPathOrStdOption a b c n h) = [Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h] +optionFromDarcsoption wd (DarcsAbsPathOption a b c n h) = [Option a b (ReqArg (c . makeAbsolute wd) n) h] +optionFromDarcsoption wd (DarcsOptAbsPathOption a b d c n h) = [Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h] -- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of -- option, flattening any DarcsMultipleChoiceOption in the list. -concat_options :: [DarcsOption] -> DarcsOption -concat_options os = DarcsMultipleChoiceOption $ concatMap from_option os +concatOptions :: [DarcsOption] -> DarcsOption +concatOptions os = DarcsMultipleChoiceOption $ concatMap from_option os where from_option (DarcsMultipleChoiceOption xs) = xs from_option x = [x] -extract_fix_path :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath) -extract_fix_path [] = Nothing -extract_fix_path ((FixFilePath repo orig):_) = Just (repo, orig) -extract_fix_path (_:fs) = extract_fix_path fs +extractFixPath :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath) +extractFixPath [] = Nothing +extractFixPath ((FixFilePath repo orig):_) = Just (repo, orig) +extractFixPath (_:fs) = extractFixPath fs fixFilePath :: [DarcsFlag] -> FilePath -> IO AbsolutePath -fixFilePath opts f = case extract_fix_path opts of +fixFilePath opts f = case extractFixPath opts of Nothing -> bug "Can't fix path in fixFilePath" Just (_,o) -> withCurrentDirectory o $ ioAbsolute f fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd fixFilePathOrStd opts f = - case extract_fix_path opts of + case extractFixPath opts of Nothing -> bug "Can't fix path in fixFilePathOrStd" Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f @@ -424,7 +445,7 @@ putStrLn $ "Ignoring non-repository paths: " ++ unwords bad return $ nub good where - (r,o) = case extract_fix_path flags of + (r,o) = case extractFixPath flags of Just xxx -> xxx Nothing -> bug "Can't fix path in fixSubPaths" fixit p = do ap <- ioAbsolute p @@ -441,13 +462,13 @@ areFileArgs rps = concatMap toFilePath rps /= "" -- | 'list_option' is an option which lists the command's arguments -list_options :: DarcsOption -list_options = DarcsNoArgOption [] ["list-options"] ListOptions +listOptions :: DarcsOption +listOptions = DarcsNoArgOption [] ["list-options"] ListOptions "simply list the command's arguments" flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String flagToString x f = maybeHead $ catMaybes $ map f2o x - where f2o (DarcsArgOption _ (s:_) c _ _) = do arg <- get_content f + where f2o (DarcsArgOption _ (s:_) c _ _) = do arg <- getContentString f if c arg == f then return $ unwords [('-':'-':s), arg] else Nothing @@ -458,31 +479,29 @@ maybeHead [] = Nothing reponame :: DarcsOption -tagname :: DarcsOption -deps_sel :: DarcsOption -checkpoint :: DarcsOption +depsSel :: DarcsOption partial :: DarcsOption -partial_check :: DarcsOption +partialCheck :: DarcsOption tokens :: DarcsOption -working_repo_dir :: DarcsOption -possibly_remote_repo_dir :: DarcsOption +workingRepoDir :: DarcsOption +possiblyRemoteRepoDir :: DarcsOption disable :: DarcsOption -restrict_paths :: DarcsOption +restrictPaths :: DarcsOption -pipe_interactive, all_pipe_interactive, all_interactive, all_patches, interactive, pipe, - human_readable, diffflags, allow_problematic_filenames, noskip_boring, - ask_long_comment, match_one_nontag, changes_reverse, creatorhash, - changes_format, match_one_context, happy_forwarding, send_to_context, - diff_cmd_flag, store_in_memory, use_external_merge, - pull_conflict_options, target, cc, apply_conflict_options, reply, xmloutput, - distname_option, patchname_option, edit_description, - output, output_auto_name, unidiff, repo_combinator, - unified, summary, uncompress_nocompress, subject, in_reply_to, - nocompress, match_several_or_range, match_several_or_last, - author, askdeps, lookforadds, ignoretimes, test, notest, help, force_replace, - allow_unrelated_repos, - match_one, match_range, match_several, fancy_move_add, sendmail_cmd, - logfile, rmlogfile, leave_test_dir, from_opt, set_default +pipeInteractive, allPipeInteractive, allInteractive, all_patches, interactive, pipe, + humanReadable, diffflags, allowProblematicFilenames, noskipBoring, + askLongComment, matchOneNontag, changesReverse, creatorhash, + changesFormat, matchOneContext, happyForwarding, sendToContext, + diffCmdFlag, storeInMemory, useExternalMerge, + pullConflictOptions, target, ccSend, ccApply, applyConflictOptions, reply, xmloutput, + distnameOption, patchnameOption, editDescription, + output, outputAutoName, unidiff, repoCombinator, + unified, summary, uncompressNocompress, subject, inReplyTo, + nocompress, matchSeveralOrRange, matchSeveralOrLast, + author, askdeps, lookforadds, ignoretimes, test, notest, help, forceReplace, + allowUnrelatedRepos, + matchOne, matchRange, matchSeveral, fancyMoveAdd, sendmailCmd, + logfile, rmlogfile, leaveTestDir, fromOpt, setDefault :: DarcsOption @@ -527,8 +546,8 @@ \end{options} Most commands also accept the \verb!--verbose! option, which tells darcs to provide additional output. The amount of verbosity varies from command to -command. Commands that accept \verb!--verbose\verb! also accept \verb!--quiet\verb!, -which surpresses non-error output, and \verb!--normal-verbosity\verb! which can be +command. Commands that accept \verb!--verbose! also accept \verb!--quiet!, +which surpresses non-error output, and \verb!--normal-verbosity! which can be used to restore the default verbosity if \verb!--verbose! or \verb!--quiet! is in the defaults file. @@ -540,8 +559,8 @@ would not be interesting. Option \verb!--debug-http! makes darcs output debugging info for libcurl. \begin{code} -any_verbosity :: [DarcsOption] -any_verbosity =[DarcsMultipleChoiceOption +anyVerbosity :: [DarcsOption] +anyVerbosity =[DarcsMultipleChoiceOption [DarcsNoArgOption [] ["debug"] Debug "give only debug output", DarcsNoArgOption [] ["debug-verbose"] DebugVerbose @@ -569,18 +588,18 @@ when running \verb'apply' from a mailer. \begin{code} -working_repo_dir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY" +workingRepoDir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY" "specify the repository directory in which to run" -possibly_remote_repo_dir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL" +possiblyRemoteRepoDir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL" "specify the repository URL" --- | 'get_repourl' takes a list of flags and returns the url of the +-- | 'getRepourl' takes a list of flags and returns the url of the -- repository specified by @Repodir \"directory\"@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--repodir=DIRECTORY@ -get_repourl :: [DarcsFlag] -> Maybe String -get_repourl [] = Nothing -get_repourl (WorkRepoUrl d:_) | not (is_file d) = Just d -get_repourl (_:fs) = get_repourl fs +getRepourl :: [DarcsFlag] -> Maybe String +getRepourl [] = Nothing +getRepourl (WorkRepoUrl d:_) | not (is_file d) = Just d +getRepourl (_:fs) = getRepourl fs \end{code} \begin{options} @@ -597,10 +616,10 @@ (and the default repository may be overwritten). \begin{code} --- | 'remote_repo' is the option used to specify the URL of the remote +-- | 'remoteRepo' is the option used to specify the URL of the remote -- repository to work with -remote_repo :: DarcsOption -remote_repo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL" +remoteRepo :: DarcsOption +remoteRepo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL" "specify the remote repository URL to work with" \end{code} @@ -608,13 +627,13 @@ \input{Darcs/Patch/Match.lhs} \begin{code} -patchname_option = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME" +patchnameOption = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME" "name of patch" -send_to_context = DarcsAbsPathOption [] ["context"] Context "FILENAME" +sendToContext = DarcsAbsPathOption [] ["context"] Context "FILENAME" "send to context stored in FILENAME" -match_one_context = +matchOneContext = DarcsMultipleChoiceOption [DarcsArgOption [] ["to-match"] mp "PATTERN" "select changes up to a patch matching PATTERN", @@ -626,16 +645,16 @@ ] where mp s = OnePattern (patch_match s) -match_one = concat_options [__match, __patch, __tag, __index] -match_one_nontag = concat_options [__match, __patch, __index] -match_several = concat_options [__matches, __patches, __tags] -match_range = concat_options [match_to, match_from, __match, __patch, __last, __indexes] -match_several_or_range = concat_options [match_to, match_from, __last, __indexes, +matchOne = concatOptions [__match, __patch, __tag, __index] +matchOneNontag = concatOptions [__match, __patch, __index] +matchSeveral = concatOptions [__matches, __patches, __tags] +matchRange = concatOptions [matchTo, matchFrom, __match, __patch, __last, __indexes] +matchSeveralOrRange = concatOptions [matchTo, matchFrom, __last, __indexes, __matches, __patches, __tags] -match_several_or_last = concat_options [match_from, __last, __matches, __patches, __tags] +matchSeveralOrLast = concatOptions [matchFrom, __last, __matches, __patches, __tags] -match_to, match_from :: DarcsOption -match_to = DarcsMultipleChoiceOption +matchTo, matchFrom :: DarcsOption +matchTo = DarcsMultipleChoiceOption [DarcsArgOption [] ["to-match"] uptop "PATTERN" "select changes up to a patch matching PATTERN", DarcsArgOption [] ["to-patch"] UpToPatch "REGEXP" @@ -643,7 +662,7 @@ DarcsArgOption [] ["to-tag"] UpToTag "REGEXP" "select changes up to a tag matching REGEXP"] where uptop s = UpToPattern (patch_match s) -match_from = DarcsMultipleChoiceOption +matchFrom = DarcsMultipleChoiceOption [DarcsArgOption [] ["from-match"] fromp "PATTERN" "select changes starting with a patch matching PATTERN", DarcsArgOption [] ["from-patch"] AfterPatch "REGEXP" @@ -673,7 +692,7 @@ __last = DarcsArgOption [] ["last"] lastn "NUMBER" "select the last NUMBER patches" - where lastn = LastN . number_string + where lastn = LastN . numberString __index = DarcsArgOption ['n'] ["index"] indexrange "N" "select one patch" where indexrange s = if all isDigit s @@ -690,17 +709,17 @@ else PatchIndexRange 0 0 isokay c = isDigit c || c == '-' -match_maxcount :: DarcsOption -match_maxcount = DarcsArgOption [] ["max-count"] mc "NUMBER" +matchMaxcount :: DarcsOption +matchMaxcount = DarcsArgOption [] ["max-count"] mc "NUMBER" "return only NUMBER results" - where mc = MaxCount . number_string + where mc = MaxCount . numberString --- | 'get_context' takes a list of flags and returns the context +-- | 'getContext' takes a list of flags and returns the context -- specified by @Context c@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--context=FILE@ -get_context :: [DarcsFlag] -> Maybe AbsolutePath -get_context xs = listToMaybe [ c | Context c <- xs ] +getContext :: [DarcsFlag] -> Maybe AbsolutePath +getContext xs = listToMaybe [ c | Context c <- xs ] notest = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script", @@ -708,7 +727,7 @@ test = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["test"] Test "run the test script", DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script"] -leave_test_dir = DarcsMultipleChoiceOption +leaveTestDir = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["leave-test-directory"] LeaveTestDir "don't remove the test directory", DarcsNoArgOption [] ["remove-test-directory"] @@ -719,7 +738,7 @@ \end{code} \begin{options} ---ignore-times +--ignore-times, --no-ignore-times \end{options} Darcs optimizes its operations by keeping track of the modification times of your files. This dramatically speeds up commands such as @@ -732,16 +751,22 @@ \verb!--ignore-times! option, which instructs darcs not to trust the file modification times, but instead to check each file's contents explicitly. \begin{code} -ignoretimes = DarcsNoArgOption [] ["ignore-times"] IgnoreTimes - "don't trust the file modification times" +ignoretimes = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["ignore-times"] IgnoreTimes + "don't trust the file modification times" + ,DarcsNoArgOption [] ["no-ignore-times"] DontIgnoreTimes + "trust modification times to find modified files [DEFAULT]" + ] + lookforadds = DarcsMultipleChoiceOption [DarcsNoArgOption ['l'] ["look-for-adds"] LookForAdds "look for (non-boring) files that could be added", - DarcsNoArgOption [] ["dont-look-for-adds"] NoLookForAdds + DarcsNoArgOption [] ["dont-look-for-adds","no-look-for-adds"] NoLookForAdds "don't look for any files that could be added [DEFAULT]"] -fancy_move_add = +fancyMoveAdd = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["date-trick"] FancyMoveAdd "add files with date appended to avoid conflict [EXPERIMENTAL] ", @@ -755,7 +780,7 @@ DarcsNoArgOption [] ["no-ask-deps"] NoAskDeps "don't ask for extra dependencies"] -ask_long_comment = +askLongComment = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["edit-long-comment"] EditLongComment "edit the long comment by default", @@ -768,45 +793,45 @@ \begin{options} --author \end{options} -\label{env:DARCS_EMAIL} -Several commands need to be able to identify you. Conventionally, you -provide an email address for this purpose, which can include comments, -e.g.\ \verb!David Roundy !. The easiest way to do -this is -to define an environment variable \verb!EMAIL! or \verb!DARCS_EMAIL! (with -the latter overriding the former). You can also override this using the -\verb!--author! flag to any command. Alternatively, you could set your -email address on a per-repository basis using the ``defaults'' mechanism -for ``ALL'' commands, as described in Appendix~\ref{repository_format}. -Or, you could specify the author on a per-repository basis using the -\verb!_darcs/prefs/author! file as described in section~\ref{author_prefs}. - -Also, a global author file can be created in your home directory with the name -\verb!.darcs/author!, on MS Windows~\ref{ms_win}. This file overrides the -contents of the environment variables, but a repository-specific author -file overrides the global author file. +\darcsEnv{DARCS_EMAIL} \begin{code} logfile = DarcsAbsPathOption [] ["logfile"] LogFile "FILE" "give patch name and comment in file" -rmlogfile = DarcsNoArgOption [] ["delete-logfile"] RmLogFile - "delete the logfile when done" +rmlogfile = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["delete-logfile"] RmLogFile + "delete the logfile when done", + DarcsNoArgOption [] ["no-delete-logfile"] DontRmLogFile + "keep the logfile when done [DEFAULT]"] author = DarcsArgOption ['A'] ["author"] Author "EMAIL" "specify author id" -from_opt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address" +fromOpt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address" --- | 'get_author' takes a list of flags and returns the author of the +fileHelpAuthor :: [String] +fileHelpAuthor = [ + "Each patch is attributed to its author, usually by email address (for", + "example, `Fred Bloggs '). Darcs looks in several", + "places for this author string: the --author option, the files", + "_darcs/prefs/author (in the repository) and ~/.darcs/author (in your", + "home directory), and the environment variables $DARCS_EMAIL and", + "$EMAIL. If none of those exist, Darcs will prompt you for an author", + "string and write it to _darcs/prefs/author."] + +environmentHelpEmail :: ([String], [String]) +environmentHelpEmail = (["DARCS_EMAIL","EMAIL"], fileHelpAuthor) + +-- | 'getAuthor' takes a list of flags and returns the author of the -- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any. -- Otherwise, if @Pipe@ is present, asks the user who is the author and -- returns the answer. If neither are present, try to guess the author, -- from @_darcs/prefs@, and if it's not possible, ask the user. -get_author :: [DarcsFlag] -> IO String -get_author (Author a:_) = return a -get_author (Pipe:_) = do askUser "Who is the author? " -get_author (_:flags) = get_author flags -get_author [] = do - easy_author <- get_easy_author +getAuthor :: [DarcsFlag] -> IO String +getAuthor (Author a:_) = return a +getAuthor (Pipe:_) = do askUser "Who is the author? " +getAuthor (_:flags) = getAuthor flags +getAuthor [] = do + easy_author <- getEasyAuthor case easy_author of Just a -> return a Nothing -> do @@ -822,16 +847,17 @@ text "If you move that file to ~/.darcs/author, it will be used for patches" $$ text "you record in ALL repositories." add <- askUser "What is your email address? " - writeFile (darcsdir++"/prefs/author") add + writeFile (darcsdir ++ "/prefs/author") $ + unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add return add else askUser "What is your email address (e.g. Fred Bloggs )? " --- | 'get_easy_author' tries to get the author name first from the repository preferences, +-- | 'getEasyAuthor' tries to get the author name first from the repository preferences, -- then from global preferences, then from environment variables. Returns 'Nothing' if it -- could not get it. -get_easy_author :: IO (Maybe String) -get_easy_author = firstJustIO [ firstNotBlank `fmap` get_preflist "author", - firstNotBlank `fmap` get_global "author", +getEasyAuthor :: IO (Maybe String) +getEasyAuthor = firstJustIO [ firstNotBlank `fmap` getPreflist "author", + firstNotBlank `fmap` getGlobal "author", maybeGetEnv "DARCS_EMAIL", maybeGetEnv "EMAIL" ] \end{code} @@ -845,13 +871,13 @@ file. \begin{code} -nocompress = concat_options [__compress, __dont_compress] -uncompress_nocompress = concat_options [__compress, __dont_compress, __uncompress] +nocompress = concatOptions [__compress, __dontCompress] +uncompressNocompress = concatOptions [__compress, __dontCompress, __uncompress] -__compress, __dont_compress, __uncompress :: DarcsOption +__compress, __dontCompress, __uncompress :: DarcsOption __compress = DarcsNoArgOption [] ["compress"] Compress "create compressed patches" -__dont_compress = DarcsNoArgOption [] ["dont-compress"] NoCompress +__dontCompress = DarcsNoArgOption [] ["dont-compress","no-compress"] NoCompress "don't create compressed patches" __uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress "uncompress patches" @@ -859,24 +885,37 @@ summary = DarcsMultipleChoiceOption [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes", DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"] -unified = DarcsNoArgOption ['u'] ["unified"] Unified - "output patch in a darcs-specific format similar to diff -u" -unidiff = DarcsNoArgOption ['u'] ["unified"] Unified - "pass -u option to diff" -diff_cmd_flag = DarcsArgOption [] ["diff-command"] +unified = DarcsMultipleChoiceOption + [DarcsNoArgOption ['u'] ["unified"] Unified + "output patch in a darcs-specific format similar to diff -u", + DarcsNoArgOption [] ["no-unified"] NonUnified + "output patch in darcs' usual format"] + +unidiff = DarcsMultipleChoiceOption + [DarcsNoArgOption ['u'] ["unified"] Unified + "pass -u option to diff", + DarcsNoArgOption [] ["no-unified"] NonUnified + "output patch in diff's dumb format"] + +diffCmdFlag = DarcsArgOption [] ["diff-command"] DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)" -store_in_memory = DarcsNoArgOption [] ["store-in-memory"] StoreInMemory - "do patch application in memory rather than on disk" +storeInMemory = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["store-in-memory"] StoreInMemory + "do patch application in memory rather than on disk", + DarcsNoArgOption [] ["no-store-in-memory"] ApplyOnDisk + "do patch application on disk [DEFAULT]"] + target = DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email" -cc = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply" +ccSend = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s)" +ccApply = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply" --- |'get_cc' takes a list of flags and returns the addresses to send a copy of +-- |'getCc' takes a list of flags and returns the addresses to send a copy of -- the patch bundle to when using @darcs send@. -- looks for a cc address specified by @Cc \"address\"@ in that list of flags. -- Returns the addresses as a comma separated string. -get_cc :: [DarcsFlag] -> String -get_cc fs = lt $ catMaybes $ map whatcc fs +getCc :: [DarcsFlag] -> String +getCc fs = lt $ catMaybes $ map whatcc fs where whatcc (Cc t) = Just t whatcc _ = Nothing lt [t] = t @@ -886,44 +925,44 @@ subject = DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject" --- |'get_subject' takes a list of flags and returns the subject of the mail +-- |'getSubject' takes a list of flags and returns the subject of the mail -- to be sent by @darcs send@. Looks for a subject specified by -- @Subject \"subject\"@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--subject=SUBJECT@ -get_subject :: [DarcsFlag] -> Maybe String -get_subject (Subject s:_) = Just s -get_subject (_:fs) = get_subject fs -get_subject [] = Nothing +getSubject :: [DarcsFlag] -> Maybe String +getSubject (Subject s:_) = Just s +getSubject (_:fs) = getSubject fs +getSubject [] = Nothing -in_reply_to = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header" -get_in_reply_to :: [DarcsFlag] -> Maybe String -get_in_reply_to (InReplyTo s:_) = Just s -get_in_reply_to (_:fs) = get_in_reply_to fs -get_in_reply_to [] = Nothing +inReplyTo = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header" +getInReplyTo :: [DarcsFlag] -> Maybe String +getInReplyTo (InReplyTo s:_) = Just s +getInReplyTo (_:fs) = getInReplyTo fs +getInReplyTo [] = Nothing output = DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE" "specify output filename" -output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY" +outputAutoName = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY" "output to automatically named file in DIRECTORY, default: current directory" -edit_description = +editDescription = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["edit-description"] EditDescription "edit the patch bundle description", - DarcsNoArgOption [] ["dont-edit-description"] NoEditDescription + DarcsNoArgOption [] ["dont-edit-description","no-edit-description"] NoEditDescription "don't edit the patch bundle description"] -distname_option = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" +distnameOption = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" "name of version" recursive h = DarcsMultipleChoiceOption [DarcsNoArgOption ['r'] ["recursive"] Recursive h, - DarcsNoArgOption [] ["not-recursive"] NoRecursive ("don't "++h)] + DarcsNoArgOption [] ["not-recursive","no-recursive"] NoRecursive ("don't "++h)] -inventory_choices :: DarcsOption -inventory_choices = +inventoryChoices :: DarcsOption +inventoryChoices = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["hashed"] UseHashedInventory "Some new features. Compatible with older repos", @@ -932,14 +971,19 @@ DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory "Minimal features. What older repos use."] -get_inventory_choices :: DarcsOption -get_inventory_choices = +getInventoryChoices :: DarcsOption +getInventoryChoices = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["hashed"] UseHashedInventory "Convert darcs-1 format to hashed format", DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory "Convert from hashed to darcs-1 format"] +upgradeFormat :: DarcsOption +upgradeFormat = + DarcsNoArgOption [] ["upgrade"] UpgradeFormat + "upgrade repository to latest compatible format" + xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput "generate XML formatted output" @@ -953,16 +997,21 @@ "sign the patch with a given keyid", DarcsArgOption [] ["sign-ssl"] SignSSL "IDFILE" "sign the patch using openssl with a given private key", - DarcsNoArgOption [] ["dont-sign"] NoSign + DarcsNoArgOption [] ["dont-sign","no-sign"] NoSign "don't sign the patch"] applyas = DarcsMultipleChoiceOption [DarcsArgOption [] ["apply-as"] ApplyAs "USERNAME" "apply patch as another user using sudo", - DarcsNoArgOption [] ["apply-as-myself"] NonApply + DarcsNoArgOption [] ["no-apply-as"] NonApply "don't use sudo to apply as another user [DEFAULT]"] -happy_forwarding = DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding - "forward unsigned messages without extra header" -set_default = DarcsMultipleChoiceOption + +happyForwarding = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding + "forward unsigned messages without extra header", + DarcsNoArgOption [] ["no-happy-forwarding"] NoHappyForwarding + "don't forward unsigned messages without extra header [DEFAULT]"] + +setDefault = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["set-default"] SetDefault "set default repository [DEFAULT]", DarcsNoArgOption [] ["no-set-default"] NoSetDefault @@ -979,22 +1028,18 @@ reponame = DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY" "path of output directory" --repodir is there for compatibility --should be removed eventually -tagname = DarcsArgOption ['t'] ["tag"] TagName "TAGNAME" - "name of version to checkpoint" -deps_sel = DarcsMultipleChoiceOption +depsSel = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["no-deps"] DontGrabDeps "don't automatically fulfill dependencies", DarcsNoArgOption [] ["dont-prompt-for-dependencies"] DontPromptForDependencies "don't ask about patches that are depended on by matched patches (with --match or --patch)", DarcsNoArgOption [] ["prompt-for-dependencies"] PromptForDependencies "prompt about patches that are depended on by matched patches [DEFAULT]"] -checkpoint = DarcsNoArgOption [] ["checkpoint"] CheckPoint - "create a checkpoint file (see get --partial)" tokens = DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\"" "define token to contain these characters" -partial = concat_options [__partial, __lazy, __ephemeral, __complete] -partial_check = concat_options [__complete, __partial] +partial = concatOptions [__partial, __lazy, __ephemeral, __complete] +partialCheck = concatOptions [__complete, __partial] __partial, __lazy, __ephemeral, __complete :: DarcsOption __partial = DarcsNoArgOption [] ["partial"] Partial @@ -1006,14 +1051,14 @@ __complete = DarcsNoArgOption [] ["complete"] Complete "get a complete copy of the repository" -force_replace = DarcsMultipleChoiceOption +forceReplace = DarcsMultipleChoiceOption [DarcsNoArgOption ['f'] ["force"] ForceReplace "proceed with replace even if 'new' token already exists", DarcsNoArgOption [] ["no-force"] NonForce "don't force the replace if it looks scary"] reply = DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address" -apply_conflict_options +applyConflictOptions = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["mark-conflicts"] MarkConflicts "mark conflicts", @@ -1021,17 +1066,23 @@ AllowConflicts "allow conflicts, but don't mark them", DarcsNoArgOption [] ["no-resolve-conflicts"] NoAllowConflicts "equivalent to --dont-allow-conflicts, for backwards compatibility", - DarcsNoArgOption [] ["dont-allow-conflicts"] - NoAllowConflicts "fail on patches that create conflicts [DEFAULT]"] -pull_conflict_options + DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"] + NoAllowConflicts "fail if there are patches that would create conflicts [DEFAULT]", + DarcsNoArgOption [] ["skip-conflicts"] + SkipConflicts "filter out any patches that would create conflicts" + ] +pullConflictOptions = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["mark-conflicts"] MarkConflicts "mark conflicts [DEFAULT]", DarcsNoArgOption [] ["allow-conflicts"] AllowConflicts "allow conflicts, but don't mark them", - DarcsNoArgOption [] ["dont-allow-conflicts"] - NoAllowConflicts "fail on patches that create conflicts"] -use_external_merge = DarcsArgOption [] ["external-merge"] + DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"] + NoAllowConflicts "fail if there patches that would create conflicts", + DarcsNoArgOption [] ["skip-conflicts"] + SkipConflicts "filter out any patches that would create conflicts" + ] +useExternalMerge = DarcsArgOption [] ["external-merge"] ExternalMerge "COMMAND" "use external tool to merge conflicts" \end{code} @@ -1079,15 +1130,15 @@ An exclamation mark appears next to any option that has a conflict. \begin{code} --- NOTE: I'd rather work to have no uses of dry_run_noxml, so that any time +-- NOTE: I'd rather work to have no uses of dryRunNoxml, so that any time -- --dry-run is a possibility, automated users can examine the results more -- easily with --xml. -dry_run_noxml :: DarcsOption -dry_run_noxml = DarcsNoArgOption [] ["dry-run"] DryRun +dryRunNoxml :: DarcsOption +dryRunNoxml = DarcsNoArgOption [] ["dry-run"] DryRun "don't actually take the action" -dry_run :: [DarcsOption] -dry_run = [dry_run_noxml, xmloutput] +dryRun :: [DarcsOption] +dryRun = [dryRunNoxml, xmloutput] -- | @'showFriendly' flags patch@ returns a 'Doc' representing the right -- way to show @patch@ given the list @flags@ of flags darcs was invoked with. @@ -1096,14 +1147,14 @@ | Summary `elem` opts = Darcs.Patch.summary p | otherwise = description p --- | @'print_dry_run_message_and_exit' action opts patches@ prints a string +-- | @'printDryRunMessageAndExit' action opts patches@ prints a string -- representing the action that would be taken if the @--dry-run@ option -- had not been passed to darcs. Then darcs exits successfully. -- @action@ is the name of the action being taken, like @\"push\"@ -- @opts@ is the list of flags which were sent to darcs -- @patches@ is the sequence of patches which would be touched by @action@. -print_dry_run_message_and_exit :: RepoPatch p => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () -print_dry_run_message_and_exit action opts patches = +printDryRunMessageAndExit :: RepoPatch p => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () +printDryRunMessageAndExit action opts patches = do when (DryRun `elem` opts) $ do putInfo $ text $ "Would " ++ action ++ " the following changes:" putDocLn $ put_mode @@ -1125,7 +1176,7 @@ xml_with_summary hp | Just p <- hopefullyM hp = insert_before_lastline - (to_xml $ info hp) (indent $ xml_summary p) + (to_xml $ info hp) (indent $ xmlSummary p) xml_with_summary hp = to_xml (info hp) indent = prefix " " @@ -1135,33 +1186,48 @@ \input{Darcs/Resolution.lhs} \begin{code} -noskip_boring = DarcsNoArgOption [] ["boring"] - Boring "don't skip boring files" -allow_problematic_filenames = DarcsMultipleChoiceOption +noskipBoring = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["boring"] + Boring "don't skip boring files", + DarcsNoArgOption [] ["no-boring"] + SkipBoring "skip borign files [DEFAULT]"] + +allowProblematicFilenames = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly "don't refuse to add files differing only in case" + ,DarcsNoArgOption [] ["no-case-ok"] DontAllowCaseOnly + "refuse to add files whose name differ only in case [DEFAULT]" ,DarcsNoArgOption [] ["reserved-ok"] AllowWindowsReserved "don't refuse to add files with Windows-reserved names" - ] + ,DarcsNoArgOption [] ["no-reserved-ok"] DontAllowWindowsReserved + "refuse to add files with Windows-reserved names [DEFAULT]"] + diffflags = DarcsArgOption [] ["diff-opts"] DiffFlags "OPTIONS" "options to pass to diff" -changes_format = DarcsMultipleChoiceOption +changesFormat = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["context"] (Context rootDirectory) "give output suitable for get --context", xmloutput, - human_readable, + humanReadable, DarcsNoArgOption [] ["number"] NumberPatches "number the changes", DarcsNoArgOption [] ["count"] Count "output count of changes" ] -changes_reverse = DarcsNoArgOption [] ["reverse"] Reverse - "show changes in reverse order" +changesReverse = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["reverse"] Reverse + "show changes in reverse order" + ,DarcsNoArgOption [] ["no-reverse"] Forward + "show changes in the usual order [DEFAULT]"] -only_to_files :: DarcsOption -only_to_files = DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles - "show only changes to specified files" +onlyToFiles :: DarcsOption +onlyToFiles = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles + "show only changes to specified files", + DarcsNoArgOption [] ["no-only-to-files"] ChangesToAllFiles + "show changes to all files [DEFAULT]"] -human_readable = DarcsNoArgOption [] ["human-readable"] + +humanReadable = DarcsNoArgOption [] ["human-readable"] HumanReadable "give human-readable output" pipe = DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata" @@ -1170,15 +1236,15 @@ "prompt user interactively" all_patches = DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches" -all_interactive = DarcsMultipleChoiceOption [all_patches, interactive] +allInteractive = DarcsMultipleChoiceOption [all_patches, interactive] -all_pipe_interactive +allPipeInteractive = DarcsMultipleChoiceOption [all_patches,pipe,interactive] -pipe_interactive = +pipeInteractive = DarcsMultipleChoiceOption [pipe, interactive] -repo_combinator = +repoCombinator = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["intersection"] Intersection "take intersection of all repositories", @@ -1187,80 +1253,76 @@ DarcsNoArgOption [] ["complement"] Complement "take complement of repositories (in order listed)"] --- | 'list_files' returns the list of all non-boring files in the repository -list_files :: IO [String] -list_files = do s <- slurp_all_but_darcs "." - skip_boring <- boring_file_filter - return (map drop_dotslash $ skip_boring $ list_slurpy s) - -drop_dotslash :: String -> String -drop_dotslash ('.':'/':x) = drop_dotslash x -drop_dotslash x = x +-- | Get a list of all non-boring files and directories in the working copy. +listFiles :: IO [String] +listFiles = do nonboring <- restrictBoring emptyTree + working <- expand =<< nonboring <$> readPlainTree "." + return $ map (anchorPath "" . fst) $ list working --- | 'list_unregistered_files' returns the list of all non-boring unregistered +-- | 'listUnregisteredFiles' returns the list of all non-boring unregistered -- files in the repository. -list_unregistered_files :: IO [String] -list_unregistered_files = withRepository [] $- \repository -> - do s <- slurp_all_but_darcs "." - skip_boring <- boring_file_filter - regs <- slurp_pending repository - return $ map drop_dotslash $ (skip_boring $ list_slurpy s) \\ (list_slurpy regs) +listUnregisteredFiles :: IO [String] +listUnregisteredFiles = + do unregd <- listFiles + regd <- listRegisteredFiles + return $ unregd \\ regd -- (inefficient) --- | 'list_registered_files' returns the list of all registered files in the repository. -list_registered_files :: IO [String] -list_registered_files = - (map drop_dotslash . list_slurpy) `fmap` (withRepository [] slurp_pending) +-- | 'listRegisteredFiles' returns the list of all registered files in the repository. +listRegisteredFiles :: IO [String] +listRegisteredFiles = + do recorded <- expand =<< withRepository [] readRecordedAndPending + return $ map (anchorPath "" . fst) $ list recorded -options_latex :: [DarcsOption] -> String -options_latex opts = "\\begin{tabular}{lll}\n"++ - unlines (map option_latex opts)++ +optionsLatex :: [DarcsOption] -> String +optionsLatex opts = "\\begin{tabular}{lll}\n"++ + unlines (map optionLatex opts)++ "\\end{tabular}\n" -latex_help :: String -> String -latex_help h +latexHelp :: String -> String +latexHelp h = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n" -option_latex :: DarcsOption -> String -option_latex (DarcsNoArgOption a b _ h) = - show_short_options a ++ show_long_options b ++ latex_help h ++ "\\\\" -option_latex (DarcsArgOption a b _ arg h) = - show_short_options a ++ - show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\" -option_latex (DarcsAbsPathOrStdOption a b _ arg h) = - show_short_options a ++ - show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\" -option_latex (DarcsAbsPathOption a b _ arg h) = - show_short_options a ++ - show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\" -option_latex (DarcsOptAbsPathOption a b _ _ arg h) = - show_short_options a ++ - show_long_options (map (++("[="++arg++"]")) b) ++ latex_help h ++ "\\\\" -option_latex (DarcsMultipleChoiceOption os) = - unlines (map option_latex os) +optionLatex :: DarcsOption -> String +optionLatex (DarcsNoArgOption a b _ h) = + showShortOptions a ++ showLongOptions b ++ latexHelp h ++ "\\\\" +optionLatex (DarcsArgOption a b _ arg h) = + showShortOptions a ++ + showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\" +optionLatex (DarcsAbsPathOrStdOption a b _ arg h) = + showShortOptions a ++ + showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\" +optionLatex (DarcsAbsPathOption a b _ arg h) = + showShortOptions a ++ + showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\" +optionLatex (DarcsOptAbsPathOption a b _ _ arg h) = + showShortOptions a ++ + showLongOptions (map (++("[="++arg++"]")) b) ++ latexHelp h ++ "\\\\" +optionLatex (DarcsMultipleChoiceOption os) = + unlines (map optionLatex os) -show_short_options :: [Char] -> String -show_short_options [] = "&" -show_short_options [c] = "\\verb!-"++[c]++"! &" -show_short_options (c:cs) = "\\verb!-"++[c]++"!,"++show_short_options cs +showShortOptions :: [Char] -> String +showShortOptions [] = "&" +showShortOptions [c] = "\\verb!-"++[c]++"! &" +showShortOptions (c:cs) = "\\verb!-"++[c]++"!,"++showShortOptions cs -show_long_options :: [String] -> String -show_long_options [] = " &" -show_long_options [s] = "\\verb!--" ++ s ++ "! &" -show_long_options (s:ss) - = "\\verb!--" ++ s ++ "!,"++ show_long_options ss +showLongOptions :: [String] -> String +showLongOptions [] = " &" +showLongOptions [s] = "\\verb!--" ++ s ++ "! &" +showLongOptions (s:ss) + = "\\verb!--" ++ s ++ "!,"++ showLongOptions ss -set_scripts_executable :: DarcsOption -set_scripts_executable = DarcsMultipleChoiceOption +setScriptsExecutableOption :: DarcsOption +setScriptsExecutableOption = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["set-scripts-executable"] SetScriptsExecutable "make scripts executable", - DarcsNoArgOption [] ["dont-set-scripts-executable"] DontSetScriptsExecutable + DarcsNoArgOption [] ["dont-set-scripts-executable","no-set-scripts-executable"] DontSetScriptsExecutable "don't make scripts executable"] -relink, relink_pristine, sibling :: DarcsOption +relink, relinkPristine, sibling :: DarcsOption relink = DarcsNoArgOption [] ["relink"] Relink "relink random internal data to a sibling" -relink_pristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine +relinkPristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine "relink pristine tree (not recommended)" sibling = DarcsAbsPathOption [] ["sibling"] Sibling "URL" @@ -1276,8 +1338,8 @@ nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks "do not link repository or pristine to sibling" -reorder_patches :: DarcsOption -reorder_patches = DarcsNoArgOption [] ["reorder-patches"] Reorder +reorderPatches :: DarcsOption +reorderPatches = DarcsNoArgOption [] ["reorder-patches"] Reorder "reorder the patches in the repository" \end{code} \begin{options} @@ -1286,7 +1348,7 @@ \darcsEnv{SENDMAIL} \begin{code} -sendmail_cmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command" +sendmailCmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command" environmentHelpSendmail :: ([String], [String]) environmentHelpSendmail = (["SENDMAIL"], [ @@ -1303,15 +1365,15 @@ -- * on a multi-user system without an MTA and on which you haven't -- got root, can be msmtp. --- |'get_sendmail_cmd' takes a list of flags and returns the sendmail command +-- |'getSendmailCmd' takes a list of flags and returns the sendmail command -- to be used by @darcs send@. Looks for a command specified by -- @SendmailCmd \"command\"@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@ -- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present. -get_sendmail_cmd :: [DarcsFlag] -> IO String -get_sendmail_cmd (SendmailCmd a:_) = return a -get_sendmail_cmd (_:flags) = get_sendmail_cmd flags -get_sendmail_cmd [] = do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ] +getSendmailCmd :: [DarcsFlag] -> IO String +getSendmailCmd (SendmailCmd a:_) = return a +getSendmailCmd (_:flags) = getSendmailCmd flags +getSendmailCmd [] = do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ] case easy_sendmail of Just a -> return a Nothing -> return "" @@ -1341,6 +1403,9 @@ nullFlag = DarcsNoArgOption ['0'] ["null"] NullFlag "separate file names by NUL characters" \end{code} + +\subsection{Posthooks} + \begin{options} --posthook=COMMAND, --no-posthook \end{options} @@ -1382,7 +1447,7 @@ vcat (mapFL (to_xml . info) ps) $$ text "") finishedOneIO k "DARCS_FILES" - setEnvCautiously "DARCS_FILES" (unlines$ list_touched_files ps) + setEnvCautiously "DARCS_FILES" (unlines$ listTouchedFiles ps) endTedious k setEnvCautiously :: String -> String -> IO () @@ -1398,32 +1463,35 @@ defineChanges :: Patchy p => p C(x y) -> IO () #ifndef WIN32 -defineChanges ps = setEnvCautiously "DARCS_FILES" (unlines $ list_touched_files ps) +defineChanges ps = setEnvCautiously "DARCS_FILES" (unlines $ listTouchedFiles ps) #else defineChanges _ = return () #endif -posthook_cmd :: DarcsOption -posthook_cmd = DarcsMultipleChoiceOption +posthookCmd :: DarcsOption +posthookCmd = DarcsMultipleChoiceOption [DarcsArgOption [] ["posthook"] PosthookCmd "COMMAND" "specify command to run after this darcs command", DarcsNoArgOption [] ["no-posthook"] NoPosthook "don't run posthook command"] -posthook_prompt :: DarcsOption -posthook_prompt = DarcsMultipleChoiceOption +posthookPrompt :: DarcsOption +posthookPrompt = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["prompt-posthook"] AskPosthook "prompt before running posthook [DEFAULT]", DarcsNoArgOption [] ["run-posthook"] RunPosthook "run posthook command without prompting"] --- | 'get_posthook_cmd' takes a list of flags and returns the posthook command +-- | 'getPosthookCmd' takes a list of flags and returns the posthook command -- specified by @PosthookCmd a@ in that list of flags, if any. -get_posthook_cmd :: [DarcsFlag] -> Maybe String -get_posthook_cmd (PosthookCmd a:_) = Just a -get_posthook_cmd (_:flags) = get_posthook_cmd flags -get_posthook_cmd [] = Nothing +getPosthookCmd :: [DarcsFlag] -> Maybe String +getPosthookCmd (PosthookCmd a:_) = Just a +getPosthookCmd (_:flags) = getPosthookCmd flags +getPosthookCmd [] = Nothing \end{code} + +\subsection{Prehooks} + \begin{options} --prehook=COMMAND, --no-prehook \end{options} @@ -1438,26 +1506,26 @@ These options control prompting before running the prehook. See the posthook documentation above for details. \begin{code} -prehook_cmd :: DarcsOption -prehook_cmd = DarcsMultipleChoiceOption +prehookCmd :: DarcsOption +prehookCmd = DarcsMultipleChoiceOption [DarcsArgOption [] ["prehook"] PrehookCmd "COMMAND" "specify command to run before this darcs command", DarcsNoArgOption [] ["no-prehook"] NoPrehook "don't run prehook command"] -prehook_prompt :: DarcsOption -prehook_prompt = DarcsMultipleChoiceOption +prehookPrompt :: DarcsOption +prehookPrompt = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["prompt-prehook"] AskPrehook "prompt before running prehook [DEFAULT]", DarcsNoArgOption [] ["run-prehook"] RunPrehook "run prehook command without prompting"] --- | 'get_prehook_cmd' takes a list of flags and returns the prehook command +-- | 'getPrehookCmd' takes a list of flags and returns the prehook command -- specified by @PrehookCmd a@ in that list of flags, if any. -get_prehook_cmd :: [DarcsFlag] -> Maybe String -get_prehook_cmd (PrehookCmd a:_) = Just a -get_prehook_cmd (_:flags) = get_prehook_cmd flags -get_prehook_cmd [] = Nothing +getPrehookCmd :: [DarcsFlag] -> Maybe String +getPrehookCmd (PrehookCmd a:_) = Just a +getPrehookCmd (_:flags) = getPrehookCmd flags +getPrehookCmd [] = Nothing \end{code} \begin{options} @@ -1486,8 +1554,8 @@ Do not use patch caches. \begin{code} -network_options :: [DarcsOption] -network_options = +networkOptions :: [DarcsOption] +networkOptions = [DarcsMultipleChoiceOption [DarcsNoArgOption [] ["ssh-cm"] SSHControlMaster "use SSH ControlMaster feature", @@ -1498,7 +1566,7 @@ pipelining_description, DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining no_pipelining_description], - no_cache + noCache, remote_darcs ] where pipelining_description = "enable HTTP pipelining"++ @@ -1507,9 +1575,17 @@ "disable HTTP pipelining"++ (if pipeliningEnabledByDefault then "" else " [DEFAULT]") -no_cache :: DarcsOption -no_cache = DarcsNoArgOption [] ["no-cache"] NoCache +remote_darcs :: DarcsOption +remote_darcs = DarcsArgOption [] ["remote-darcs"] RemoteDarcs "COMMAND" + "name of the darcs executable on the remote server" + +noCache :: DarcsOption +noCache = DarcsNoArgOption [] ["no-cache"] NoCache "don't use patch caches" + +optimizePristine :: DarcsOption +optimizePristine = DarcsNoArgOption [] ["pristine"] OptimizePristine + "optimize hashed pristine layout" \end{code} \begin{options} --umask @@ -1519,8 +1595,8 @@ writing to the repository. \begin{code} -umask_option :: DarcsOption -umask_option = +umaskOption :: DarcsOption +umaskOption = DarcsArgOption [] ["umask"] UMask "UMASK" "specify umask to use when writing" \end{code} @@ -1545,11 +1621,11 @@ the command line, when pulling or applying unknown patches. \begin{code} -restrict_paths = +restrictPaths = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths "don't allow darcs to touch external files or repo metadata", - DarcsNoArgOption [] ["dont-restrict-paths"] DontRestrictPaths + DarcsNoArgOption [] ["dont-restrict-paths","no-restrict-paths"] DontRestrictPaths "allow darcs to modify any file or directory (unsafe)"] \end{code} @@ -1560,13 +1636,13 @@ doing pull, push and send. This option makes darcs skip this check. \begin{code} -allow_unrelated_repos = +allowUnrelatedRepos = DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos "do not check if repositories are unrelated" \end{code} \begin{code} -just_this_repo :: DarcsOption +justThisRepo :: DarcsOption \end{code} \begin{options} @@ -1576,13 +1652,13 @@ omits any caches or other repos listed as a source of patches. \begin{code} -just_this_repo = +justThisRepo = DarcsNoArgOption [] ["just-this-repo"] JustThisRepo "Limit the check or repair to the current repo" \end{code} \begin{code} -check, repair, check_or_repair :: DarcsOption +check, repair, checkOrRepair :: DarcsOption \end{code} \begin{options} @@ -1606,30 +1682,31 @@ DarcsNoArgOption [] ["repair"] Repair "Specify repair mode" -check_or_repair = concat_options [check, repair] +checkOrRepair = concatOptions [check, repair] --- | @'patch_select_flag' f@ holds whenever @f@ is a way of selecting +-- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting -- patches such as @PatchName n@. -patch_select_flag :: DarcsFlag -> Bool -patch_select_flag All = True -patch_select_flag (PatchName _) = True -patch_select_flag (OnePatch _) = True -patch_select_flag (SeveralPatch _) = True -patch_select_flag (AfterPatch _) = True -patch_select_flag (UpToPatch _) = True -patch_select_flag (TagName _) = True -patch_select_flag (LastN _) = True -patch_select_flag (OneTag _) = True -patch_select_flag (AfterTag _) = True -patch_select_flag (UpToTag _) = True -patch_select_flag (OnePattern _) = True -patch_select_flag (SeveralPattern _) = True -patch_select_flag (AfterPattern _) = True -patch_select_flag (UpToPattern _) = True -patch_select_flag _ = False +patchSelectFlag :: DarcsFlag -> Bool +patchSelectFlag All = True +patchSelectFlag (PatchName _) = True +patchSelectFlag (OnePatch _) = True +patchSelectFlag (SeveralPatch _) = True +patchSelectFlag (AfterPatch _) = True +patchSelectFlag (UpToPatch _) = True +patchSelectFlag (TagName _) = True +patchSelectFlag (LastN _) = True +patchSelectFlag (OneTag _) = True +patchSelectFlag (AfterTag _) = True +patchSelectFlag (UpToTag _) = True +patchSelectFlag (OnePattern _) = True +patchSelectFlag (SeveralPattern _) = True +patchSelectFlag (AfterPattern _) = True +patchSelectFlag (UpToPattern _) = True +patchSelectFlag _ = False -- | The integer corresponding to a string, if it's only composed of digits. -- Otherwise, -1. -number_string :: String -> Int -number_string s = if and (map isDigit s) then read s else (-1) +numberString :: String -> Int +numberString "" = -1 +numberString s = if all isDigit s then read s else (-1) \end{code} diff --git a/src/Darcs/Commands.lhs b/src/Darcs/Commands.lhs --- a/src/Darcs/Commands.lhs +++ b/src/Darcs/Commands.lhs @@ -16,39 +16,40 @@ % Boston, MA 02110-1301, USA. \begin{code} -module Darcs.Commands ( CommandControl( Command_data, Hidden_command, Group_name ), - DarcsCommand( DarcsCommand, command_name, - command_help, command_description, - command_basic_options, command_advanced_options, - command_command, - command_prereq, - command_extra_arg_help, - command_extra_args, - command_argdefaults, - command_get_arg_possibilities, +module Darcs.Commands ( CommandControl( CommandData, HiddenCommand, GroupName ), + DarcsCommand( DarcsCommand, commandName, + commandHelp, commandDescription, + commandBasicOptions, commandAdvancedOptions, + commandCommand, + commandPrereq, + commandExtraArgHelp, + commandExtraArgs, + commandArgdefaults, + commandGetArgPossibilities, SuperCommand, - command_sub_commands ), - command_alias, command_stub, - command_options, command_alloptions, - disambiguate_commands, CommandArgs(..), - get_command_help, get_command_mini_help, - get_subcommands, - usage, subusage, chomp_newline, - extract_commands, - super_name, + commandSubCommands ), + commandAlias, commandStub, + commandOptions, commandAlloptions, + disambiguateCommands, CommandArgs(..), + getCommandHelp, getCommandMiniHelp, + getSubcommands, + usage, subusage, chompNewline, + extractCommands, + superName, nodefaults, - loggers, + putInfo, putVerbose, putWarning, abortRun ) where import System.Console.GetOpt( OptDescr, usageInfo ) +import Control.Monad (when, unless) import Data.List ( sort, isPrefixOf ) -import Darcs.Arguments ( DarcsFlag, DarcsOption, disable, help, - any_verbosity, posthook_cmd, posthook_prompt, - prehook_cmd, prehook_prompt, option_from_darcsoption ) +import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption, disable, help, + anyVerbosity, posthookCmd, posthookPrompt, + prehookCmd, prehookPrompt, optionFromDarcsoption ) import Darcs.RepoPath ( AbsolutePath, rootDirectory ) -import Darcs.Utils ( putStrLnError ) -import Printer ( Doc, putDocLn ) +import Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc ) +import System.IO ( stderr ) \end{code} The general format of a darcs command is @@ -114,78 +115,78 @@ \end{center} \begin{code} -extract_commands, extract_hidden_commands :: [CommandControl] -> [DarcsCommand] -extract_commands cs = concatMap (\x -> case x of { Command_data cmd_d -> [cmd_d]; _ -> []}) cs -extract_hidden_commands cs = concatMap (\x -> case x of { Hidden_command cmd_d -> [cmd_d]; _ -> []}) cs +extractCommands, extractHiddenCommands :: [CommandControl] -> [DarcsCommand] +extractCommands cs = concatMap (\x -> case x of { CommandData cmd_d -> [cmd_d]; _ -> []}) cs +extractHiddenCommands cs = concatMap (\x -> case x of { HiddenCommand cmd_d -> [cmd_d]; _ -> []}) cs \end{code} \input{Darcs/Arguments.lhs} \begin{code} -data CommandControl = Command_data DarcsCommand - | Hidden_command DarcsCommand - | Group_name String +data CommandControl = CommandData DarcsCommand + | HiddenCommand DarcsCommand + | GroupName String data DarcsCommand = - DarcsCommand {command_name, command_help, command_description :: String, - command_extra_args :: Int, - command_extra_arg_help :: [String], - command_command :: [DarcsFlag] -> [String] -> IO (), - command_prereq :: [DarcsFlag] -> IO (Either String ()), - command_get_arg_possibilities :: IO [String], - command_argdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String], - command_basic_options :: [DarcsOption], - command_advanced_options :: [DarcsOption]} - | SuperCommand {command_name, command_help, command_description :: String, - command_prereq :: [DarcsFlag] -> IO (Either String ()), - command_sub_commands :: [CommandControl]} + DarcsCommand {commandName, commandHelp, commandDescription :: String, + commandExtraArgs :: Int, + commandExtraArgHelp :: [String], + commandCommand :: [DarcsFlag] -> [String] -> IO (), + commandPrereq :: [DarcsFlag] -> IO (Either String ()), + commandGetArgPossibilities :: IO [String], + commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String], + commandBasicOptions :: [DarcsOption], + commandAdvancedOptions :: [DarcsOption]} + | SuperCommand {commandName, commandHelp, commandDescription :: String, + commandPrereq :: [DarcsFlag] -> IO (Either String ()), + commandSubCommands :: [CommandControl]} -command_alloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption]) -command_alloptions DarcsCommand { command_basic_options = opts1 - , command_advanced_options = opts2 } +commandAlloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption]) +commandAlloptions DarcsCommand { commandBasicOptions = opts1 + , commandAdvancedOptions = opts2 } = (opts1 ++ [disable, help], - any_verbosity ++ opts2 ++ - [posthook_cmd, posthook_prompt - ,prehook_cmd, prehook_prompt]) + anyVerbosity ++ opts2 ++ + [posthookCmd, posthookPrompt + ,prehookCmd, prehookPrompt]) -- Supercommands cannot be disabled. -command_alloptions SuperCommand { } = ([help],[]) +commandAlloptions SuperCommand { } = ([help],[]) -- Obtain options suitable as input to -- System.Console.Getopt, including the --disable option (which is -- not listed explicitly in the DarcsCommand definitions). -command_options :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag]) -command_options cwd c = (convert basic, convert advanced) - where (basic, advanced) = command_alloptions c - convert = concatMap (option_from_darcsoption cwd) +commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag]) +commandOptions cwd c = (convert basic, convert advanced) + where (basic, advanced) = commandAlloptions c + convert = concatMap (optionFromDarcsoption cwd) nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] nodefaults _ _ xs = return xs -get_subcommands :: DarcsCommand -> [CommandControl] -get_subcommands c@(SuperCommand {}) = command_sub_commands c -get_subcommands _ = [] +getSubcommands :: DarcsCommand -> [CommandControl] +getSubcommands c@(SuperCommand {}) = commandSubCommands c +getSubcommands _ = [] -command_alias :: String -> DarcsCommand -> DarcsCommand -command_alias n c = - c { command_name = n - , command_description = "Alias for `darcs " ++ command_name c ++ "'." - , command_help = "The `darcs " ++ n ++ "' command is an alias for " ++ - "`darcs " ++ command_name c ++ "'.\n" ++ - command_help c +commandAlias :: String -> DarcsCommand -> DarcsCommand +commandAlias n c = + c { commandName = n + , commandDescription = "Alias for `darcs " ++ commandName c ++ "'." + , commandHelp = "The `darcs " ++ n ++ "' command is an alias for " ++ + "`darcs " ++ commandName c ++ "'.\n" ++ + commandHelp c } -command_stub :: String -> String -> String -> DarcsCommand -> DarcsCommand -command_stub n h d c = - c { command_name = n - , command_help = h - , command_description = d - , command_command = \_ _ -> putStr h +commandStub :: String -> String -> String -> DarcsCommand -> DarcsCommand +commandStub n h d c = + c { commandName = n + , commandHelp = h + , commandDescription = d + , commandCommand = \_ _ -> putStr h } usage :: [CommandControl] -> String usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++ - usage_helper cs ++ "\n" ++ + usageHelper cs ++ "\n" ++ "Use 'darcs COMMAND --help' for help on a single command.\n" ++ "Use 'darcs --version' to see the darcs version number.\n" ++ "Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" ++ @@ -197,67 +198,67 @@ subusage :: DarcsCommand -> String subusage super = (usageInfo - ("Usage: darcs "++command_name super++" SUBCOMMAND ... " ++ - "\n\n"++ command_description super++ - "\n\nSubcommands:\n" ++ usage_helper (get_subcommands super) ++ "\nOptions:") - (option_from_darcsoption rootDirectory help)) - ++ "\n" ++ command_help super + ("Usage: darcs "++commandName super++" SUBCOMMAND ... " ++ + "\n\n"++ commandDescription super++ + "\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:") + (optionFromDarcsoption rootDirectory help)) + ++ "\n" ++ commandHelp super -usage_helper :: [CommandControl] -> String -usage_helper [] = "" -usage_helper (Hidden_command _:cs) = usage_helper cs -usage_helper ((Command_data c):cs) = " "++pad_spaces (command_name c) 15 ++ - chomp_newline (command_description c)++"\n"++usage_helper cs -usage_helper ((Group_name n):cs) = "\n" ++ n ++ "\n" ++ usage_helper cs +usageHelper :: [CommandControl] -> String +usageHelper [] = "" +usageHelper (HiddenCommand _:cs) = usageHelper cs +usageHelper ((CommandData c):cs) = " "++padSpaces (commandName c) 15 ++ + chompNewline (commandDescription c)++"\n"++usageHelper cs +usageHelper ((GroupName n):cs) = "\n" ++ n ++ "\n" ++ usageHelper cs -chomp_newline :: String -> String -chomp_newline "" = "" -chomp_newline s = if last s == '\n' then init s else s +chompNewline :: String -> String +chompNewline "" = "" +chompNewline s = if last s == '\n' then init s else s -pad_spaces :: String -> Int -> String -pad_spaces s n = s ++ replicate (n - length s) ' ' +padSpaces :: String -> Int -> String +padSpaces s n = s ++ replicate (n - length s) ' ' -super_name :: Maybe DarcsCommand -> String -super_name Nothing = "" -super_name (Just x) = command_name x ++ " " +superName :: Maybe DarcsCommand -> String +superName Nothing = "" +superName (Just x) = commandName x ++ " " -get_command_mini_help :: Maybe DarcsCommand -> DarcsCommand -> String -get_command_mini_help msuper cmd = - get_command_help_core msuper cmd ++ +getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String +getCommandMiniHelp msuper cmd = + getCommandHelpCore msuper cmd ++ "\n\nSee darcs help " - ++ (maybe "" (\c -> command_name c ++ " ") msuper) - ++ command_name cmd ++ " for details." + ++ (maybe "" (\c -> commandName c ++ " ") msuper) + ++ commandName cmd ++ " for details." -get_command_help :: Maybe DarcsCommand -> DarcsCommand -> String -get_command_help msuper cmd = +getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> String +getCommandHelp msuper cmd = unlines (reverse basicR) ++ (if null advanced then "" else "\nAdvanced options:\n" ++ unlines (reverse advancedR)) - ++ "\n" ++ command_help cmd + ++ "\n" ++ commandHelp cmd where -- we could just call usageInfo twice, but then the advanced -- options might not line up with the basic ones (no short flags) (advancedR, basicR) = splitAt (length advanced) $ reverse $ lines combinedUsage combinedUsage = usageInfo - (get_command_help_core msuper cmd ++ subcommands ++ "\n\nOptions:") + (getCommandHelpCore msuper cmd ++ subcommands ++ "\n\nOptions:") (basic ++ advanced) - (basic, advanced) = command_options rootDirectory cmd + (basic, advanced) = commandOptions rootDirectory cmd subcommands = case msuper of - Nothing -> case get_subcommands cmd of + Nothing -> case getSubcommands cmd of [] -> [] - s -> "\n\nSubcommands:\n" ++ (usage_helper s) + s -> "\n\nSubcommands:\n" ++ (usageHelper s) -- we don't want to list subcommands if we're already specifying them Just _ -> "" -get_command_help_core :: Maybe DarcsCommand -> DarcsCommand -> String -get_command_help_core msuper cmd = - "Usage: darcs "++super_name msuper++command_name cmd++ +getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> String +getCommandHelpCore msuper cmd = + "Usage: darcs "++superName msuper++commandName cmd++ " [OPTION]... " ++ unwords args_help ++ - "\n"++ command_description cmd + "\n"++ commandDescription cmd where args_help = case cmd of (DarcsCommand _ _ _ _ _ _ _ _ _ _ _) -> - command_extra_arg_help cmd + commandExtraArgHelp cmd _ -> [] data CommandArgs = CommandOnly DarcsCommand @@ -265,11 +266,11 @@ | SuperCommandSub DarcsCommand DarcsCommand -- Parses a darcs command line with potentially abbreviated commands -disambiguate_commands :: [CommandControl] -> String -> [String] +disambiguateCommands :: [CommandControl] -> String -> [String] -> Either String (CommandArgs, [String]) -disambiguate_commands allcs cmd args = +disambiguateCommands allcs cmd args = do c <- extract cmd allcs - case (get_subcommands c, args) of + case (getSubcommands c, args) of ([], _) -> return (CommandOnly c, args) (_ ,[]) -> return (SuperCommandOnly c, args) (subcs, (a:as)) -> case extract a subcs of @@ -278,17 +279,31 @@ extract :: String -> [CommandControl] -> Either String DarcsCommand extract cmd cs = - case [ c | c <- extract_commands cs, cmd `isPrefixOf` command_name c ] ++ - [ h | h <- extract_hidden_commands cs, cmd == command_name h ] of + case [ c | c <- extractCommands cs, cmd `isPrefixOf` commandName c ] ++ + [ h | h <- extractHiddenCommands cs, cmd == commandName h ] of [] -> Left $ "No such command '" ++ cmd ++ "'\n" [c] -> Right c cs' -> Left $ "Ambiguous command...\n\n" ++ "The command '"++cmd++"' could mean one of:\n" ++ - unwords (sort $ map command_name cs') + unwords (sort $ map commandName cs') --- | Output functions equivalent to (putStrLn, hPutStrLn stderr, putDocLn) -loggers :: [DarcsFlag] -> ( String -> IO () - , String -> IO () - , Doc -> IO ()) -loggers _ = (putStrLn, putStrLnError, putDocLn) +amVerbose :: [DarcsFlag] -> Bool +amVerbose = elem Verbose + +amQuiet :: [DarcsFlag] -> Bool +amQuiet = elem Quiet + +putVerbose :: [DarcsFlag] -> Doc -> IO () +putVerbose opts = when (amVerbose opts) . putDocLn + +putInfo :: [DarcsFlag] -> Doc -> IO () +putInfo opts = unless (amQuiet opts) . putDocLn + +putWarning :: [DarcsFlag] -> Doc -> IO () +putWarning opts = unless (amQuiet opts) . hPutDocLn stderr + +abortRun :: [DarcsFlag] -> Doc -> IO () +abortRun opts msg = if DryRun `elem` opts + then putInfo opts $ text "NOTE:" <+> msg + else errorDoc msg \end{code} diff --git a/src/Darcs/Commands/Add.lhs b/src/Darcs/Commands/Add.lhs --- a/src/Darcs/Commands/Add.lhs +++ b/src/Darcs/Commands/Add.lhs @@ -17,44 +17,43 @@ \darcsCommand{add} \begin{code} -module Darcs.Commands.Add ( add ) where +module Darcs.Commands.Add ( add, expandDirs ) where import Data.List ( (\\), nub) -import Darcs.Commands -import Darcs.Arguments (noskip_boring, allow_problematic_filenames, - fancy_move_add, - recursive, working_repo_dir, dry_run_noxml, umask_option, - list_files, list_unregistered_files, - DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive, - Verbose, Quiet, FancyMoveAdd, DryRun), +import Darcs.Commands(DarcsCommand(..), putVerbose, putWarning, nodefaults) +import Darcs.Arguments (noskipBoring, allowProblematicFilenames, + fancyMoveAdd, + recursive, workingRepoDir, dryRunNoxml, umaskOption, + listFiles, listUnregisteredFiles, + DarcsFlag ( Recursive, FancyMoveAdd, DryRun, Verbose), fixSubPaths, ) +import Darcs.Flags( includeBoring, doAllowCaseOnly, doAllowWindowsReserved,) import Darcs.Utils ( withCurrentDirectory, nubsort ) import IsoDate ( getIsoDateTime ) import Darcs.Repository ( amInRepository, withRepoLock, ($-), slurp_pending, add_to_pending ) -import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move ) -import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL ) +import Darcs.Patch ( Prim, applyToSlurpy, addfile, adddir, move ) +import Darcs.Witnesses.Ordered ( FL(..), unsafeFL, concatFL, nullFL ) import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has, isFileReallySymlink, doesDirectoryReallyExist, doesFileReallyExist, slurp_hasdir, ) import Darcs.Patch.FileName ( fp2fn ) -import Darcs.RepoPath ( toFilePath ) -import Control.Monad ( when, unless ) -import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter ) -import Data.Maybe ( maybeToList ) +import Darcs.RepoPath ( SubPath, toFilePath, simpleSubPath, toPath ) +import Control.Monad ( when, unless, liftM ) +import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter ) +import Data.Maybe ( maybeToList, fromJust ) import System.FilePath.Posix ( takeDirectory, () ) -import System.IO ( hPutStrLn, stderr ) import qualified System.FilePath.Windows as WindowsFilePath -import Darcs.Gorsvet( invalidateIndex ) +import Printer( text ) -add_description :: String -add_description = "Add one or more new files or directories." +addDescription :: String +addDescription = "Add one or more new files or directories." -add_help :: String -add_help = +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" ++ @@ -67,24 +66,24 @@ "Adding symbolic links (symlinks) is not supported.\n\n" add :: DarcsCommand -add = DarcsCommand {command_name = "add", - command_help = add_help ++ add_help' ++ add_help'', - command_description = add_description, - command_extra_args = -1, - command_extra_arg_help = [" ..."], - command_command = add_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_unregistered_files, - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = - [noskip_boring, allow_problematic_filenames, +add = DarcsCommand {commandName = "add", + commandHelp = addHelp ++ addHelp' ++ addHelp'', + commandDescription = addDescription, + commandExtraArgs = -1, + commandExtraArgHelp = [" ..."], + commandCommand = addCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listUnregisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = + [noskipBoring, allowProblematicFilenames, recursive "add contents of subdirectories", - fancy_move_add, - working_repo_dir, dry_run_noxml]} + fancyMoveAdd, + workingRepoDir, dryRunNoxml]} -add_help' :: String -add_help' = +addHelp' :: String +addHelp' = "Darcs will ignore all files and folders that look `boring'. The\n" ++ "--boring option overrides this behaviour.\n" ++ "\n" ++ @@ -95,28 +94,27 @@ "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++ "unusable on those systems!\n\n" -add_cmd :: [DarcsFlag] -> [String] -> IO () -add_cmd opts args = withRepoLock opts $- \repository -> +addCmd :: [DarcsFlag] -> [String] -> IO () +addCmd opts args = withRepoLock opts $- \repository -> do cur <- slurp_pending repository - origfiles <- map toFilePath `fmap` fixSubPaths opts args + origfiles <- fixSubPaths opts args when (null origfiles) $ putStrLn "Nothing specified, nothing added." >> putStrLn "Maybe you wanted to say `darcs add --recursive .'?" - parlist <- get_parents cur origfiles + parlist <- getParents cur (map toFilePath origfiles) flist' <- if Recursive `elem` opts - then expand_dirs origfiles + then expandDirs origfiles else return origfiles - let flist = nubsort (parlist ++ flist') + let flist = nubsort (parlist ++ toFilePath `map` flist') -- refuse to add boring files recursively: - nboring <- if Boring `elem` opts - then return darcsdir_filter - else boring_file_filter - let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn - mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $ + nboring <- if includeBoring opts + then return darcsdirFilter + else boringFileFilter + let fixedOpts = if DryRun `elem` opts then Verbose:opts else opts + mapM_ (putWarning fixedOpts . text . ((msg_skipping msgs ++ " boring file ")++)) $ flist \\ nboring flist date <- getIsoDateTime - invalidateIndex repository - ps <- addp msgs opts date cur $ nboring flist + ps <- addp msgs fixedOpts date cur $ nboring flist when (nullFL ps && not (null args)) $ fail "No files were added" unless gotDryRun $ add_to_pending repository ps @@ -164,8 +162,8 @@ msg_are msgs ++ " already in the repository" else return $ "The following files " ++ msg_are msgs ++ " already in the repository") - putInfo $ dupMsg ++ caseMsg - mapM_ putInfo uniq_dups + putWarning opts . text $ dupMsg ++ caseMsg + mapM_ (putWarning opts . text) uniq_dups return $ concatFL $ unsafeFL ps where addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath) @@ -174,7 +172,8 @@ then return (cur, Nothing, Just f) else if is_badfilename - then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it." + then do putWarning opts . text $ + "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it." return add_failure else do isdir <- doesDirectoryReallyExist f @@ -185,8 +184,9 @@ then trypatch $ myaddfile f else do islink <- isFileReallySymlink f if islink then - putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs." - else putInfo $ "File "++ f ++" does not exist!" + putWarning opts . text $ + "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs." + else putWarning opts . text $ "File "++ f ++" does not exist!" return add_failure where already_has = if gotAllowCaseOnly then slurp_has f cur @@ -194,10 +194,10 @@ is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f) add_failure = (cur, Nothing, Nothing) trypatch p = - case apply_to_slurpy p cur of - Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error + case applyToSlurpy p cur of + Nothing -> do putWarning opts . text $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error return (cur, Nothing, Nothing) - Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'" + Just s' -> do putVerbose opts . text $ msg_adding msgs++" '"++f++"'" return (s', Just p, Nothing) parentdir = takeDirectory f have_parentdir = slurp_hasdir (fp2fn parentdir) cur @@ -213,13 +213,9 @@ then addfile (d++"-"++date) :>: move (d++"-"++date) d :>: NilFL else addfile d :>: NilFL - putVerbose = if Verbose `elem` opts || DryRun `elem` opts - then putStrLn - else \_ -> return () - putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr gotFancyMoveAdd = FancyMoveAdd `elem` opts - gotAllowCaseOnly = AllowCaseOnly `elem` opts - gotAllowWindowsReserved = AllowWindowsReserved `elem` opts + gotAllowCaseOnly = doAllowCaseOnly opts + gotAllowWindowsReserved = doAllowWindowsReserved opts data AddMessages = AddMessages @@ -247,31 +243,32 @@ -- |FIXME: this documentation makes *no* sense to me, and the -- ramifications of using this option are not clear. --twb, 2008 -add_help'' :: String -add_help'' = +addHelp'' :: String +addHelp'' = "The --date-trick option allows you to enable an experimental trick to\n" ++ "make add conflicts, in which two users each add a file or directory\n" ++ "with the same name, less problematic. While this trick is completely\n" ++ "safe, it is not clear to what extent it is beneficial.\n" -expand_dirs :: [FilePath] -> IO [FilePath] -expand_dirs fs = concat `fmap` mapM expand_one fs -expand_one :: FilePath -> IO [FilePath] -expand_one "" = list_files -expand_one f = do +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 list_files + else do fs <- withCurrentDirectory f listFiles return $ f: map (f ) fs -get_parents :: Slurpy -> [FilePath] -> IO [FilePath] -get_parents cur fs = - concat `fmap` mapM (get_parent cur) fs -get_parent :: Slurpy -> FilePath -> IO [FilePath] -get_parent cur f = +getParents :: Slurpy -> [FilePath] -> IO [FilePath] +getParents cur fs = + concat `fmap` mapM (getParent cur) fs +getParent :: Slurpy -> FilePath -> IO [FilePath] +getParent cur f = if slurp_hasdir (fp2fn parentdir) cur then return [] - else do grandparents <- get_parent cur parentdir + else do grandparents <- getParent cur parentdir return (grandparents ++ [parentdir]) where parentdir = takeDirectory f \end{code} diff --git a/src/Darcs/Commands/AmendRecord.lhs b/src/Darcs/Commands/AmendRecord.lhs --- a/src/Darcs/Commands/AmendRecord.lhs +++ b/src/Darcs/Commands/AmendRecord.lhs @@ -20,52 +20,52 @@ module Darcs.Commands.AmendRecord ( amendrecord ) where import Data.List ( sort ) import Data.Maybe ( isJust ) +import System.Directory ( removeFile ) import System.Exit ( ExitCode(..), exitWith ) import Control.Monad ( when ) import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, EditLongComment, PromptLongComment) ) import Darcs.Lock ( world_readable_temp ) -import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.RepoPath ( toFilePath ) import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info ) -import Darcs.Repository ( withRepoLock, ($-), withGutsOf, - get_unrecorded_in_files, get_unrecorded_in_files_unsorted, +import Darcs.Repository ( Repository, withRepoLock, ($-), withGutsOf, tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges, - sync_repo, amInRepository, + amInRepository + , invalidateIndex, unrecordedChanges ) import Darcs.Patch ( RepoPatch, description, Prim, fromPrims, infopatch, getdeps, adddeps, effect, - sort_coalesceFL, - canonize ) + ) +import Darcs.Patch.Prim ( canonizeFL ) import Darcs.Patch.Info ( pi_author, pi_name, pi_log, PatchInfo, patchinfo, is_inverted, invert_name, ) -import Darcs.Ordered ( FL(..), (:>)(..), (+>+), - nullFL, mapFL_FL, concatFL ) +import Darcs.Patch.Split ( primSplitter ) +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL ) import Darcs.SelectChanges ( with_selected_changes_to_files', with_selected_patch_from_repo ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Commands.Record ( get_date, get_log ) +import Darcs.Commands.Record ( getDate, getLog ) import Darcs.Arguments ( DarcsFlag ( All ), areFileArgs, fixSubPaths, defineChanges, - all_interactive, ignoretimes, - ask_long_comment, author, patchname_option, - leave_test_dir, nocompress, lookforadds, - working_repo_dir, - match_one_nontag, umask_option, - notest, testByDefault, list_registered_files, - get_easy_author, set_scripts_executable + allInteractive, ignoretimes, + askLongComment, author, patchnameOption, + leaveTestDir, nocompress, lookforadds, + workingRepoDir, + matchOneNontag, umaskOption, + notest, testByDefault, listRegisteredFiles, + getEasyAuthor, setScriptsExecutableOption ) -import Darcs.Utils ( askUser ) +import Darcs.Utils ( askUser, clarifyErrors ) import Printer ( putDocLn ) -import Darcs.Gorsvet( invalidateIndex ) -amendrecord_description :: String -amendrecord_description = +amendrecordDescription :: String +amendrecordDescription = "Improve a patch before it leaves your repository." -amendrecord_help :: String -amendrecord_help = +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" ++ @@ -100,96 +100,107 @@ "On Windows use C:/Documents And Settings/user/Application Data/darcs/defaults\n" amendrecord :: DarcsCommand -amendrecord = DarcsCommand {command_name = "amend-record", - command_help = amendrecord_help, - command_description = amendrecord_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_command = amendrecord_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [nocompress, ignoretimes, umask_option, - set_scripts_executable], - command_basic_options = [match_one_nontag, +amendrecord = DarcsCommand {commandName = "amend-record", + commandHelp = amendrecordHelp, + commandDescription = amendrecordDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = amendrecordCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [nocompress, ignoretimes, umaskOption, + setScriptsExecutableOption], + commandBasicOptions = [matchOneNontag, notest, - leave_test_dir, - all_interactive, - author, patchname_option, ask_long_comment, + leaveTestDir, + allInteractive, + author, patchnameOption, askLongComment, lookforadds, - working_repo_dir]} + workingRepoDir]} -amendrecord_cmd :: [DarcsFlag] -> [String] -> IO () -amendrecord_cmd opts args = - let edit_metadata = has_edit_metadata opts in +amendrecordCmd :: [DarcsFlag] -> [String] -> IO () +amendrecordCmd opts args = withRepoLock (testByDefault opts) $- \repository -> do files <- sort `fmap` fixSubPaths opts args when (areFileArgs files) $ putStrLn $ "Amending changes in "++unwords (map show files)++":\n" with_selected_patch_from_repo "amend" repository opts $ \ (_ :> oldp) -> do - ch <- if All `elem` opts - then get_unrecorded_in_files_unsorted repository (map sp2fn files) - else get_unrecorded_in_files repository (map sp2fn files) + ch <- unrecordedChanges opts repository files case ch of - NilFL | not edit_metadata -> putStrLn "No changes!" - _ -> do - date <- get_date opts - with_selected_changes_to_files' "add" (filter (==All) opts) - (map toFilePath files) ch $ \ (chs:>_) -> - if (nullFL chs && not edit_metadata) + NilFL | not (hasEditMetadata opts) -> putStrLn "No changes!" + _ -> + with_selected_changes_to_files' "add" (filter (==All) opts) (Just primSplitter) + (map toFilePath files) ch $ addChangesToPatch opts repository oldp + +addChangesToPatch :: forall t p . (RepoPatch p) => [DarcsFlag] -> Repository p -> PatchInfoAnd p + -> (FL Prim :> t) -> IO () +addChangesToPatch opts repository oldp (chs:>_) = + if (nullFL chs && not (hasEditMetadata opts)) then putStrLn "You don't want to record anything!" else do + (mlogf, newp) <- updatePatchHeader opts oldp chs + defineChanges newp + invalidateIndex repository + withGutsOf repository $ do + tentativelyRemovePatches repository opts (hopefully oldp :>: NilFL) + tentativelyAddPatch repository opts newp + let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf + finalizeRepositoryChanges repository `clarifyErrors` failmsg + maybe (return ()) removeFile mlogf + putStrLn "Finished amending patch:" + putDocLn $ description newp + +updatePatchHeader :: forall p. (RepoPatch p) => [DarcsFlag] -> PatchInfoAnd p -> FL Prim + -> IO (Maybe String, PatchInfoAnd p) +updatePatchHeader opts oldp chs = do let old_pinf = info oldp prior = (pi_name old_pinf, pi_log old_pinf) make_log = world_readable_temp "darcs-amend-record" old_author = pi_author old_pinf - author_here <- get_easy_author - case author_here of - Nothing -> return () - Just ah -> let edit_author = isJust (get_author opts) - in if (edit_author || ah == old_author) - then return () - else do yorn <- askUser $ "You're not "++old_author - ++"! Amend anyway? " - case yorn of ('y':_) -> return () - _ -> exitWith $ ExitSuccess - (new_name, new_log, _) <- get_log opts (Just prior) make_log chs - let new_author = case get_author opts of + date <- 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 -> pi_author old_pinf maybe_invert = if is_inverted old_pinf then invert_name else id new_pinf <- maybe_invert `fmap` patchinfo date new_name new_author new_log - let newp = fixp oldp chs new_pinf - defineChanges newp - invalidateIndex repository - withGutsOf repository $ do - tentativelyRemovePatches repository opts (hopefully oldp :>: NilFL) - tentativelyAddPatch repository opts newp - finalizeRepositoryChanges repository - sync_repo repository - putStrLn "Finished amending patch:" - putDocLn $ description newp + return $ (mlogf, fixp oldp chs new_pinf) -has_edit_metadata :: [DarcsFlag] -> Bool -has_edit_metadata (Author _:_) = True -has_edit_metadata (LogFile _:_) = True -has_edit_metadata (PatchName _:_) = True -has_edit_metadata (EditLongComment:_) = True -has_edit_metadata (PromptLongComment:_) = True -has_edit_metadata (_:fs) = has_edit_metadata fs -has_edit_metadata [] = False +warnIfHijacking :: [DarcsFlag] -> String -> IO () +warnIfHijacking opts old_author = do + author_here <- getEasyAuthor + case author_here of + Nothing -> return () + Just ah -> let edit_author = isJust (getAuthor opts) + in if (edit_author || ah == old_author) + then return () + else do yorn <- askUser $ + "You're not "++old_author ++"! Amend anyway? " + case yorn of ('y':_) -> return () + _ -> exitWith $ ExitSuccess -get_author :: [DarcsFlag] -> Maybe String -get_author (Author a:_) = Just a -get_author (_:as) = get_author as -get_author [] = Nothing +hasEditMetadata :: [DarcsFlag] -> Bool +hasEditMetadata (Author _:_) = True +hasEditMetadata (LogFile _:_) = True +hasEditMetadata (PatchName _:_) = True +hasEditMetadata (EditLongComment:_) = True +hasEditMetadata (PromptLongComment:_) = True +hasEditMetadata (_:fs) = hasEditMetadata fs +hasEditMetadata [] = False +getAuthor :: [DarcsFlag] -> Maybe String +getAuthor (Author a:_) = Just a +getAuthor (_:as) = getAuthor as +getAuthor [] = Nothing + fixp :: RepoPatch p => PatchInfoAnd p -> FL Prim -> PatchInfo -> PatchInfoAnd p fixp oldp chs new_pinf = let pdeps = getdeps $ hopefully oldp oldchs = effect oldp infodepspatch pinfo deps p = adddeps (infopatch pinfo p) deps - in n2pia $ infodepspatch new_pinf pdeps $ fromPrims $ concatFL $ mapFL_FL canonize - $ sort_coalesceFL $ concatFL $ mapFL_FL canonize $ oldchs +>+ chs + in n2pia $ infodepspatch new_pinf pdeps $ fromPrims $ canonizeFL + $ oldchs +>+ chs \end{code} diff --git a/src/Darcs/Commands/Annotate.lhs b/src/Darcs/Commands/Annotate.lhs --- a/src/Darcs/Commands/Annotate.lhs +++ b/src/Darcs/Commands/Annotate.lhs @@ -22,25 +22,26 @@ #include "gadts.h" -module Darcs.Commands.Annotate ( annotate, created_as_xml ) where +module Darcs.Commands.Annotate ( annotate, createdAsXml ) where import Control.Monad ( when ) import Data.List ( sort ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, - summary, unified, human_readable, +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, + summary, unified, humanReadable, xmloutput, creatorhash, fixSubPaths, - list_registered_files, - match_one, + listRegisteredFiles, + matchOne, ) -import Darcs.SlurpDirectory ( slurp ) +import Darcs.Flags ( isUnified ) +import Storage.Hashed.Plain( readPlainTree ) import Darcs.Repository ( Repository, PatchSet, amInRepository, withRepository, ($-), read_repo, getMarkedupFile ) -import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xml_summary ) +import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xmlSummary ) import qualified Darcs.Patch ( summary ) -import Darcs.Ordered ( mapRL, concatRL ) +import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import qualified Data.ByteString.Char8 as BC ( unpack, ByteString ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch ) import Darcs.Patch.Info ( PatchInfo, human_friendly, to_xml, make_filename, @@ -54,70 +55,66 @@ ) import Darcs.Hopefully ( info ) import Darcs.RepoPath ( SubPath, toFilePath ) -import Darcs.Match ( match_patch, have_nonrange_match, get_first_match ) +import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch ) import Darcs.Lock ( withTempDir ) -import Darcs.Sealed ( Sealed2(..), unseal2 ) +import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 ) import Printer ( putDocLn, text, errorDoc, ($$), prefix, (<+>), Doc, empty, vcat, (<>), renderString, packedString ) #include "impossible.h" -annotate_description :: String -annotate_description = "Display which patch last modified something." +annotateDescription :: String +annotateDescription = "Display which patch last modified something." -annotate_help :: String -annotate_help = - "Annotate displays which patches created or last modified a directory\n"++ - "file or line. It can also display the contents of a particular patch\n"++ - "in darcs format.\n" +annotateHelp :: String +annotateHelp = + "The `darcs annotate' command provides two unrelated operations. When\n" ++ + "called on a file, it will find the patch that last modified each line\n" ++ + "in that file. When called on a patch (e.g. using --patch), it will\n" ++ + "print the internal representation of that patch.\n" ++ + "\n" ++ + "The --summary option will result in a summarized patch annotation,\n" ++ + "similar to `darcs whatsnew'. It has no effect on file annotations.\n" ++ + "\n" ++ + "By default, output is in a human-readable format. The --xml-output\n" ++ + "option can be used to generate output for machine postprocessing.\n" annotate :: DarcsCommand -annotate = DarcsCommand {command_name = "annotate", - command_help = annotate_help, - command_description = annotate_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_command = annotate_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [summary,unified, - human_readable, +annotate = DarcsCommand {commandName = "annotate", + commandHelp = annotateHelp, + commandDescription = annotateDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = annotateCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [summary,unified, + humanReadable, xmloutput, - match_one, creatorhash, - working_repo_dir]} -\end{code} - -\begin{options} ---human-readable, --summary, --unified, --xml--output -\end{options} - -When called with just a patch name, annotate outputs the patch in darcs format, -which is the same as \verb!--human-readable!. - -\verb!--xml-output! is the alternative to \verb!--human-readable!. - -\verb!--summary! can be used with either the \verb!--xml-output! or the -\verb!--human-readable! options to alter the results. It is documented -fully in the `common options' portion of the manual. + matchOne, creatorhash, + workingRepoDir]} +\end{code} +%% FIXME: AFAICT -u does nothing. Remove it from anno's options? +%% --twb, 2009-09-20 Giving the \verb!--unified! flag implies \verb!--human-readable!, and causes the output to remain in a darcs-specific format that is similar to that produced by \verb!diff --unified!. \begin{code} -annotate_cmd :: [DarcsFlag] -> [String] -> IO () -annotate_cmd opts [] = withRepository opts $- \repository -> do - when (not $ have_nonrange_match opts) $ +annotateCmd :: [DarcsFlag] -> [String] -> IO () +annotateCmd opts [] = withRepository opts $- \repository -> do + when (not $ haveNonrangeMatch opts) $ fail $ "Annotate requires either a patch pattern or a " ++ "file or directory argument." - Sealed2 p <- match_patch opts `fmap` read_repo repository + Sealed2 p <- matchPatch opts `fmap` read_repo repository if Summary `elem` opts then do putDocLn $ showpi $ patch2patchinfo p putDocLn $ show_summary p - else if Unified `elem` opts + else if isUnified opts then withTempDir "context" $ \_ -> - do get_first_match repository opts - c <- slurp "." + do getFirstMatch repository opts + c <- readPlainTree "." contextualPrintPatch c p else printPatch p where showpi | MachineReadable `elem` opts = showPatchInfo @@ -125,7 +122,7 @@ | otherwise = human_friendly show_summary :: RepoPatch p => Named p C(x y) -> Doc show_summary = if XMLOutput `elem` opts - then xml_summary + then xmlSummary else Darcs.Patch.summary \end{code} @@ -143,25 +140,25 @@ that patch was applied. If a directory and a tag name are given, the details of the patches involved in the specified tagged version will be output. \begin{code} -annotate_cmd opts args@[_] = withRepository opts $- \repository -> do +annotateCmd opts args@[_] = withRepository opts $- \repository -> do r <- read_repo repository (rel_file_or_directory:_) <- fixSubPaths opts args let file_or_directory = rel_file_or_directory - pinfo <- if have_nonrange_match opts - then return $ patch2patchinfo `unseal2` (match_patch opts r) + pinfo <- if haveNonrangeMatch opts + then return $ patch2patchinfo `unseal2` (matchPatch opts r) else case mapRL info $ concatRL r of [] -> fail "Annotate does not currently work correctly on empty repositories." (x:_) -> return x pop <- getRepoPopVersion "." pinfo -- deal with --creator-hash option - let maybe_creation_pi = find_creation_patchinfo opts r + let maybe_creation_pi = findCreationPatchinfo opts r lookup_thing = case maybe_creation_pi of Nothing -> lookup_pop Just cp -> lookup_creation_pop cp if toFilePath file_or_directory == "" - then case pop of (Pop _ pt) -> annotate_pop opts pinfo pt + then case pop of (Pop _ pt) -> annotatePop opts pinfo pt else case lookup_thing (toFilePath file_or_directory) pop of Nothing -> fail $ "There is no file or directory named '"++ toFilePath file_or_directory++"'" @@ -170,18 +167,18 @@ errorDoc $ text ("The directory '" ++ toFilePath rel_file_or_directory ++ "' was removed by") $$ human_friendly (modifiedByI i) - | otherwise -> annotate_pop opts pinfo pt + | otherwise -> annotatePop opts pinfo pt Just (Pop _ pt@(PopFile i)) | modifiedHowI i == RemovedFile && modifiedByI i /= pinfo -> errorDoc $ text ("The file '" ++ toFilePath rel_file_or_directory ++ "' was removed by") $$ human_friendly (modifiedByI i) - | otherwise -> annotate_file repository opts pinfo file_or_directory pt + | otherwise -> annotateFile repository opts pinfo file_or_directory pt -annotate_cmd _ _ = fail "annotate accepts at most one argument" +annotateCmd _ _ = fail "annotate accepts at most one argument" -annotate_pop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO () -annotate_pop opts pinfo pt = putDocLn $ p2format pinfo pt +annotatePop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO () +annotatePop opts pinfo pt = putDocLn $ p2format pinfo pt where p2format = if XMLOutput `elem` opts then p2xml else p2s @@ -234,8 +231,8 @@ | x == z = y ++ (strReplace x y zs) | otherwise = z : (strReplace x y zs) -created_as_xml :: PatchInfo -> String -> Doc -created_as_xml pinfo as = text " escapeXML as <> text "'>" $$ to_xml pinfo @@ -243,37 +240,37 @@ --removed_by_xml :: PatchInfo -> String --removed_by_xml pinfo = "\n"++to_xml pinfo++"\n" -p2xml_open :: PatchInfo -> PopTree -> Doc -p2xml_open _ (PopFile inf) = +p2xmlOpen :: PatchInfo -> PopTree -> Doc +p2xmlOpen _ (PopFile inf) = text "" $$ created $$ modified where f = BC.unpack $ nameI inf created = case createdByI inf of Nothing -> empty - Just ci -> created_as_xml ci + Just ci -> createdAsXml ci (BC.unpack $ fromJust $ creationNameI inf) modified = modified_to_xml inf -p2xml_open _ (PopDir inf _) = +p2xmlOpen _ (PopDir inf _) = text "" $$ created $$ modified where f = BC.unpack $ nameI inf created = case createdByI inf of Nothing -> empty - Just ci -> created_as_xml ci + Just ci -> createdAsXml ci (BC.unpack $ fromJust $ creationNameI inf) modified = modified_to_xml inf -p2xml_close :: PatchInfo -> PopTree -> Doc -p2xml_close _(PopFile _) = text "" -p2xml_close _ (PopDir _ _) = text "" +p2xmlClose :: PatchInfo -> PopTree -> Doc +p2xmlClose _(PopFile _) = text "" +p2xmlClose _ (PopDir _ _) = text "" p2xml :: PatchInfo -> PopTree -> Doc -p2xml pinf p@(PopFile _) = p2xml_open pinf p $$ p2xml_close pinf p -p2xml pinf p@(PopDir _ pops) = p2xml_open pinf p +p2xml pinf p@(PopFile _) = p2xmlOpen pinf p $$ p2xmlClose pinf p +p2xml pinf p@(PopDir _ pops) = p2xmlOpen pinf p $$ vcat (map (p2xml pinf) $ sort pops) - $$ p2xml_close pinf p + $$ p2xmlClose pinf p \end{code} If a file name is given, the last modifying patch details of that file will be output, along @@ -283,40 +280,40 @@ that patch was applied. \begin{code} -annotate_file :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree -> IO () -annotate_file repository opts pinfo f (PopFile inf) = do +annotateFile :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree -> IO () +annotateFile repository opts pinfo f (PopFile inf) = do if XMLOutput `elem` opts - then putDocLn $ p2xml_open pinfo (PopFile inf) + then putDocLn $ p2xmlOpen pinfo (PopFile inf) else if createdByI inf /= Nothing then putAnn $ text ("File "++toFilePath f++" created by ") <> showPatchInfo ci <> text (" as " ++ createdname) else putAnn $ text $ "File "++toFilePath f mk <- getMarkedupFile repository ci createdname old_pis <- (dropWhile (/= pinfo).mapRL info.concatRL) `fmap` read_repo repository - mapM_ (annotate_markedup opts pinfo old_pis) mk - when (XMLOutput `elem` opts) $ putDocLn $ p2xml_close pinfo (PopFile inf) + mapM_ (annotateMarkedup opts pinfo old_pis) mk + when (XMLOutput `elem` opts) $ putDocLn $ p2xmlClose pinfo (PopFile inf) where ci = fromJust $ createdByI inf createdname = BC.unpack $ fromJust $ creationNameI inf -annotate_file _ _ _ _ _ = impossible +annotateFile _ _ _ _ _ = impossible -annotate_markedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo] +annotateMarkedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () -annotate_markedup opts | XMLOutput `elem` opts = xml_markedup - | otherwise = text_markedup +annotateMarkedup opts | XMLOutput `elem` opts = xmlMarkedup + | otherwise = textMarkedup -text_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () -text_markedup _ _ (l,None) = putLine ' ' l -text_markedup pinfo old_pis (l,RemovedLine wheni) +textMarkedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () +textMarkedup _ _ (l,None) = putLine ' ' l +textMarkedup pinfo old_pis (l,RemovedLine wheni) | wheni == pinfo = putLine '-' l | wheni `elem` old_pis = return () | otherwise = putLine ' ' l -text_markedup pinfo old_pis (l,AddedLine wheni) +textMarkedup pinfo old_pis (l,AddedLine wheni) | wheni == pinfo = putLine '+' l | wheni `elem` old_pis = do putAnn $ text "Following line added by " <> showPatchInfo wheni putLine ' ' l | otherwise = return () -text_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem) +textMarkedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem) | whenadd == pinfo = do putAnn $ text "Following line removed by " <> showPatchInfo whenrem putLine '+' l @@ -334,9 +331,9 @@ putAnn :: Doc -> IO () putAnn s = putDocLn $ prefix "# " s -xml_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () -xml_markedup _ _ (l,None) = putLine ' ' l -xml_markedup pinfo old_pis (l,RemovedLine wheni) +xmlMarkedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () +xmlMarkedup _ _ (l,None) = putLine ' ' l +xmlMarkedup pinfo old_pis (l,RemovedLine wheni) | wheni == pinfo = putDocLn $ text "" $$ escapeXML (BC.unpack l) $$ text "" @@ -347,7 +344,7 @@ $$ text "" $$ escapeXML (BC.unpack l) $$ text "" -xml_markedup pinfo old_pis (l,AddedLine wheni) +xmlMarkedup pinfo old_pis (l,AddedLine wheni) | wheni == pinfo = putDocLn $ text "" $$ escapeXML (BC.unpack l) $$ text "" @@ -358,7 +355,7 @@ $$ escapeXML (BC.unpack l) $$ text "" | otherwise = return () -xml_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem) +xmlMarkedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem) | whenadd == pinfo = putDocLn $ text "" $$ text "" @@ -398,14 +395,14 @@ examine a file even if it has been renamed multiple times. \begin{code} -find_creation_patchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo -find_creation_patchinfo [] _ = Nothing -find_creation_patchinfo (CreatorHash h:_) r = find_hash h $ mapRL info $ concatRL r -find_creation_patchinfo (_:fs) r = find_creation_patchinfo fs r +findCreationPatchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo +findCreationPatchinfo [] _ = Nothing +findCreationPatchinfo (CreatorHash h:_) r = findHash h $ mapRL info $ concatRL r +findCreationPatchinfo (_:fs) r = findCreationPatchinfo fs r -find_hash :: String -> [PatchInfo] -> Maybe PatchInfo -find_hash _ [] = Nothing -find_hash h (pinf:pinfs) +findHash :: String -> [PatchInfo] -> Maybe PatchInfo +findHash _ [] = Nothing +findHash h (pinf:pinfs) | take (length h) (make_filename pinf) == h = Just pinf - | otherwise = find_hash h pinfs + | otherwise = findHash h pinfs \end{code} diff --git a/src/Darcs/Commands/Apply.lhs b/src/Darcs/Commands/Apply.lhs --- a/src/Darcs/Commands/Apply.lhs +++ b/src/Darcs/Commands/Apply.lhs @@ -27,38 +27,37 @@ import Control.Exception ( catch, throw, Exception( ExitException ) ) import Control.Monad ( when ) -import Darcs.Hopefully ( n2pia, conscientiously, info ) +import Darcs.Hopefully ( PatchInfoAnd, n2pia, conscientiously, info ) import Darcs.SignalHandler ( withSignalsBlocked ) -import Darcs.Commands ( DarcsCommand(..) ) +import Darcs.Commands ( DarcsCommand(..), putVerbose ) import Darcs.CommandsAux ( check_paths ) -import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All, - Verbose, HappyForwarding ), +import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All ), definePatches, - get_cc, working_repo_dir, - notest, nocompress, apply_conflict_options, - use_external_merge, - ignoretimes, get_sendmail_cmd, - reply, verify, list_files, - fixFilePathOrStd, umask_option, - all_interactive, sendmail_cmd, - leave_test_dir, happy_forwarding, - dry_run, print_dry_run_message_and_exit, - set_scripts_executable, restrict_paths + getCc, workingRepoDir, + notest, nocompress, applyConflictOptions, + useExternalMerge, + ignoretimes, getSendmailCmd, + reply, verify, listFiles, + fixFilePathOrStd, umaskOption, + allInteractive, sendmailCmd, + leaveTestDir, happyForwarding, + dryRun, printDryRunMessageAndExit, + setScriptsExecutableOption, restrictPaths ) -import qualified Darcs.Arguments as DarcsArguments ( cc ) +import Darcs.Flags(doHappyForwarding) + +import qualified Darcs.Arguments as DarcsArguments ( ccApply ) import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd ) -import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository, +import Darcs.Repository ( Repository, SealedPatchSet, withRepoLock, ($-), amInRepository, tentativelyMergePatches, - sync_repo, read_repo, + read_repo, finalizeRepositoryChanges, - applyToWorking, + applyToWorking, invalidateIndex ) import Darcs.Patch ( RepoPatch, description ) -import Darcs.Patch.Info ( human_friendly ) -import Darcs.Ordered ( (:\/:)(..), (:>)(..), unsafeUnRL, - mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL ) -import Darcs.SlurpDirectory ( wait_a_moment ) - +import Darcs.Patch.Info ( PatchInfo, human_friendly ) +import Darcs.Witnesses.Ordered ( FL, RL, (:\/:)(..), (:>)(..), + mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL ) import ByteStringUtils ( linesPS, unlinesPS ) import qualified Data.ByteString as B (ByteString, null, readFile, hGetContents, init, take, drop) import qualified Data.ByteString.Char8 as BC (unpack, last, pack) @@ -68,60 +67,86 @@ import Darcs.Email ( read_email ) import Darcs.Lock ( withStdoutTemp, readBinFile ) import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing ) -import Darcs.SelectChanges ( with_selected_changes ) +import Darcs.SelectChanges ( with_selected_changes, filterOutConflicts ) import Darcs.Patch.Bundle ( scan_bundle ) -import Darcs.Sealed ( Sealed(Sealed) ) -import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty ) -import Darcs.Gorsvet( invalidateIndex ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) +import Printer ( packedString, vcat, text, ($$), errorDoc, empty ) + #include "impossible.h" -apply_description :: String -apply_description = "Apply a patch bundle created by `darcs send'." +#include "gadts.h" -apply_help :: String -apply_help = - "Apply is used to apply a bundle of patches to this repository.\n"++ - "Such a bundle may be created using send.\n" +applyDescription :: String +applyDescription = "Apply a patch bundle created by `darcs send'." +applyHelp :: String +applyHelp = + "The `darcs apply' command takes a patch bundle and attempts to insert\n" ++ + "it into the current repository. In addition to invoking it directly\n" ++ + "on bundles created by `darcs send', it is used internally by `darcs\n" ++ + "push' and `darcs put' on the remote end of an SSH connection.\n" ++ + "\n" ++ + "If no file is supplied, the bundle is read from standard input.\n" ++ + "\n" ++ + "If given an email instead of a patch bundle, Darcs will look for the\n" ++ + "bundle as a MIME attachment to that email. Currently this will fail\n" ++ + "if the MIME boundary is rewritten, such as in Courier and Mail.app.\n" ++ + "\n" ++ + "If the `--reply noreply@example.net' option is used, and the bundle is\n" ++ + "attached to an email, Darcs will send a report (indicating success or\n" ++ + "failure) to the sender of the bundle (the To field). The argument to\n" ++ + "noreply is the address the report will appear to originate FROM.\n" ++ + "\n" ++ + "The --cc option will cause the report to be CC'd to another address,\n" ++ + "for example `--cc reports@lists.example.net,admin@lists.example.net'.\n" ++ + "Using --cc without --reply is undefined.\n" ++ + "\n" ++ + "If gpg(1) is installed, you can use `--verify pubring.gpg' to reject\n" ++ + "bundles that aren't signed by a key in pubring.gpg.\n" ++ + "\n" ++ + "If --test is supplied and a test is defined (see `darcs setpref'), the\n" ++ + "bundle will be rejected if the test fails after applying it. In that\n" ++ + "case, the rejection email from --reply will include the test output.\n" + stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x apply :: DarcsCommand -apply = DarcsCommand {command_name = "apply", - command_help = apply_help, - command_description = apply_description, - command_extra_args = 1, - command_extra_arg_help = [""], - command_command = apply_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_files, - command_argdefaults = const stdindefault, - command_advanced_options = [reply, DarcsArguments.cc, - happy_forwarding, - sendmail_cmd, +apply = DarcsCommand {commandName = "apply", + commandHelp = applyHelp ++ "\n" ++ applyHelp', + commandDescription = applyDescription, + commandExtraArgs = 1, + commandExtraArgHelp = [""], + commandCommand = applyCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listFiles, + commandArgdefaults = const stdindefault, + commandAdvancedOptions = [reply, DarcsArguments.ccApply, + happyForwarding, + sendmailCmd, ignoretimes, nocompress, - set_scripts_executable, umask_option, - restrict_paths], - command_basic_options = [verify, - all_interactive]++dry_run++ - [apply_conflict_options, - use_external_merge, + setScriptsExecutableOption, umaskOption, + restrictPaths], + commandBasicOptions = [verify, + allInteractive]++dryRun++ + [applyConflictOptions, + useExternalMerge, notest, - leave_test_dir, - working_repo_dir]} + leaveTestDir, + workingRepoDir]} -apply_cmd :: [DarcsFlag] -> [String] -> IO () -apply_cmd _ [""] = fail "Empty filename argument given to apply!" -apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do +applyCmd :: [DarcsFlag] -> [String] -> IO () +applyCmd _ [""] = fail "Empty filename argument given to apply!" +applyCmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do patchesfile <- fixFilePathOrStd opts unfixed_patchesfile ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile - am_verbose <- return $ Verbose `elem` opts - let from_whom = get_from ps + let from_whom = getFrom ps us <- read_repo repository - either_them <- get_patch_bundle opts ps - them <- case either_them of - Right (Sealed t) -> return t - Left er -> do forwarded <- consider_forwarding opts ps + either_them <- getPatchBundle opts ps + Sealed them + <- case either_them of + Right t -> return t + Left er -> do forwarded <- considerForwarding opts ps if forwarded then exitWith ExitSuccess else fail er @@ -131,47 +156,57 @@ then cannotApplyPartialRepo pinfo "" else cannotApplyMissing pinfo Right x -> return x - when (null $ unsafeUnRL $ head $ unsafeUnRL them') $ + let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch " + ++"bundle, since we're missing:") $$)) + $ reverseRL them' + (hadConflicts, Sealed their_ps_filtered) <- filterOutConflicts opts us' repository their_ps + when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts." + when (nullFL their_ps_filtered) $ do putStr $ "All these patches have already been applied. " ++ "Nothing to do.\n" exitWith ExitSuccess - let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch " - ++"bundle, since we're missing:") $$)) - $ reverseRL $ head $ unsafeUnRL them' - with_selected_changes "apply" fixed_opts their_ps $ - \ (to_be_applied:>_) -> do - print_dry_run_message_and_exit "apply" opts to_be_applied + with_selected_changes "apply" fixed_opts Nothing their_ps_filtered $ + \ (to_be_applied:>_) -> + applyItNow opts from_whom repository us' to_be_applied + where fixed_opts = if Interactive `elem` opts + then opts + else All : opts +applyCmd _ _ = impossible + +applyItNow :: FORALL(p r u t x y z) RepoPatch p => + [DarcsFlag] -> String -> Repository p C(r u t) + -> RL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x z) -> IO () +applyItNow opts from_whom repository us' to_be_applied = do + printDryRunMessageAndExit "apply" opts to_be_applied when (nullFL to_be_applied) $ do putStrLn "You don't want to apply any patches, so I'm exiting!" exitWith ExitSuccess check_paths opts to_be_applied - redirect_output opts from_whom $ do - when am_verbose $ putStrLn "We have the following extra patches:" - when am_verbose $ putDocLn $ vcat $ mapRL description $ head $ unsafeUnRL us' - when am_verbose $ putStrLn "Will apply the following patches:" - when am_verbose $ putDocLn $ vcat $ mapFL description to_be_applied + redirectOutput opts from_whom $ do + putVerbose opts $ text "We have the following extra patches:" + putVerbose opts . vcat $ mapRL description us' + putVerbose opts $ text "Will apply the following patches:" + putVerbose opts . vcat $ mapFL description to_be_applied definePatches to_be_applied Sealed pw <- tentativelyMergePatches repository "apply" opts - (reverseRL $ head $ unsafeUnRL us') to_be_applied + (reverseRL us') to_be_applied invalidateIndex repository withSignalsBlocked $ do finalizeRepositoryChanges repository - wait_a_moment -- so work will be more recent than rec applyToWorking repository opts pw `catch` \e -> fail ("Error applying patch to working dir:\n" ++ show e) - sync_repo repository putStrLn "Finished applying..." - where fixed_opts = if Interactive `elem` opts - then opts - else All : opts - cannotApplyMissing pinfo - = errorDoc $ text "Cannot apply this patch bundle, since we're missing:" - $$ human_friendly pinfo - cannotApplyPartialRepo pinfo e - = errorDoc $ text ("Cannot apply this patch bundle, " - ++ "this is a \"--partial repository") - $$ text "We don't have the following patch:" - $$ human_friendly pinfo $$ text e -apply_cmd _ _ = impossible + +cannotApplyMissing :: PatchInfo -> a +cannotApplyMissing pinfo + = errorDoc $ text "Cannot apply this patch bundle, since we're missing:" + $$ human_friendly pinfo + +cannotApplyPartialRepo :: PatchInfo -> String -> a +cannotApplyPartialRepo pinfo e + = errorDoc $ text ("Cannot apply this patch bundle, " + ++ "this is a \"--partial repository") + $$ text "We don't have the following patch:" + $$ human_friendly pinfo $$ text e \end{code} Darcs apply accepts a single argument, which is the name of the patch @@ -184,14 +219,11 @@ --verify \end{options} -If you specify the \verb!--verify PUBRING! option, darcs will check that -the patch was GPG-signed by a key which is in \verb!PUBRING! and will -refuse to apply the patch otherwise. - \begin{code} -get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString + +getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString -> IO (Either String (SealedPatchSet p)) -get_patch_bundle opts fps = do +getPatchBundle opts fps = do mps <- verifyPS opts $ read_email fps mops <- verifyPS opts fps case (mps, mops) of @@ -216,81 +248,28 @@ stripline p | B.null p = p | BC.last p == '\r' = B.init p | otherwise = p -\end{code} -\begin{options} ---cc, --reply -\end{options} - -If you give the \verb!--reply FROM! option to \verb!darcs apply!, it will send the -results of the application to the sender of the patch. This only works if -the patch is in the form of email with its headers intact, so that darcs -can actually know the origin of the patch. The reply email will indicate -whether or not the patch was successfully applied. The \verb!FROM! flag is -the email address that will be used as the ``from'' address when replying. -If the darcs apply is being done automatically, it is important that this -address not be the same as the address at which the patch was received, in -order to avoid automatic email loops. - -If you want to also send the apply email to another address (for example, -to create something like a ``commits'' mailing list), you can use the -\verb!--cc! option to specify additional recipients. Note that the -\verb!--cc! option \emph{requires} the \verb!--reply! option, which -provides the ``From'' address. - -The \verb!--reply! feature of apply is intended primarily for two uses. -When used by itself, it is handy for when you want to apply patches sent to -you by other developers so that they will know when their patch has been -applied. For example, in my \verb!.muttrc! (the config file for my mailer) -I have: -\begin{verbatim} -macro pager A "darcs apply --verbose \ - --reply droundy@abridgegame.org --repodir ~/darcs -\end{verbatim} -which allows me to apply a patch to darcs directly from my mailer, with the -originator of that patch being sent a confirmation when the patch is -successfully applied. NOTE: In an attempt to make sure no one else -can read your email, mutt seems to set the umask -such that patches created with the above macro are not world-readable, so -use it with care. - -When used in combination with the \verb!--verify! option, the -\verb!--reply! option allows for a nice pushable repository. When these -two options are used together, any patches that don't pass the verify will -be forwarded to the \verb!FROM! address of the \verb!--reply! option. This -allows you to set up a repository so that anyone who is authorized can push -to it and have it automatically applied, but if a stranger pushes to it, -the patch will be forwarded to you. Please (for your own sake!)\ be certain -that the \verb!--reply FROM! address is different from the one used to send -patches to a pushable repository, since otherwise an unsigned patch will be -forwarded to the repository in an infinite loop. - -If you use \verb!darcs apply --verify PUBRING --reply! to create a -pushable repository by applying patches automatically as they are received by -email, you will also want to use the \verb!--dont-allow-conflicts! option. - -\begin{options} ---dont-allow-conflicts -\end{options} -The \verb!--dont-allow-conflicts! flag causes apply to fail when applying a -patch would cause conflicts. This flag is recommended on repositories -which will be pushed to or sent to. - -\begin{options} ---allow-conflicts -\end{options} - -\verb!--allow-conflicts! will allow conflicts, but will keep the local and -recorded versions in sync on the repository. This means the conflict will exist -in both locations until it is resolved. - -\begin{options} ---mark-conflicts -\end{options} - -\verb!--mark-conflicts! will add conflict markers to illustrate the the -conflict. +applyHelp' :: String +applyHelp' = + "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 --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" ++ + "such as using `darcs pull --union' to download of your co-workers\n" ++ + "patches before going offline.\n" ++ + "\n" ++ + "This can mess up unrecorded changes in the working tree, forcing you\n" ++ + "to resolve the conflict immediately. To simply reject bundles that\n" ++ + "introduce unresolved conflicts, using the --dont-allow-conflicts\n" ++ + "option. Making this the default in push-based workflows is strongly\n" ++ + "recommended.\n" ++ + "\n" ++ + "Unlike most Darcs commands, `darcs apply' defaults to --all. Use the\n" ++ + "--interactive option to pick which patches to apply from a bundle.\n" +\end{code} \begin{options} --external-merge \end{options} @@ -300,16 +279,6 @@ subsection~\ref{resolution}. \begin{options} ---all, --interactive -\end{options} - -If you provide the \verb!--interactive! flag, darcs will -ask you for each change in the patch bundle whether or not you wish to -apply that change. The opposite is the \verb!--all! flag, which can be -used to override an \verb!interactive! which might be set in your -``defaults'' file. - -\begin{options} --sendmail-command \end{options} @@ -326,17 +295,17 @@ \begin{code} -get_from :: B.ByteString -> String -get_from ps = readFrom $ linesPS ps +getFrom :: B.ByteString -> String +getFrom ps = readFrom $ linesPS ps where readFrom [] = "" readFrom (x:xs) - | B.take 5 x == from_start = BC.unpack $ B.drop 5 x + | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x | otherwise = readFrom xs -redirect_output :: [DarcsFlag] -> String -> IO a -> IO a -redirect_output opts to doit = ro opts +redirectOutput :: [DarcsFlag] -> String -> IO a -> IO a +redirectOutput opts to doit = ro opts where - cc = get_cc opts + cc = getCc opts ro [] = doit ro (Reply f:_) = withStdoutTemp $ \tempf-> do {a <- doit; @@ -362,7 +331,7 @@ -- To:, Subject:, CC:, and mail body sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO () sendSanitizedEmail opts file to subject cc mailtext = - do scmd <- get_sendmail_cmd opts + do scmd <- getSendmailCmd opts body <- sanitizeFile mailtext sendEmail file to subject cc scmd body @@ -384,25 +353,25 @@ throwIO :: Exception -> IO a throwIO e = return $ throw e -forwarding_message :: B.ByteString -forwarding_message = BC.pack $ +forwardingMessage :: B.ByteString +forwardingMessage = BC.pack $ "The following patch was either unsigned, or signed by a non-allowed\n"++ "key, or there was a GPG failure.\n" -consider_forwarding :: [DarcsFlag] -> B.ByteString -> IO Bool -consider_forwarding opts m = cf opts (get_cc opts) +considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool +considerForwarding opts m = cf opts (getCc opts) where cf [] _ = return False cf (Reply t:_) cc = case break is_from (linesPS m) of (m1, f:m2) -> - let m_lines = forwarding_message:m1 ++ m2 + let m_lines = forwardingMessage:m1 ++ m2 m' = unlinesPS m_lines f' = BC.unpack (B.drop 5 f) in if t == f' || t == init f' then return False -- Refuse possible email loop. else do - scmd <- get_sendmail_cmd opts - if HappyForwarding `elem` opts + scmd <- getSendmailCmd opts + if doHappyForwarding opts then resendEmail t scmd m else sendEmailDoc f' t "A forwarded darcs patch" cc scmd (Just (empty,empty)) @@ -410,22 +379,8 @@ return True _ -> return False -- Don't forward emails lacking headers! cf (_:fs) cc = cf fs cc - is_from l = B.take 5 l == from_start + is_from l = B.take 5 l == fromStart -from_start :: B.ByteString -from_start = BC.pack "From:" +fromStart :: B.ByteString +fromStart = BC.pack "From:" \end{code} - -\begin{options} ---no-test, --test -\end{options} - -If you specify the \verb!--test! option, apply will run the test (if a test -exists) prior to applying the patch. If the test fails, the patch is not -applied. In this case, if the \verb!--reply! option was used, the results -of the test are sent in the reply email. You can also specify the -\verb!--no-test! option, which will override the \verb!--test! option, and -prevent the test from being run. This is helpful when setting up a -pushable repository, to keep users from running code. - - diff --git a/src/Darcs/Commands/Changes.lhs b/src/Darcs/Commands/Changes.lhs --- a/src/Darcs/Commands/Changes.lhs +++ b/src/Darcs/Commands/Changes.lhs @@ -20,7 +20,8 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP, PatternGuards #-} -module Darcs.Commands.Changes ( changes ) where +module Darcs.Commands.Changes ( changes, log ) where +import Prelude hiding ( log ) import Data.List ( intersect, sort ) import Data.Maybe ( fromMaybe ) @@ -28,96 +29,96 @@ import Darcs.Hopefully ( hopefullyM, info ) import Darcs.Patch.Depends ( slightly_optimize_patchset ) -import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable, - Interactive, OnlyChangesToFiles, Count, + Interactive, Count, NumberPatches, XMLOutput, Summary, - Reverse, Verbose, Debug), - fixSubPaths, changes_format, - possibly_remote_repo_dir, get_repourl, - working_repo_dir, only_to_files, - summary, changes_reverse, - match_several_or_range, - match_maxcount, maxCount, - all_interactive, showFriendly, - network_options + Verbose, Debug), + fixSubPaths, changesFormat, + possiblyRemoteRepoDir, getRepourl, + workingRepoDir, onlyToFiles, + summary, changesReverse, + matchSeveralOrRange, + matchMaxcount, maxCount, + allInteractive, showFriendly, + networkOptions ) +import Darcs.Flags ( doReverse, showChangesOnlyToFiles ) import Darcs.RepoPath ( toFilePath, rootDirectory ) import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path ) import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd, - get_unrecorded_in_files_unsorted, withRepositoryDirectory, ($-), findRepository, - read_repo ) + read_repo, unrecordedChanges ) import Darcs.Patch.Info ( to_xml, showPatchInfo ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.Patch.TouchesFiles ( look_touch ) -import Darcs.Patch ( RepoPatch, invert, xml_summary, description, apply_to_filepaths, - list_touched_files, effect, identity ) -import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL, +import Darcs.Patch ( RepoPatch, invert, xmlSummary, description, applyToFilepaths, + listTouchedFiles, effect, identity ) +import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL, EqCheck(..), filterFL ) -import Darcs.Match ( first_match, second_match, - match_a_patchread, have_nonrange_match, - match_first_patchset, match_second_patchset, +import Darcs.Match ( firstMatch, secondMatch, + matchAPatchread, haveNonrangeMatch, + matchFirstPatchset, matchSecondPatchset, ) -import Darcs.Commands.Annotate ( created_as_xml ) +import Darcs.Commands.Annotate ( createdAsXml ) import Printer ( Doc, putDocLnWith, simplePrinters, (<+>), renderString, prefix, text, vcat, vsep, ($$), empty, errorDoc, insert_before_lastline ) import Darcs.ColorPrinter ( fancyPrinters ) import Progress ( setProgressMode, debugMessage ) import Darcs.SelectChanges ( view_changes ) -import Darcs.Sealed ( unsafeUnseal ) +import Darcs.Witnesses.Sealed ( unsafeUnseal ) #include "impossible.h" -changes_description :: String -changes_description = "List patches in the repository." +changesDescription :: String +changesDescription = "List patches in the repository." -changes_help :: String -changes_help = +changesHelp :: String +changesHelp = "The `darcs changes' command lists the patches that constitute the\n" ++ - "current repository. Without options or arguments, ALL patches will be\n" ++ - "listed.\n" ++ - "\n" ++ changes_help' ++ - "\n" ++ changes_help'' + "current repository or, with --repo, a remote repository. Without\n" ++ + "options or arguments, ALL patches will be listed.\n" ++ + "\n" ++ changesHelp' ++ + "\n" ++ changesHelp'' changes :: DarcsCommand -changes = DarcsCommand {command_name = "changes", - command_help = changes_help, - command_description = changes_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_get_arg_possibilities = return [], - command_command = changes_cmd, - command_prereq = findRepository, - command_argdefaults = nodefaults, - command_advanced_options = network_options, - command_basic_options = [match_several_or_range, - match_maxcount, - only_to_files, - changes_format, +changes = DarcsCommand {commandName = "changes", + commandHelp = changesHelp, + commandDescription = changesDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandGetArgPossibilities = return [], + commandCommand = changesCmd, + commandPrereq = findRepository, + commandArgdefaults = nodefaults, + commandAdvancedOptions = networkOptions, + commandBasicOptions = [matchSeveralOrRange, + matchMaxcount, + onlyToFiles, + changesFormat, summary, - changes_reverse, - possibly_remote_repo_dir, - working_repo_dir, - all_interactive]} + changesReverse, + possiblyRemoteRepoDir, + workingRepoDir, + allInteractive]} -changes_cmd :: [DarcsFlag] -> [String] -> IO () -changes_cmd [Context _] [] = return () -changes_cmd opts args | Context rootDirectory `elem` opts = - let repodir = fromMaybe "." (get_repourl opts) in +changesCmd :: [DarcsFlag] -> [String] -> IO () +changesCmd [Context _] [] = return () +changesCmd opts args | Context rootDirectory `elem` opts = + let repodir = fromMaybe "." (getRepourl opts) in withRepositoryDirectory opts repodir $- \repository -> do when (args /= []) $ fail "changes --context cannot accept other arguments" - changes_context repository opts -changes_cmd opts args = - let repodir = fromMaybe "." (get_repourl opts) in + changesContext repository opts +changesCmd opts args = + let repodir = fromMaybe "." (getRepourl opts) in withRepositoryDirectory opts repodir $- \repository -> do unless (Debug `elem` opts) $ setProgressMode False files <- sort `fmap` fixSubPaths opts args unrec <- if null files then return identity - else get_unrecorded_in_files_unsorted repository (map (fp2fn . toFilePath) files) + else unrecordedChanges opts repository files `catch` \_ -> return identity -- this is triggered when repository is remote - let filez = map (fn2fp . norm_path . fp2fn) $ apply_to_filepaths (invert unrec) $ map toFilePath files - filtered_changes p = maybe_reverse $ get_changes_info opts filez p + let filez = map (fn2fp . norm_path . fp2fn) $ applyToFilepaths (invert unrec) $ map toFilePath files + filtered_changes p = maybe_reverse $ getChangesInfo opts filez p debugMessage "About to read the repository..." patches <- read_repo repository debugMessage "Done reading the repository." @@ -132,15 +133,15 @@ ps <- read_repo repository -- read repo again to prevent holding onto -- values forced by filtered_changes putDocLnWith printers $ changelog opts ps $ filtered_changes patches - where maybe_reverse (xs,b,c) = if Reverse `elem` opts + where maybe_reverse (xs,b,c) = if doReverse opts then (reverse xs, b, c) else (xs, b, c) -- FIXME: this prose is unreadable. --twb, 2009-08 -changes_help' :: String -changes_help' = - "When given one or more files or directories as an argument, only\n" ++ +changesHelp' :: String +changesHelp' = + "When given one or more files or directories as arguments, only\n" ++ "patches which affect those files or directories are listed. This\n" ++ "includes changes that happened to files before they were moved or\n" ++ "renamed.\n" ++ @@ -156,18 +157,18 @@ "whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++ "patches, print only those that affect foo.c.\n" -get_changes_info :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p +getChangesInfo :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc) -get_changes_info opts plain_fs ps = +getChangesInfo opts plain_fs ps = case get_common_and_uncommon (p2s,p1s) of - (_,us:\/:_) -> filter_patches_by_names (maxCount opts) fs $ filter pf $ unsafeUnRL $ concatRL us + (_,us:\/:_) -> filterPatchesByNames (maxCount opts) fs $ filter pf $ unsafeUnRL us where fs = map (\x -> "./" ++ x) $ plain_fs - p1s = if first_match opts then unsafeUnseal $ match_first_patchset opts ps + p1s = if firstMatch opts then unsafeUnseal $ matchFirstPatchset opts ps else NilRL:<:NilRL - p2s = if second_match opts then unsafeUnseal $ match_second_patchset opts ps + p2s = if secondMatch opts then unsafeUnseal $ matchSecondPatchset opts ps else ps - pf = if have_nonrange_match opts - then match_a_patchread opts + pf = if haveNonrangeMatch opts + then matchAPatchread opts else \_ -> True -- | Take a list of filenames and patches and produce a list of @@ -178,30 +179,30 @@ -- limit" -- maxcount, that could be Nothing (return everything) or -- "Just n" -- returns at most n patches touching the file (starting -- from the beginning of the patch list). -filter_patches_by_names :: RepoPatch p => +filterPatchesByNames :: RepoPatch p => Maybe Int -- ^ maxcount -> [FilePath] -- ^ filenames -> [PatchInfoAnd p] -- ^ patchlist -> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc) -filter_patches_by_names (Just 0) _ _ = ([], [], empty) -filter_patches_by_names _ _ [] = ([], [], empty) -filter_patches_by_names maxcount [] (hp:ps) = - (hp, []) -:- filter_patches_by_names (subtract 1 `fmap` maxcount) [] ps -filter_patches_by_names maxcount fs (hp:ps) +filterPatchesByNames (Just 0) _ _ = ([], [], empty) +filterPatchesByNames _ _ [] = ([], [], empty) +filterPatchesByNames maxcount [] (hp:ps) = + (hp, []) -:- filterPatchesByNames (subtract 1 `fmap` maxcount) [] ps +filterPatchesByNames maxcount fs (hp:ps) | Just p <- hopefullyM hp = case look_touch fs (invert p) of (True, []) -> ([(hp, fs)], fs, empty) - (True, fs') -> (hp, fs) -:- filter_patches_by_names + (True, fs') -> (hp, fs) -:- filterPatchesByNames (subtract 1 `fmap` maxcount) fs' ps - (False, fs') -> filter_patches_by_names maxcount fs' ps -filter_patches_by_names _ _ (hp:_) = + (False, fs') -> filterPatchesByNames maxcount fs' ps +filterPatchesByNames _ _ (hp:_) = ([], [], text "Can't find changes prior to:" $$ description hp) -- | Note, lazy pattern matching is required to make functions like --- filter_patches_by_names lazy in case you are only not interested in +-- filterPatchesByNames lazy in case you are only not interested in -- the first element. E.g.: -- --- let (fs, _, _) = filter_patches_by_names ... +-- let (fs, _, _) = filterPatchesByNames ... (-:-) :: a -> ([a],b,c) -> ([a],b,c) x -:- ~(xs,y,z) = (x:xs,y,z) @@ -224,25 +225,25 @@ | otherwise = vsep (map (number_patch description') pis_and_fs) $$ errstring where change_with_summary (hp, fs) - | Just p <- hopefullyM hp = if OnlyChangesToFiles `elem` opts + | Just p <- hopefullyM hp = if showChangesOnlyToFiles opts then description hp $$ text "" $$ indent (showFriendly opts (filterFL xx $ effect p)) else showFriendly opts p | otherwise = description hp $$ indent (text "[this patch is unavailable]") - where xx x = case list_touched_files x of + where xx x = case listTouchedFiles x of ys | null $ ys `intersect` fs -> IsEq _ -> NotEq xml_with_summary hp | Just p <- hopefullyM hp = insert_before_lastline - (to_xml $ info hp) (indent $ xml_summary p) + (to_xml $ info hp) (indent $ xmlSummary p) xml_with_summary hp = to_xml (info hp) indent = prefix " " actual_xml_changes = if Summary `elem` opts then map xml_with_summary pis else map (to_xml.info) pis - xml_file_names = map (created_as_xml first_change) orig_fs - first_change = if Reverse `elem` opts + xml_file_names = map (createdAsXml first_change) orig_fs + first_change = if doReverse opts then info $ head pis else info $ last pis number_patch f x = if NumberPatches `elem` opts @@ -260,8 +261,8 @@ description' = description . fst -- FIXME: this prose is unreadable. --twb, 2009-08 -changes_help'' :: String -changes_help'' = +changesHelp'' :: String +changesHelp'' = "Three output formats exist. The default is --human-readable. You can\n" ++ "also select --context, which is the internal format (as seen in patch\n" ++ "bundles) that can be re-read by Darcs (e.g. `darcs get --context').\n" ++ @@ -277,17 +278,20 @@ "WILL be output for a knowledgeable human to recreate the current state\n" ++ "of the repository.\n" -changes_context :: RepoPatch p => Repository p -> [DarcsFlag] -> IO () -changes_context repository opts = do +changesContext :: RepoPatch p => Repository p -> [DarcsFlag] -> IO () +changesContext repository opts = do r <- read_repo repository putStrLn "\nContext:\n" when (not $ null (unsafeUnRL r) || null (unsafeUnRL $ head $ unsafeUnRL r)) $ putDocLnWith simplePrinters $ changelog opts' NilRL $ - get_changes_info opts' [] + getChangesInfo opts' [] (headRL (slightly_optimize_patchset r) :<: NilRL) where opts' = if HumanReadable `elem` opts || XMLOutput `elem` opts then opts else MachineReadable : opts headRL (x:<:_) = x headRL NilRL = impossible + +log :: DarcsCommand +log = commandAlias "log" changes \end{code} diff --git a/src/Darcs/Commands/Check.lhs b/src/Darcs/Commands/Check.lhs --- a/src/Darcs/Commands/Check.lhs +++ b/src/Darcs/Commands/Check.lhs @@ -19,28 +19,33 @@ \begin{code} module Darcs.Commands.Check ( check ) where import Control.Monad ( when ) +import Control.Applicative( (<$>) ) import System.Exit ( ExitCode(..), exitWith ) -import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag( Quiet ), - partial_check, notest, testByDefault, - leave_test_dir, working_repo_dir, + + +import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo ) +import Darcs.Arguments ( DarcsFlag(Quiet), + partialCheck, notest, testByDefault, + leaveTestDir, workingRepoDir, ignoretimes ) -import Darcs.Repository.Repair( replayRepository, - RepositoryConsistency(..) ) -import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded, - testRecorded ) +import Darcs.Flags(willIgnoreTimes) +import Darcs.Repository.Repair( replayRepository, checkIndex + , RepositoryConsistency(..) ) +import Darcs.Repository ( Repository, amInRepository, withRepository, + testRecorded, readRecorded ) import Darcs.Patch ( RepoPatch, showPatch ) -import Darcs.Ordered ( FL(..) ) -import Darcs.Diff ( unsafeDiff ) -import Darcs.Repository.Prefs ( filetype_function ) -import Printer ( putDocLn, text, ($$), (<+>) ) +import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Repository.Prefs ( filetypeFunction ) +import Darcs.Diff( treeDiff ) +import Printer ( text, ($$), (<+>) ) -check_description :: String -check_description = "Check the repository for consistency." -check_help :: String -check_help = +checkDescription :: String +checkDescription = "Check the repository for consistency." + +checkHelp :: String +checkHelp = "This command verifies that the patches in the repository, when applied\n" ++ "successively to an empty tree, result in the pristine tree. If not,\n" ++ "the differences are printed and Darcs exits unsucessfully (with a\n" ++ @@ -55,51 +60,57 @@ "by `darcs check'. Use the --no-test option to disable this.\n" check :: DarcsCommand -check = DarcsCommand {command_name = "check", - command_help = check_help, - command_description = check_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = check_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [partial_check, +check = DarcsCommand {commandName = "check", + commandHelp = checkHelp, + commandDescription = checkDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = checkCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [partialCheck, notest, - leave_test_dir, - working_repo_dir + leaveTestDir, + workingRepoDir, + ignoretimes ]} -check_cmd :: [DarcsFlag] -> [String] -> IO () -check_cmd opts _ = withRepository opts (check' opts) +checkCmd :: [DarcsFlag] -> [String] -> IO () +checkCmd opts _ = withRepository opts (check' opts) check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO () check' opts repository = do - replayRepository repository (testByDefault opts) $ \ state -> do + failed <- replayRepository repository (testByDefault opts) $ \ state -> do case state of RepositoryConsistent -> do - putInfo $ text "The repository is consistent!" + putInfo opts $ text "The repository is consistent!" testRecorded repository - exitWith ExitSuccess + return False BrokenPristine newpris -> do brokenPristine newpris - exitWith $ ExitFailure 1 + return True BrokenPatches newpris _ -> do brokenPristine newpris - putInfo $ text "Found broken patches." - exitWith $ ExitFailure 1 - where + putInfo opts $ text "Found broken patches." + return True + bad_index <- case willIgnoreTimes opts of + False -> not <$> checkIndex repository (Quiet `elem` opts) + True -> return False + when bad_index $ putInfo opts $ text "Bad index." + exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess + where brokenPristine newpris = do - putInfo $ text "Looks like we have a difference..." - mc <- slurp_recorded repository - ftf <- filetype_function - putInfo $ case unsafeDiff opts ftf newpris mc of + putInfo opts $ text "Looks like we have a difference..." + mc <- readRecorded repository + ftf <- filetypeFunction + diff <- treeDiff ftf newpris mc + putInfo opts $ case diff of NilFL -> text "Nothing" patch -> text "Difference: " <+> showPatch patch - putInfo $ text "" + putInfo opts $ text "" $$ text "Inconsistent repository!" - putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s \end{code} %% FIXME: this should go in "common options" or something, since diff --git a/src/Darcs/Commands/Convert.lhs b/src/Darcs/Commands/Convert.lhs --- a/src/Darcs/Commands/Convert.lhs +++ b/src/Darcs/Commands/Convert.lhs @@ -33,47 +33,46 @@ import Data.Maybe ( catMaybes ) import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully ) -import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo, putVerbose ) import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo, - SetScriptsExecutable, UseFormat2, NoUpdateWorking, - Verbose, Quiet ), + SetScriptsExecutable, UseFormat2, NoUpdateWorking), reponame, - set_scripts_executable, - network_options ) + setScriptsExecutableOption, + networkOptions ) import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo, - createRepository, + createRepository, invalidateIndex, slurp_recorded, optimizeInventory, tentativelyMergePatches, patchSetToPatches, createPristineDirectoryTree, - revertRepositoryChanges, finalizeRepositoryChanges, sync_repo ) + revertRepositoryChanges, finalizeRepositoryChanges ) import Darcs.Global ( darcsdir ) import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch, - modernize_patch, - adddeps, getdeps, effect, flattenFL, is_merger, patchcontents ) -import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL, + modernizePatch, + adddeps, getdeps, effect, flattenFL, isMerger, patchcontents ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL, concatFL, concatRL, mapRL ) import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag ) import Darcs.Patch.Commute ( public_unravel ) import Darcs.Patch.Real ( mergeUnravelled ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) +import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2)) import Darcs.Repository.Motd ( show_motd ) -import Darcs.Utils ( clarify_errors, askUser ) +import Darcs.Utils ( clarifyErrors, askUser ) import Darcs.ProgressPatches ( progressFL ) -import Darcs.Sealed ( FlippedSeal(..) ) -import Printer ( text, putDocLn, ($$) ) +import Darcs.Witnesses.Sealed ( FlippedSeal(..) ) +import Printer ( text, ($$) ) import Darcs.ColorPrinter ( traceDoc ) import Darcs.SlurpDirectory ( list_slurpy_files ) import Darcs.Lock ( writeBinFile ) import Workaround ( setExecutable ) import qualified Data.ByteString as B (isPrefixOf, readFile) import qualified Data.ByteString.Char8 as BC (pack) -import Darcs.Gorsvet( invalidateIndex ) -convert_description :: String -convert_description = "Convert a repository from a legacy format." +convertDescription :: String +convertDescription = "Convert a repository from a legacy format." -convert_help :: String -convert_help = +convertHelp :: String +convertHelp = "The current repository format is called `darcs-2'. It was introduced\n" ++ "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++ "The `darcs convert' command allows existing projects to migrate to\n" ++ @@ -83,7 +82,7 @@ "repository is created. It is safe to run this command more than once\n" ++ "on a repository (e.g. for testing), before the final conversion.\n" ++ "\n" ++ - convert_help' ++ + convertHelp' ++ "\n" ++ "Due to this limitation, migrating a multi-branch project is a little\n" ++ "awkward. Sorry! Here is the recommended process:\n" ++ @@ -98,8 +97,8 @@ -- | This part of the help is split out because it is used twice: in -- the help string, and in the prompt for confirmation. -convert_help' :: String -convert_help' = +convertHelp' :: String +convertHelp' = "WARNING: the repository produced by this command is not understood by\n" ++ "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++ "darcs-1 and darcs-2 formats.\n" ++ @@ -111,31 +110,38 @@ "than once.)\n" convert :: DarcsCommand -convert = DarcsCommand {command_name = "convert", - command_help = convert_help, - command_description = convert_description, - command_extra_args = -1, - command_extra_arg_help = ["", "[]"], - command_command = convert_cmd, - command_prereq = \_ -> return $ Right (), - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = network_options, - command_basic_options = [reponame,set_scripts_executable]} +convert = DarcsCommand {commandName = "convert", + commandHelp = convertHelp, + commandDescription = convertDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["", "[]"], + commandCommand = convertCmd, + commandPrereq = \_ -> return $ Right (), + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = networkOptions, + commandBasicOptions = [reponame,setScriptsExecutableOption]} -convert_cmd :: [DarcsFlag] -> [String] -> IO () -convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir] -convert_cmd orig_opts [inrepodir] = do - putStrLn convert_help' +convertCmd :: [DarcsFlag] -> [String] -> IO () +convertCmd opts [inrepodir, outname] = convertCmd (NewRepo outname:opts) [inrepodir] +convertCmd orig_opts [inrepodir] = do + + typed_repodir <- ioAbsoluteOrRemote inrepodir + let repodir = toPath typed_repodir + + --test for converting darcs-2 repository + Right format <- identifyRepoFormat repodir -- just fail in case of error + when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format." + + putStrLn convertHelp' let vow = "I understand the consequences of my action" putStrLn "Please confirm that you have read and understood the above" vow' <- askUser ("by typing `" ++ vow ++ "': ") when (vow' /= vow) $ fail "User didn't understand the consequences." + let opts = UseFormat2:orig_opts - typed_repodir <- ioAbsoluteOrRemote inrepodir - let repodir = toPath typed_repodir show_motd opts repodir - mysimplename <- make_repo_name opts repodir + mysimplename <- makeRepoName opts repodir createDirectory mysimplename setCurrentDirectory mysimplename createRepository opts @@ -170,7 +176,7 @@ Just d -> p : concatMap fixDep d Nothing -> [p] convertOne :: Patch -> FL RealPatch - convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of + convertOne x | isMerger x = case mergeUnravelled $ public_unravel $ modernizePatch x of Just (FlippedSeal y) -> case effect y =/\= effect x of IsEq -> y :>: NilFL @@ -200,45 +206,40 @@ invalidateIndex repository revertable $ createPristineDirectoryTree repository "." when (SetScriptsExecutable `elem` opts) $ - do putVerbose $ text "Making scripts executable" + do putVerbose opts $ text "Making scripts executable" c <- list_slurpy_files `fmap` slurp_recorded repository let setExecutableIfScript f = do contents <- B.readFile f when (BC.pack "#!" `B.isPrefixOf` contents) $ do - putVerbose $ text ("Making executable: " ++ f) + putVerbose opts $ text ("Making executable: " ++ f) setExecutable f True mapM_ setExecutableIfScript c - sync_repo repository optimizeInventory repository - putInfo $ text "Finished converting." - where am_verbose = Verbose `elem` orig_opts - am_informative = not $ Quiet `elem` orig_opts - putVerbose s = when am_verbose $ putDocLn s - putInfo s = when am_informative $ putDocLn s - revertable x = x `clarify_errors` unlines + putInfo opts $ text "Finished converting." + where revertable x = x `clarifyErrors` unlines ["An error may have left your new working directory an inconsistent", "but recoverable state. You should be able to make the new", "repository consistent again by running darcs revert -a."] -convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments." +convertCmd _ _ = fail "You must provide 'convert' with either one or two arguments." -make_repo_name :: [DarcsFlag] -> FilePath -> IO String -make_repo_name (NewRepo n:_) _ = +makeRepoName :: [DarcsFlag] -> FilePath -> IO String +makeRepoName (NewRepo n:_) _ = do exists <- doesDirectoryExist n file_exists <- doesFileExist n if exists || file_exists then fail $ "Directory or file named '" ++ n ++ "' already exists." else return n -make_repo_name (_:as) d = make_repo_name as d -make_repo_name [] d = +makeRepoName (_:as) d = makeRepoName as d +makeRepoName [] d = case dropWhile (=='.') $ reverse $ takeWhile (\c -> c /= '/' && c /= ':') $ dropWhile (=='/') $ reverse d of - "" -> modify_repo_name "anonymous_repo" - base -> modify_repo_name base + "" -> modifyRepoName "anonymous_repo" + base -> modifyRepoName base -modify_repo_name :: String -> IO String -modify_repo_name name = +modifyRepoName :: String -> IO String +modifyRepoName name = if head name == '/' then mrn name (-1) else do cwd <- getCurrentDirectory diff --git a/src/Darcs/Commands/Diff.lhs b/src/Darcs/Commands/Diff.lhs --- a/src/Darcs/Commands/Diff.lhs +++ b/src/Darcs/Commands/Diff.lhs @@ -20,7 +20,7 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Commands.Diff ( diff_command ) where +module Darcs.Commands.Diff ( diffCommand ) where import System.FilePath.Posix ( takeFileName ) import System.Directory ( setCurrentDirectory ) @@ -32,58 +32,61 @@ import Darcs.External( diff_program ) import CommandLine ( parseCmd ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag(DiffFlags, Unified, DiffCmd, +import Darcs.Arguments ( DarcsFlag(DiffFlags, DiffCmd, LastN, AfterPatch), - match_range, store_in_memory, - diff_cmd_flag, diffflags, unidiff, - working_repo_dir, fixSubPaths, + matchRange, storeInMemory, + diffCmdFlag, diffflags, unidiff, + workingRepoDir, fixSubPaths, ) +import Darcs.Flags ( isUnified ) import Darcs.Hopefully ( info ) import Darcs.RepoPath ( toFilePath, sp2fn ) -import Darcs.Match ( get_partial_first_match, get_partial_second_match, - first_match, second_match, - match_first_patchset, match_second_patchset ) +import Darcs.Match ( getPartialFirstMatch, getPartialSecondMatch, + firstMatch, secondMatch, + matchFirstPatchset, matchSecondPatchset ) import Darcs.Repository ( PatchSet, withRepository, ($-), read_repo, amInRepository, slurp_recorded_and_unrecorded, createPristineDirectoryTree, createPartialsPristineDirectoryTree ) import Darcs.SlurpDirectory ( get_path_list, writeSlurpy ) import Darcs.Patch ( RepoPatch ) -import Darcs.Ordered ( mapRL, concatRL ) +import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import Darcs.Patch.Info ( PatchInfo, human_friendly ) import Darcs.External ( execPipeIgnoreError, clonePaths ) import Darcs.Lock ( withTempDir ) -import Darcs.Sealed ( unsafeUnseal ) +import Darcs.Witnesses.Sealed ( unseal ) import Printer ( Doc, putDoc, vcat, empty, ($$) ) #include "impossible.h" -diff_description :: String -diff_description = "Create a diff between two versions of the repository." +#include "gadts.h" -diff_help :: String -diff_help = +diffDescription :: String +diffDescription = "Create a diff between two versions of the repository." + +diffHelp :: String +diffHelp = "Diff can be used to create a diff between two versions which are in your\n"++ "repository. Specifying just --from-patch will get you a diff against\n"++ "your working copy. If you give diff no version arguments, it gives\n"++ "you the same information as whatsnew except that the patch is\n"++ "formatted as the output of a diff command\n" -diff_command :: DarcsCommand -diff_command = DarcsCommand {command_name = "diff", - command_help = diff_help, - command_description = diff_description, - command_extra_args = -1, - command_extra_arg_help +diffCommand :: DarcsCommand +diffCommand = DarcsCommand {commandName = "diff", + commandHelp = diffHelp, + commandDescription = diffDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], - command_command = diff_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [match_range, - diff_cmd_flag, + commandCommand = diffCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [matchRange, + diffCmdFlag, diffflags, unidiff, - working_repo_dir, store_in_memory]} + workingRepoDir, storeInMemory]} \end{code} \begin{options} @@ -110,31 +113,32 @@ to your \verb!_darcs/prefs/defaults! file. \begin{code} -get_diff_opts :: [DarcsFlag] -> [String] -get_diff_opts [] = [] -get_diff_opts (Unified:fs) = "-u" : get_diff_opts fs -get_diff_opts (DiffFlags f:fs) = f : get_diff_opts fs -get_diff_opts (_:fs) = get_diff_opts fs +getDiffOpts :: [DarcsFlag] -> [String] +getDiffOpts opts | isUnified opts = "-u" : get_nonU_diff_opts opts + | otherwise = get_nonU_diff_opts opts + where get_nonU_diff_opts (DiffFlags f:fs) = f : get_nonU_diff_opts fs + get_nonU_diff_opts (_:fs) = get_nonU_diff_opts fs + get_nonU_diff_opts [] = [] -has_diff_cmd_flag :: [DarcsFlag] -> Bool -has_diff_cmd_flag (DiffCmd _:_) = True -has_diff_cmd_flag (_:t) = has_diff_cmd_flag t -has_diff_cmd_flag [] = False +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 'diff_program'. Note that this potentially involves parsing the -- user's diff-command, hence the possibility for failure with an exception. -get_diff_cmd_and_args :: String -> [DarcsFlag] -> String -> String +getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String -> Either String (String, [String]) -get_diff_cmd_and_args cmd opts f1 f2 = helper opts where +getDiffCmdAndArgs cmd opts f1 f2 = helper opts where helper (DiffCmd c:_) = case parseCmd [ ('1', f1) , ('2', f2) ] c of Left err -> Left $ show err Right ([],_) -> bug $ "parseCmd should never return empty list" Right ((h:t),_) -> Right (h,t) helper [] = -- if no command specified, use 'diff' - Right (cmd, ("-rN":get_diff_opts opts++[f1,f2])) + Right (cmd, ("-rN":getDiffOpts opts++[f1,f2])) helper (_:t) = helper t \end{code} @@ -173,8 +177,8 @@ Note also that the \verb!--diff-opts! flag is ignored if you use this option. \begin{code} -diff_cmd :: [DarcsFlag] -> [String] -> IO () -diff_cmd opts args = withRepository opts $- \repository -> do +diffCmd :: [DarcsFlag] -> [String] -> IO () +diffCmd opts args = withRepository opts $- \repository -> do when (not (null [i | LastN i <- opts]) && not (null [p | AfterPatch p <- opts]) ) $ @@ -190,15 +194,15 @@ withTempDir ("old-"++thename) $ \odir -> do setCurrentDirectory formerdir withTempDir ("new-"++thename) $ \ndir -> do - if first_match opts + if firstMatch opts then withCurrentDirectory odir $ - get_partial_first_match repository opts path_list + getPartialFirstMatch repository opts path_list else if null path_list then createPristineDirectoryTree repository (toFilePath odir) else createPartialsPristineDirectoryTree repository path_list (toFilePath odir) - if second_match opts + if secondMatch opts then withCurrentDirectory ndir $ - get_partial_second_match repository opts path_list + getPartialSecondMatch repository opts path_list else do (_, s) <- slurp_recorded_and_unrecorded repository let ps = concatMap (get_path_list s . toFilePath) path_list if null path_list @@ -212,15 +216,15 @@ (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f) (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs morepatches <- read_repo repository - putDoc $ changelog (get_diff_info opts morepatches) + putDoc $ changelog (getDiffInfo opts morepatches) $$ thediff where rundiff :: String -> String -> IO Doc rundiff f1 f2 = do cmd <- diff_program - case get_diff_cmd_and_args cmd opts f1 f2 of + case getDiffCmdAndArgs cmd opts f1 f2 of Left err -> fail err Right (d_cmd, d_args) -> - let other_diff = has_diff_cmd_flag opts in + let other_diff = hasDiffCmdFlag opts in do when other_diff $ putStrLn $ "Running command '" ++ unwords (d_cmd:d_args) ++ "'" output <- execPipeIgnoreError d_cmd d_args empty @@ -229,15 +233,14 @@ return () return output -get_diff_info :: RepoPatch p => [DarcsFlag] -> PatchSet p -> [PatchInfo] -get_diff_info opts ps = - let pi1s = mapRL info $ concatRL $ if first_match opts - then unsafeUnseal $ match_first_patchset opts ps - else ps - pi2s = mapRL info $ concatRL $ if second_match opts - then unsafeUnseal $ match_second_patchset opts ps - else ps - in pi2s \\ pi1s +getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> [PatchInfo] +getDiffInfo opts ps = + let infos = mapRL info . concatRL + handle (match_cond, do_match) + | match_cond opts = unseal infos (do_match opts ps) + | otherwise = infos ps + in handle (secondMatch, matchSecondPatchset) + \\ handle (firstMatch, matchFirstPatchset) changelog :: [PatchInfo] -> Doc changelog pis = vcat $ map human_friendly pis diff --git a/src/Darcs/Commands/Dist.lhs b/src/Darcs/Commands/Dist.lhs --- a/src/Darcs/Commands/Dist.lhs +++ b/src/Darcs/Commands/Dist.lhs @@ -26,30 +26,30 @@ import Data.Char ( isAlphaNum ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help, - command_description, command_extra_args, - command_extra_arg_help, command_command, - command_prereq, command_get_arg_possibilities, - command_argdefaults, - command_advanced_options, command_basic_options), +import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp, + commandDescription, commandExtraArgs, + commandExtraArgHelp, commandCommand, + commandPrereq, commandGetArgPossibilities, + commandArgdefaults, + commandAdvancedOptions, commandBasicOptions), nodefaults ) -import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distname_option, - working_repo_dir, match_one, store_in_memory, +import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distnameOption, + workingRepoDir, matchOne, storeInMemory, fixSubPaths ) -import Darcs.Match ( get_nonrange_match, have_nonrange_match ) +import Darcs.Match ( getNonrangeMatch, haveNonrangeMatch ) import Darcs.Repository ( amInRepository, withRepoReadLock, ($-), --withRecorded, createPartialsPristineDirectoryTree ) -import Darcs.Repository.Prefs ( get_prefval ) +import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Lock ( withTemp, withTempDir, readBinFile ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory ) import Exec ( exec, Redirect(..) ) -dist_description :: String -dist_description = "Create a distribution tarball." +distDescription :: String +distDescription = "Create a distribution tarball." -dist_help :: String -dist_help = +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" ++ @@ -81,26 +81,26 @@ -} dist :: DarcsCommand -dist = DarcsCommand {command_name = "dist", - command_help = dist_help, - command_description = dist_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = dist_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [distname_option, - working_repo_dir, - match_one, - store_in_memory]} +dist = DarcsCommand {commandName = "dist", + commandHelp = distHelp, + commandDescription = distDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = distCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [distnameOption, + workingRepoDir, + matchOne, + storeInMemory]} -dist_cmd :: [DarcsFlag] -> [String] -> IO () -dist_cmd opts args = withRepoReadLock opts $- \repository -> do - distname <- get_dist_name opts +distCmd :: [DarcsFlag] -> [String] -> IO () +distCmd opts args = withRepoReadLock opts $- \repository -> do + distname <- getDistName opts verb <- return $ Verbose `elem` opts - predist <- get_prefval "predist" + predist <- getPrefval "predist" formerdir <- getCurrentDirectory path_list <- if null args then return [""] @@ -110,12 +110,12 @@ withTempDir "darcsdist" $ \tempdir -> do setCurrentDirectory (formerdir) withTempDir (toFilePath tempdir takeFileName distname) $ \ddir -> do - if have_nonrange_match opts - then withCurrentDirectory ddir $ get_nonrange_match repository opts + if haveNonrangeMatch opts + then withCurrentDirectory ddir $ getNonrangeMatch repository opts else createPartialsPristineDirectoryTree repository path_list (toFilePath ddir) ec <- case predist of Nothing -> return ExitSuccess Just pd -> system pd - if (ec == ExitSuccess) then do_dist verb tarfile tempdir ddir resultfile + if (ec == ExitSuccess) then doDist verb tarfile tempdir ddir resultfile else do putStrLn "Dist aborted due to predist failure" @@ -124,8 +124,8 @@ -- | This function performs the actual distribution action itself. -- NB - it does /not/ perform the pre-dist, that should already -- have completed successfully before this is invoked. -do_dist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO () -do_dist verb tarfile tempdir ddir resultfile = do +doDist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO () +doDist verb tarfile tempdir ddir resultfile = do setCurrentDirectory (toFilePath tempdir) exec "tar" ["-cf", "-", safename $ takeFileName $ toFilePath ddir] (Null, File tarfile, AsIs) @@ -141,16 +141,16 @@ safename n@(c:_) | isAlphaNum c = n safename n = "./" ++ n -guess_repo_name :: IO String -guess_repo_name = do +guessRepoName :: IO String +guessRepoName = do pwd <- getCurrentDirectory if '/' `elem` pwd then return $ reverse $ takeWhile (/='/') $ reverse pwd else return "cantguessreponame" -get_dist_name :: [DarcsFlag] -> IO String -get_dist_name (DistName dn:_) = return dn -get_dist_name (_:fs) = get_dist_name fs -get_dist_name _ = guess_repo_name +getDistName :: [DarcsFlag] -> IO String +getDistName (DistName dn:_) = return dn +getDistName (_:fs) = getDistName fs +getDistName _ = guessRepoName \end{code} diff --git a/src/Darcs/Commands/GZCRCs.lhs b/src/Darcs/Commands/GZCRCs.lhs --- a/src/Darcs/Commands/GZCRCs.lhs +++ b/src/Darcs/Commands/GZCRCs.lhs @@ -1,19 +1,24 @@ % Copyright (C) 2009 Ganesh Sittampalam % -% This program is free software; you can redistribute it and/or modify -% it under the terms of the GNU General Public License as published by -% the Free Software Foundation; either version 2, or (at your option) -% any later version. +% 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: % -% 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. +% The above copyright notice and this permission notice shall be +% included in all copies or substantial portions of the Software. % -% 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. +% 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. \subsection{darcs gzcrcs} \darcsCommand{gzcrcs} @@ -21,7 +26,7 @@ {-# LANGUAGE CPP #-} module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where -import Control.Arrow ( (***) ) +import Control.Arrow ( first ) import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Writer ( runWriterT, tell ) @@ -33,10 +38,11 @@ import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist ) import System.Exit ( ExitCode(..), exitWith ) +import Data.IORef ( newIORef, readIORef, writeIORef ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ), - check_or_repair, working_repo_dir, just_this_repo + checkOrRepair, workingRepoDir, justThisRepo ) import Darcs.Repository ( Repository, amInRepository, withRepository ) import Darcs.Patch ( RepoPatch ) @@ -52,30 +58,16 @@ import Darcs.Repository.Cache ( Cache(..), writable, isthisrepo, hashedFilePath, allHashedDirs ) -#ifdef HAVE_HASKELL_ZLIB import Darcs.Global ( getCRCWarnings, resetCRCWarnings ) import ByteStringUtils ( gzDecompress ) -#else --- These functions aren't available unless we have the Haskell zlib. --- The gzcrcs command shouldn't be enabled in this case, but we would --- still like to typecheck this module as much as possible so we include --- dummy versions -noChecking :: String -> a -noChecking what = error $ "Darcs.Commands.GZCRCs." ++ what ++ ": gz CRC checking is not possible unless " ++ - "darcs has been built with the Haskell zlib. This code should be unreachable." -getCRCWarnings :: IO [FilePath] -getCRCWarnings = noChecking "getCRCWarnings" -resetCRCWarnings :: IO () -resetCRCWarnings = noChecking "resetCRCWarnings" -gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool) -gzDecompress = noChecking "gzDecompress" -#endif -gzcrcs_description :: String -gzcrcs_description = "Check or repair the CRCs of compressed files in the repository." +#include "gadts.h" -gzcrcs_help :: String -gzcrcs_help = formatText +gzcrcsDescription :: String +gzcrcsDescription = "Check or repair the CRCs of compressed files in the repository." + +gzcrcsHelp :: String +gzcrcsHelp = formatText [ "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++ "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++ @@ -109,7 +101,7 @@ para w = para' where para' [] = [] para' xs = uncurry (:) $ para'' w xs - para'' r (x:xs) | w == r || length x < r = ((x:) *** id) $ para'' (r - length x - 1) xs + para'' r (x:xs) | w == r || length x < r = first (x:) $ para'' (r - length x - 1) xs para'' _ xs = ([], para' xs) -- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand @@ -126,32 +118,33 @@ when verbose $ putStrLn $ unlines ("The following corrupt files were found:":files) gzcrcs :: DarcsCommand -gzcrcs = DarcsCommand {command_name = "gzcrcs", - command_help = gzcrcs_help, - command_description = gzcrcs_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = gzcrcs_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [check_or_repair, - just_this_repo, - working_repo_dir +gzcrcs = DarcsCommand {commandName = "gzcrcs", + commandHelp = gzcrcsHelp, + commandDescription = gzcrcsDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = gzcrcsCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [checkOrRepair, + justThisRepo, + workingRepoDir ]} -gzcrcs_cmd :: [DarcsFlag] -> [String] -> IO () -gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts) -gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs" +gzcrcsCmd :: [DarcsFlag] -> [String] -> IO () +gzcrcsCmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts) +gzcrcsCmd _ _ = error "You must specify --check or --repair for gzcrcs" -#ifdef GADT_WITNESSES -gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p r u t -> IO () -#else -gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO () -#endif +gzcrcs' + :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) -> IO () gzcrcs' opts repo = do let Ca locs = extractCache repo + -- Somewhat ugly IORef use here because it's convenient, would be nicer + -- to pre-filter the list of locs to check and then decide whether to + -- print the message up front. + warnRelatedRepos <- newIORef (JustThisRepo `notElem` opts) ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do unless (JustThisRepo `elem` opts && not (isthisrepo loc)) $ do let w = writable loc @@ -159,6 +152,11 @@ let dir = hashedFilePath loc hdir "" exists <- liftIO $ doesDirectoryExist dir when exists $ do + liftIO $ do + warn <- readIORef warnRelatedRepos + when (warn && not (isthisrepo loc)) $ do + writeIORef warnRelatedRepos False + putInfo $ text "Also checking related repos and caches; use --just-this-repo to disable." liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)") files <- liftIO $ getDirectoryContents dir ((), Sum count) <- runWriterT $ flip mapM_ files $ \file -> do diff --git a/src/Darcs/Commands/Get.lhs b/src/Darcs/Commands/Get.lhs --- a/src/Darcs/Commands/Get.lhs +++ b/src/Darcs/Commands/Get.lhs @@ -28,21 +28,22 @@ import Data.Maybe ( isJust ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo ) import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy, UseFormat2, UseOldFashionedInventory, UseHashedInventory, - SetScriptsExecutable, Quiet, OnePattern ), - get_context, get_inventory_choices, + SetScriptsExecutable, OnePattern ), + getContext, getInventoryChoices, partial, reponame, - match_one_context, set_default, set_scripts_executable, nolinks, - network_options ) + matchOneContext, setDefault, setScriptsExecutableOption, nolinks, + networkOptions ) import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo, createPristineDirectoryTree, tentativelyRemovePatches, patchSetToPatches, patchSetToRepository, copyRepository, tentativelyAddToPending, - finalizeRepositoryChanges, sync_repo, setScriptsExecutable ) + finalizeRepositoryChanges, setScriptsExecutable + , invalidateIndex ) import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat, - RepoProperty ( Darcs2, HashedInventory ), format_has ) + RepoProperty ( Darcs2, HashedInventory ), formatHas ) import Darcs.Repository.DarcsRepo ( write_inventory ) import qualified Darcs.Repository.DarcsRepo as DR ( read_repo ) import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches, @@ -51,31 +52,30 @@ import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint ) import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert, effect, description ) -import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL ) +import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), mapRL, concatRL, reverseRL, lengthFL ) import Darcs.External ( copyFileOrUrl, Cachable(..) ) import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag ) -import Darcs.Repository.Prefs ( set_defaultrepo ) +import Darcs.Repository.Prefs ( setDefaultrepo ) import Darcs.Repository.Motd ( show_motd ) import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) import Darcs.SignalHandler ( catchInterrupt ) import Darcs.Commands.Init ( initialize ) -import Darcs.Match ( have_patchset_match, get_one_patchset ) +import Darcs.Match ( havePatchsetMatch, getOnePatchset ) import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError ) import Progress ( debugMessage ) -import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, ) +import Printer ( text, vcat, errorDoc, ($$) ) import Darcs.Lock ( writeBinFile ) import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote) -import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) +import Darcs.Witnesses.Sealed ( Sealed(..), unsafeUnflippedseal ) import Darcs.Global ( darcsdir ) import English ( englishNum, Noun(..) ) -import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -get_description :: String -get_description = "Create a local copy of a repository." +getDescription :: String +getDescription = "Create a local copy of a repository." -get_help :: String -get_help = +getHelp :: String +getHelp = "Get creates a local copy of a repository. The optional second\n" ++ "argument specifies a destination directory for the new copy; if\n" ++ "omitted, it is inferred from the source location.\n" ++ @@ -100,10 +100,10 @@ "Darcs get will not copy unrecorded changes to the source repository's\n" ++ "working tree.\n" ++ "\n" ++ - get_help_tag ++ + getHelpTag ++ "\n" ++ -- The remaining help text covers backwards-compatibility options. - get_help_partial ++ + getHelpPartial ++ "\n" ++ "A repository created by `darcs get' will be in the best available\n" ++ "format: it will be able to exchange patches with the source\n" ++ @@ -112,31 +112,31 @@ "is required.\n" get :: DarcsCommand -get = DarcsCommand {command_name = "get", - command_help = get_help, - command_description = get_description, - command_extra_args = -1, - command_extra_arg_help = ["", "[]"], - command_command = get_cmd, - command_prereq = contextExists, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = network_options ++ - command_advanced_options initialize, - command_basic_options = [reponame, +get = DarcsCommand {commandName = "get", + commandHelp = getHelp, + commandDescription = getDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["", "[]"], + commandCommand = getCmd, + commandPrereq = contextExists, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = networkOptions ++ + commandAdvancedOptions initialize, + commandBasicOptions = [reponame, partial, - match_one_context, - set_default, - set_scripts_executable, + matchOneContext, + setDefault, + setScriptsExecutableOption, nolinks, - get_inventory_choices]} + getInventoryChoices]} clone :: DarcsCommand -clone = command_alias "clone" get +clone = commandAlias "clone" get -get_cmd :: [DarcsFlag] -> [String] -> IO () -get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir] -get_cmd opts [inrepodir] = do +getCmd :: [DarcsFlag] -> [String] -> IO () +getCmd opts [inrepodir, outname] = getCmd (NewRepo outname:opts) [inrepodir] +getCmd opts [inrepodir] = do debugMessage "Starting work on get..." typed_repodir <- ioAbsoluteOrRemote inrepodir let repodir = toPath typed_repodir @@ -146,24 +146,24 @@ rfsource <- case rfsource_or_e of Left e -> fail e Right x -> return x debugMessage $ "Found the format of "++repodir++"..." - mysimplename <- make_repo_name opts repodir + mysimplename <- makeRepoName opts repodir createDirectory mysimplename setCurrentDirectory mysimplename - when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $ - putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n" - let opts' = if format_has Darcs2 rfsource + when (formatHas Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $ + putInfo opts $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n" + let opts' = if formatHas Darcs2 rfsource then UseFormat2:opts else if not (UseOldFashionedInventory `elem` opts) then UseHashedInventory:filter (/= UseFormat2) opts else UseOldFashionedInventory:filter (/= UseFormat2) opts createRepository opts' debugMessage "Finished initializing new directory." - set_defaultrepo repodir opts + setDefaultrepo repodir opts rf_or_e <- identifyRepoFormat "." rf <- case rf_or_e of Left e -> fail e Right x -> return x - if format_has HashedInventory rf -- refactor this into repository + if formatHas HashedInventory rf -- refactor this into repository then writeBinFile (darcsdir++"/hashed_inventory") "" else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch) @@ -172,48 +172,60 @@ then withRepository opts $- \repository -> do debugMessage "Using economical get --to-match handling" fromrepo <- identifyRepositoryFor repository repodir - Sealed patches_to_get <- get_one_patchset fromrepo opts + Sealed patches_to_get <- getOnePatchset fromrepo opts patchSetToRepository fromrepo patches_to_get opts debugMessage "Finished converting selected patch set to new repository" - else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo - where am_informative = not $ Quiet `elem` opts - putInfo s = when am_informative $ putDocLn s - -get_cmd _ _ = fail "You must provide 'get' with either one or two arguments." + else copyRepoAndGoToChosenVersion opts repodir rfsource rf +getCmd _ _ = fail "You must provide 'get' with either one or two arguments." --- | called by get_cmd +-- | called by getCmd -- assumes that the target repo of the get is the current directory, and that an inventory in the -- right format has already been created. -copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO () -copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do - copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.") - withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts - putInfo $ text "Finished getting." +copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> IO () +copyRepoAndGoToChosenVersion opts repodir rfsource rf = do + copy_repo `catchInterrupt` (when (formatHas HashedInventory rfsource) + (putInfo opts $ text "Using lazy repository.")) + withRepository opts $- \repository -> goToChosenVersion repository opts + putInfo opts $ text "Finished getting." where copy_repo = withRepository opts $- \repository -> do - if format_has HashedInventory rf || format_has HashedInventory rfsource - then do debugMessage "Identifying and copying repository..." - identifyRepositoryFor repository repodir >>= copyRepository - when (SetScriptsExecutable `elem` opts) setScriptsExecutable - else copy_repo_old_fashioned repository opts repodir + let hashUs = formatHas HashedInventory rf + hashThem = formatHas HashedInventory rfsource + case () of _ | hashUs && hashThem -> do + debugMessage "Identifying and copying repository..." + copyRepoHashed repository + | hashUs -> do + putInfo opts $ text "Converting old-fashioned repository to hashed format..." + $$ text "*******************************************************************************" + $$ text "Fetching a hashed repository would be faster. Perhaps you could persuade" + $$ text "the maintainer to run darcs optimize --upgrade with darcs 2.4.0 or higher?" + $$ text "*******************************************************************************" + copyRepoHashed repository + | hashThem -> do + putInfo opts $ text "Fetching a hashed repository as an old-fashioned one..." + copyRepoHashed repository + | otherwise -> copyRepoOldFashioned repository opts repodir + copyRepoHashed repository = + do identifyRepositoryFor repository repodir >>= copyRepository + when (SetScriptsExecutable `elem` opts) setScriptsExecutable -make_repo_name :: [DarcsFlag] -> FilePath -> IO String -make_repo_name (NewRepo n:_) _ = +makeRepoName :: [DarcsFlag] -> FilePath -> IO String +makeRepoName (NewRepo n:_) _ = do exists <- doesDirectoryExist n file_exists <- doesFileExist n if exists || file_exists then fail $ "Directory or file named '" ++ n ++ "' already exists." else return n -make_repo_name (_:as) d = make_repo_name as d -make_repo_name [] d = +makeRepoName (_:as) d = makeRepoName as d +makeRepoName [] d = case dropWhile (=='.') $ reverse $ takeWhile (\c -> c /= '/' && c /= ':') $ dropWhile (=='/') $ reverse d of - "" -> modify_repo_name "anonymous_repo" - base -> modify_repo_name base + "" -> modifyRepoName "anonymous_repo" + base -> modifyRepoName base -modify_repo_name :: String -> IO String -modify_repo_name name = +modifyRepoName :: String -> IO String +modifyRepoName name = if head name == '/' then mrn name (-1) else do cwd <- getCurrentDirectory @@ -232,8 +244,8 @@ else mrn n $ i+1 where thename = if i == -1 then n else n++"_"++show i -get_help_tag :: String -get_help_tag = +getHelpTag :: String +getHelpTag = "It is often desirable to make a copy of a repository that excludes\n" ++ "some patches. For example, if releases are tagged then `darcs get\n" ++ "--tag .' would make a copy of the repository as at the latest release.\n" ++ @@ -254,27 +266,27 @@ contextExists :: [DarcsFlag] -> IO (Either String ()) contextExists opts = - case get_context opts of + case getContext opts of Nothing -> return $ Right () Just f -> do exists <- doesFileExist $ toFilePath f if exists then return $ Right () else return . Left $ "Context file "++toFilePath f++" does not exist" -go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ()) +goToChosenVersion :: RepoPatch p => Repository p -> [DarcsFlag] -> IO () -go_to_chosen_version repository putInfo opts = - when (have_patchset_match opts) $ do +goToChosenVersion repository opts = + when (havePatchsetMatch opts) $ do debugMessage "Going to specified version..." patches <- read_repo repository - Sealed context <- get_one_patchset repository opts + Sealed context <- getOnePatchset repository opts let (_,us':\/:them') = get_common_and_uncommon (patches, context) case them' of - NilRL:<:NilRL -> return () + NilRL -> return () _ -> errorDoc $ text "Missing these patches from context:" - $$ (vcat $ mapRL description $ head $ unsafeUnRL them') - let ps = patchSetToPatches us' - putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++ + $$ (vcat $ mapRL description them') + let ps = patchSetToPatches (us':<:NilRL) + putInfo opts $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++ (englishNum (lengthFL ps) (Noun "patch") "") invalidateIndex repository withRepoLock opts $- \_ -> @@ -283,11 +295,10 @@ finalizeRepositoryChanges repository apply opts (invert $ effect ps) `catch` \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e) - sync_repo repository -get_help_partial :: String -get_help_partial = +getHelpPartial :: String +getHelpPartial = "If the source repository is in a legacy darcs-1 format and contains at\n" ++ "least one checkpoint (see `darcs optimize'), the --partial option will\n" ++ "create a partial repository. A partial repository discards history\n" ++ @@ -295,8 +306,8 @@ "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++ "the --lazy option.\n" -copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO () -copy_repo_old_fashioned repository opts repodir = do +copyRepoOldFashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO () +copyRepoOldFashioned repository opts repodir = do myname <- getCurrentDirectory fromrepo <- identifyRepositoryFor repository repodir mch <- get_checkpoint fromrepo @@ -329,7 +340,7 @@ if Partial `elem` opts && isJust mch then let Sealed p_ch = fromJust mch pi_ch = patch2patchinfo p_ch - needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $ + needed_patches = reverseRL $ unsafeUnflippedseal $ get_patches_beyond_tag pi_ch local_patches in do write_checkpoint_patch p_ch apply opts p_ch `catch` @@ -340,8 +351,5 @@ pristine <- identifyPristine createPristineFromWorking pristine setCurrentDirectory myname - debugMessage "Syncing the repository..." - sync_repo repository - debugMessage "Repository synced." \end{code} diff --git a/src/Darcs/Commands/Help.lhs b/src/Darcs/Commands/Help.lhs --- a/src/Darcs/Commands/Help.lhs +++ b/src/Darcs/Commands/Help.lhs @@ -18,19 +18,19 @@ \darcsCommand{help} \begin{code} module Darcs.Commands.Help ( - help_cmd, - command_control_list, environmentHelp, -- these are for preproc.hs - print_version, - list_available_commands ) where + helpCmd, + commandControlList, environmentHelp, -- these are for preproc.hs + printVersion, + listAvailableCommands ) where -import Darcs.Arguments ( DarcsFlag(..), environmentHelpSendmail ) +import Darcs.Arguments ( DarcsFlag(..), environmentHelpEmail, environmentHelpSendmail ) import Darcs.Commands ( CommandArgs(..), CommandControl(..), DarcsCommand(..), - disambiguate_commands, extract_commands, get_command_help, nodefaults, usage ) + disambiguateCommands, extractCommands, getCommandHelp, nodefaults, usage ) import Darcs.External ( viewDoc ) import Darcs.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir ) import Darcs.Patch.Match ( helpOnMatchers ) -import Darcs.Repository.Prefs ( binaries_file_help, environmentHelpHome ) +import Darcs.Repository.Prefs ( binariesFileHelp, environmentHelpHome ) import Darcs.Utils ( withCurrentDirectory, environmentHelpEditor, environmentHelpPager ) import Data.Char ( isAlphaNum, toLower ) import Data.List ( groupBy ) @@ -38,59 +38,59 @@ import Printer ( text ) import Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import System.Exit ( ExitCode(..), exitWith ) -import ThisVersion ( darcs_version ) +import Version ( version ) import URL (environmentHelpProxy, environmentHelpProxyPassword) import Workaround ( getCurrentDirectory ) import qualified Darcs.TheCommands as TheCommands -help_description :: String -help_description = "Display help about darcs and darcs commands." +helpDescription :: String +helpDescription = "Display help about darcs and darcs commands." -help_help :: String -help_help = +helpHelp :: String +helpHelp = "Without arguments, `darcs help' prints a categorized list of darcs\n" ++ "commands and a short description of each one. With an extra argument,\n" ++ "`darcs help foo' prints detailed help about the darcs command foo.\n" help :: DarcsCommand -help = DarcsCommand {command_name = "help", - command_help = help_help, - command_description = help_description, - command_extra_args = -1, - command_extra_arg_help = ["[ [DARCS_SUBCOMMAND]] "], - command_command = \ x y -> help_cmd x y >> exitWith ExitSuccess, - command_prereq = \_ -> return $ Right (), - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = []} +help = DarcsCommand {commandName = "help", + commandHelp = helpHelp, + commandDescription = helpDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[ [DARCS_SUBCOMMAND]] "], + commandCommand = \ x y -> helpCmd x y >> exitWith ExitSuccess, + commandPrereq = \_ -> return $ Right (), + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = []} -help_cmd :: [DarcsFlag] -> [String] -> IO () -help_cmd _ ["manpage"] = putStr $ unlines manpageLines -help_cmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers -help_cmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment -help_cmd _ [] = viewDoc $ text $ usage command_control_list +helpCmd :: [DarcsFlag] -> [String] -> IO () +helpCmd _ ["manpage"] = putStr $ unlines manpageLines +helpCmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers +helpCmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment +helpCmd _ [] = viewDoc $ text $ usage commandControlList -help_cmd _ (cmd:args) = - let disambiguated = disambiguate_commands command_control_list cmd args +helpCmd _ (cmd:args) = + let disambiguated = disambiguateCommands commandControlList cmd args in case disambiguated of Left err -> fail err Right (cmds,_) -> let msg = case cmds of - CommandOnly c -> get_command_help Nothing c - SuperCommandOnly c -> get_command_help Nothing c - SuperCommandSub c s -> get_command_help (Just c) s + CommandOnly c -> getCommandHelp Nothing c + SuperCommandOnly c -> getCommandHelp Nothing c + SuperCommandSub c s -> getCommandHelp (Just c) s in viewDoc $ text msg -list_available_commands :: IO () -list_available_commands = +listAvailableCommands :: IO () +listAvailableCommands = do here <- getCurrentDirectory - is_valid <- sequence $ map - (\c-> withCurrentDirectory here $ (command_prereq c) []) - (extract_commands command_control_list) - putStr $ unlines $ map (command_name . fst) $ + is_valid <- mapM + (\c-> withCurrentDirectory here $ (commandPrereq c) []) + (extractCommands commandControlList) + putStr $ unlines $ map (commandName . fst) $ filter (isRight.snd) $ - zip (extract_commands command_control_list) is_valid + zip (extractCommands commandControlList) is_valid putStrLn "--help" putStrLn "--version" putStrLn "--exact-version" @@ -98,14 +98,17 @@ where isRight (Right _) = True isRight _ = False -print_version :: IO () -print_version = putStrLn $ "darcs version " ++ darcs_version +printVersion :: IO () +printVersion = putStrLn $ "darcs version " ++ version -- avoiding a module import cycle between Help and TheCommands -command_control_list :: [CommandControl] -command_control_list = - Command_data help : TheCommands.command_control_list +commandControlList :: [CommandControl] +commandControlList = + CommandData help : TheCommands.commandControlList +-- FIXME: the "grouping" comments below should made subsections in the +-- manpage, as we already do for DarcsCommand groups. --twb, 2009 + -- | Help on each environment variable in which Darcs is interested. environmentHelp :: [([String], [String])] environmentHelp = [ @@ -115,6 +118,7 @@ environmentHelpPager, environmentHelpTmpdir, environmentHelpKeepTmpdir, + environmentHelpEmail, environmentHelpSendmail, -- Remote Repositories environmentHelpSsh, @@ -144,7 +148,7 @@ -- | The lines of the manpage to be printed. manpageLines :: [String] manpageLines = [ - ".TH DARCS 1 \"" ++ darcs_version ++ "\"", + ".TH DARCS 1 \"" ++ version ++ "\"", ".SH NAME", "darcs \\- an advanced revision control system", ".SH SYNOPSIS", @@ -190,7 +194,7 @@ unlines environment, ".SH FILES", ".SS \"_darcs/prefs/binaries\"", - escape $ unlines binaries_file_help, + escape $ unlines binariesFileHelp, ".SH BUGS", "At http://bugs.darcs.net/ you can find a list of known", "bugs in Darcs. Unknown bugs can be reported at that", @@ -209,19 +213,19 @@ -- necessary to avoid blank lines from Hidden_commands, as groff -- translates them into annoying vertical padding (unlike TeX). synopsis :: [String] - synopsis = foldl iter [] command_control_list + synopsis = foldl iter [] commandControlList where iter :: [String] -> CommandControl -> [String] - iter acc (Group_name _) = acc - iter acc (Hidden_command _) = acc - iter acc (Command_data c@SuperCommand {}) = + iter acc (GroupName _) = acc + iter acc (HiddenCommand _) = acc + iter acc (CommandData c@SuperCommand {}) = acc ++ concatMap - (render (command_name c ++ " ")) - (extract_commands (command_sub_commands c)) - iter acc (Command_data c) = acc ++ render "" c + (render (commandName c ++ " ")) + (extractCommands (commandSubCommands c)) + iter acc (CommandData c) = acc ++ render "" c render :: String -> DarcsCommand -> [String] render prefix c = - [".B darcs " ++ prefix ++ command_name c] ++ - (map mangle_args $ command_extra_arg_help c) ++ + [".B darcs " ++ prefix ++ commandName c] ++ + (map mangle_args $ commandExtraArgHelp c) ++ -- In the output, we want each command to be on its own -- line, but we don't want blank lines between them. -- AFAICT this can only be achieved with the .br @@ -231,20 +235,20 @@ -- | As 'synopsis', but make each group a subsection (.SS), and -- include the help text for each command. commands :: [String] - commands = foldl iter [] command_control_list + commands = foldl iter [] commandControlList where iter :: [String] -> CommandControl -> [String] - iter acc (Group_name x) = acc ++ [".SS \"" ++ x ++ "\""] - iter acc (Hidden_command _) = acc - iter acc (Command_data c@SuperCommand {}) = + iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""] + iter acc (HiddenCommand _) = acc + iter acc (CommandData c@SuperCommand {}) = acc ++ concatMap - (render (command_name c ++ " ")) - (extract_commands (command_sub_commands c)) - iter acc (Command_data c) = acc ++ render "" c + (render (commandName c ++ " ")) + (extractCommands (commandSubCommands c)) + iter acc (CommandData c) = acc ++ render "" c render :: String -> DarcsCommand -> [String] render prefix c = - [".B darcs " ++ prefix ++ command_name c] ++ - (map mangle_args $ command_extra_arg_help c) ++ - [".RS 4", escape $ command_help c, ".RE"] + [".B darcs " ++ prefix ++ commandName c] ++ + (map mangle_args $ commandExtraArgHelp c) ++ + [".RS 4", escape $ commandHelp c, ".RE"] -- | Now I'm showing off: mangle the extra arguments of Darcs commands -- so as to use the ideal format for manpages, italic words and roman diff --git a/src/Darcs/Commands/Init.lhs b/src/Darcs/Commands/Init.lhs --- a/src/Darcs/Commands/Init.lhs +++ b/src/Darcs/Commands/Init.lhs @@ -17,17 +17,17 @@ \darcsCommand{initialize} \begin{code} -module Darcs.Commands.Init ( initialize, initialize_cmd ) where +module Darcs.Commands.Init ( initialize, initializeCmd ) where import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag, working_repo_dir, - inventory_choices ) +import Darcs.Arguments ( DarcsFlag, workingRepoDir, + inventoryChoices ) import Darcs.Repository ( amNotInRepository, createRepository ) -initialize_description :: String -initialize_description = "Make the current directory a repository." +initializeDescription :: String +initializeDescription = "Make the current directory a repository." -initialize_help :: String -initialize_help = +initializeHelp :: String +initializeHelp = "The `darcs initialize' command turns the current directory into a\n" ++ "Darcs repository. Any existing files and subdirectories become\n" ++ "UNSAVED changes in the working tree: record them with `darcs add -r'\n" ++ @@ -70,20 +70,20 @@ "Initialize is commonly abbreviated to `init'.\n" initialize :: DarcsCommand -initialize = DarcsCommand {command_name = "initialize", - command_help = initialize_help, - command_description = initialize_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_prereq = amNotInRepository, - command_command = initialize_cmd, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [inventory_choices, - working_repo_dir]} +initialize = DarcsCommand {commandName = "initialize", + commandHelp = initializeHelp, + commandDescription = initializeDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandPrereq = amNotInRepository, + commandCommand = initializeCmd, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [inventoryChoices, + workingRepoDir]} -initialize_cmd :: [DarcsFlag] -> [String] -> IO () -initialize_cmd opts _ = createRepository opts +initializeCmd :: [DarcsFlag] -> [String] -> IO () +initializeCmd opts _ = createRepository opts \end{code} diff --git a/src/Darcs/Commands/MarkConflicts.lhs b/src/Darcs/Commands/MarkConflicts.lhs --- a/src/Darcs/Commands/MarkConflicts.lhs +++ b/src/Darcs/Commands/MarkConflicts.lhs @@ -25,25 +25,25 @@ import Darcs.SignalHandler ( withSignalsBlocked ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) -import Darcs.Arguments ( DarcsFlag, ignoretimes, working_repo_dir, umask_option ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) +import Darcs.Arguments ( DarcsFlag, ignoretimes, workingRepoDir, umaskOption ) import Darcs.Repository ( withRepoLock, ($-), amInRepository, add_to_pending, applyToWorking, - read_repo, sync_repo, get_unrecorded_unsorted, + read_repo, unrecordedChanges ) import Darcs.Patch ( invert ) -import Darcs.Ordered ( FL(..) ) -import Darcs.Sealed ( Sealed(Sealed) ) +import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Resolution ( patchset_conflict_resolutions ) import Darcs.Utils ( promptYorn ) #include "impossible.h" -markconflicts_description :: String -markconflicts_description = +markconflictsDescription :: String +markconflictsDescription = "Mark unresolved conflicts in working tree, for manual resolution." -markconflicts_help :: String -markconflicts_help = +markconflictsHelp :: String +markconflictsHelp = "Darcs requires human guidance to unify changes to the same part of a\n" ++ "source file. When a conflict first occurs, darcs will add both\n" ++ "choices to the working tree, delimited by the markers `v v v',\n" ++ @@ -63,22 +63,22 @@ "alias still exists for backwards-compatibility.\n" markconflicts :: DarcsCommand -markconflicts = DarcsCommand {command_name = "mark-conflicts", - command_help = markconflicts_help, - command_description = markconflicts_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = markconflicts_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = [ignoretimes, - working_repo_dir]} +markconflicts = DarcsCommand {commandName = "mark-conflicts", + commandHelp = markconflictsHelp, + commandDescription = markconflictsDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = markconflictsCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = [ignoretimes, + workingRepoDir]} -markconflicts_cmd :: [DarcsFlag] -> [String] -> IO () -markconflicts_cmd opts [] = withRepoLock opts $- \repository -> do - pend <- get_unrecorded_unsorted repository +markconflictsCmd :: [DarcsFlag] -> [String] -> IO () +markconflictsCmd opts [] = withRepoLock opts $- \repository -> do + pend <- unrecordedChanges opts repository [] r <- read_repo repository Sealed res <- return $ patchset_conflict_resolutions r case res of NilFL -> do putStrLn "No conflicts to mark." @@ -86,21 +86,20 @@ _ -> return () case pend of NilFL -> return () - _ -> do yorn <- promptYorn - ("This will trash any unrecorded changes"++ - " in the working directory.\nAre you sure? ") + _ -> do putStrLn ("This will trash any unrecorded changes"++ + " in the working directory.") + yorn <- promptYorn "Are you sure? " when (yorn /= 'y') $ exitWith ExitSuccess applyToWorking repository opts (invert pend) `catch` \e -> bug ("Can't undo pending changes!" ++ show e) - sync_repo repository withSignalsBlocked $ do add_to_pending repository res applyToWorking repository opts res `catch` \e -> bug ("Problem marking conflicts in mark-conflicts!" ++ show e) putStrLn "Finished marking conflicts." -markconflicts_cmd _ _ = impossible +markconflictsCmd _ _ = impossible -- |resolve is an alias for mark-conflicts. resolve :: DarcsCommand -resolve = command_alias "resolve" markconflicts +resolve = commandAlias "resolve" markconflicts \end{code} diff --git a/src/Darcs/Commands/Move.lhs b/src/Darcs/Commands/Move.lhs --- a/src/Darcs/Commands/Move.lhs +++ b/src/Darcs/Commands/Move.lhs @@ -25,11 +25,12 @@ import Data.Maybe ( catMaybes ) import Darcs.SignalHandler ( withSignalsBlocked ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) -import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ), - fixSubPaths, working_repo_dir, - list_files, allow_problematic_filenames, umask_option, +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) +import Darcs.Arguments ( DarcsFlag(), + fixSubPaths, workingRepoDir, + listFiles, allowProblematicFilenames, umaskOption, ) +import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved ) import Darcs.RepoPath ( toFilePath, sp2fn ) import System.FilePath.Posix ( (), takeFileName ) import System.Directory ( renameDirectory ) @@ -37,28 +38,27 @@ import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, slurp_pending, add_to_pending, ) -import Darcs.Ordered ( FL(..), unsafeFL ) +import Darcs.Witnesses.Ordered ( FL(..), unsafeFL ) import Darcs.Global ( debugMessage ) import qualified Darcs.Patch import Darcs.Patch ( RepoPatch, Prim ) import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase, slurp_remove, slurp_hasdir, slurp_hasfile ) -import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name ) +import Darcs.Patch.FileName ( fp2fn, fn2fp, superName ) import qualified System.FilePath.Windows as WindowsFilePath -import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -move_description :: String -move_description = "Move or rename files." +moveDescription :: String +moveDescription = "Move or rename files." -move_help :: String -move_help = +moveHelp :: String +moveHelp = "Darcs cannot reliably distinguish between a file being deleted and a\n" ++ "new one added, and a file being moved. Therefore Darcs always assumes\n" ++ "the former, and provides the `darcs mv' command to let Darcs know when\n" ++ "you want the latter. This command will also move the file in the\n" ++ - "working tree (unlike `darcs remove').\n" ++ + "working tree (unlike `darcs remove'), unless it has already been moved.\n" ++ "\n" ++ -- Note that this paragraph is very similar to one in ./Add.lhs. "Darcs will not rename a file if another file in the same folder has\n" ++ @@ -69,51 +69,50 @@ "unusable on those systems!\n" move :: DarcsCommand -move = DarcsCommand {command_name = "move", - command_help = move_help, - command_description = move_description, - command_extra_args = -1, - command_extra_arg_help = [" ... "], - command_command = move_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_files, - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = [allow_problematic_filenames, working_repo_dir]} -move_cmd :: [DarcsFlag] -> [String] -> IO () -move_cmd _ [] = fail "The `darcs move' command requires at least two arguments." -move_cmd _ [_] = fail "The `darcs move' command requires at least two arguments." +move = DarcsCommand {commandName = "move", + commandHelp = moveHelp, + commandDescription = moveDescription, + commandExtraArgs = -1, + commandExtraArgHelp = [" ... "], + commandCommand = moveCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = [allowProblematicFilenames, workingRepoDir]} +moveCmd :: [DarcsFlag] -> [String] -> IO () +moveCmd _ [] = fail "The `darcs move' command requires at least two arguments." +moveCmd _ [_] = fail "The `darcs move' command requires at least two arguments." -move_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do +moveCmd opts args@[_,_] = withRepoLock opts $- \repository -> do two_files <- fixSubPaths opts args [old,new] <- return $ case two_files of [_,_] -> two_files [_] -> error "Cannot rename a file or directory onto itself!" - xs -> bug $ "Problem in move_cmd: " ++ show xs + xs -> bug $ "Problem in moveCmd: " ++ show xs work <- slurp "." let old_fp = toFilePath old new_fp = toFilePath new if slurp_hasdir (sp2fn new) work && slurp_has old_fp work - then move_to_dir repository opts [old_fp] new_fp + then moveToDir repository opts [old_fp] new_fp else do cur <- slurp_pending repository addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp) - invalidateIndex repository withSignalsBlocked $ do case addpatch of Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL) Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL) - move_file_or_dir work old_fp new_fp + moveFileOrDir work old_fp new_fp -move_cmd opts args = +moveCmd opts args = withRepoLock opts $- \repository -> do relpaths <- map toFilePath `fmap` fixSubPaths opts args let moved = init relpaths finaldir = last relpaths - move_to_dir repository opts moved finaldir + moveToDir repository opts moved finaldir -move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO () -move_to_dir repository opts moved finaldir = +moveToDir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO () +moveToDir repository opts moved finaldir = let movefns = map takeFileName moved movetargets = map (finaldir ) movefns movepatches = zipWith Darcs.Patch.move moved movetargets @@ -121,31 +120,30 @@ cur <- slurp_pending repository work <- slurp "." addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets - invalidateIndex repository withSignalsBlocked $ do add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches - zipWithM_ (move_file_or_dir work) moved movetargets + zipWithM_ (moveFileOrDir work) moved movetargets check_new_and_old_filenames :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim) check_new_and_old_filenames opts cur work (old,new) = do - unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $ + unless (doAllowWindowsReserved opts || WindowsFilePath.isValid new) $ fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++ "Use --reserved-ok to allow such filenames." maybe_add_file_thats_been_moved <- if slurp_has old work -- We need to move the object - then do unless (slurp_hasdir (super_name $ fp2fn new) work) $ + then do unless (slurp_hasdir (superName $ fp2fn new) work) $ fail $ "The target directory " ++ - (fn2fp $ super_name $ fp2fn new)++ + (fn2fp $ superName $ fp2fn new)++ " isn't known in working directory, did you forget to add it?" when (it_has new work) $ fail $ already_exists "working directory" return Nothing else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory" return $ Just $ Darcs.Patch.addfile old if slurp_has old cur - then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $ + then do unless (slurp_hasdir (superName $ fp2fn new) cur) $ fail $ "The target directory " ++ - (fn2fp $ super_name $ fp2fn new)++ + (fn2fp $ superName $ fp2fn new)++ " isn't known in working directory, did you forget to add it?" when (it_has new cur) $ fail $ already_exists "repository" else fail $ doesnt_exist "repository" @@ -154,11 +152,11 @@ let ms2 = slurp_remove (fp2fn old) s in case ms2 of Nothing -> False - Just s2 -> if AllowCaseOnly `elem` opts + Just s2 -> if doAllowCaseOnly opts then slurp_has f s2 else slurp_has_anycase f s2 already_exists what_slurpy = - if AllowCaseOnly `elem` opts + if doAllowCaseOnly opts then "A file or dir named "++new++" already exists in " ++ what_slurpy ++ "." else "A file or dir named "++new++" (or perhaps differing"++ @@ -169,18 +167,18 @@ "There is no file or dir named " ++ old ++ " in the "++ what_slurpy ++ "." -move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO () -move_file_or_dir work old new = - if slurp_hasfile (fp2fn old) work - then do debugMessage $ unwords ["renameFile",old,new] - renameFile old new - else if slurp_hasdir (fp2fn old) work - then do debugMessage $ unwords ["renameDirectory",old,new] - renameDirectory old new - else return () +moveFileOrDir :: Slurpy -> FilePath -> FilePath -> IO () +moveFileOrDir work old new + | slurp_hasfile (fp2fn old) work = + do debugMessage $ unwords ["renameFile",old,new] + renameFile old new + | slurp_hasdir (fp2fn old) work = + do debugMessage $ unwords ["renameDirectory",old,new] + renameDirectory old new + | otherwise = return () mv :: DarcsCommand -mv = command_alias "mv" move +mv = commandAlias "mv" move \end{code} diff --git a/src/Darcs/Commands/Optimize.lhs b/src/Darcs/Commands/Optimize.lhs --- a/src/Darcs/Commands/Optimize.lhs +++ b/src/Darcs/Commands/Optimize.lhs @@ -23,60 +23,81 @@ module Darcs.Commands.Optimize ( optimize ) where import Control.Monad ( when, unless ) import Data.Maybe ( isJust ) -import Text.Regex ( mkRegex, matchRegex ) -import System.Directory ( getDirectoryContents, doesDirectoryExist ) +import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist ) +import qualified Data.ByteString.Char8 as BS +import Storage.Hashed.Darcs( decodeDarcsSize ) + import Darcs.Hopefully ( hopefully, info ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag( Compress, UnCompress, +import Darcs.Arguments ( DarcsFlag( UpgradeFormat, UseHashedInventory, + Compress, UnCompress, NoCompress, Reorder, - TagName, CheckPoint, - Relink, RelinkPristine ), - tagname, checkpoint, reorder_patches, - uncompress_nocompress, - relink, relink_pristine, sibling, + Relink, RelinkPristine, OptimizePristine ), + reorderPatches, + uncompressNocompress, + relink, relinkPristine, sibling, flagsToSiblings, - working_repo_dir, umask_option, + upgradeFormat, + workingRepoDir, umaskOption, optimizePristine ) -import Darcs.Repository.Prefs ( get_preflist ) +import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf, read_repo, optimizeInventory, slurp_recorded, tentativelyReplacePatches, cleanRepository, - amInRepository, finalizeRepositoryChanges ) -import Darcs.Repository.Checkpoint ( write_checkpoint ) -import Darcs.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL ) -import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly ) + amInRepository, finalizeRepositoryChanges, replacePristine ) +import Darcs.Witnesses.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL ) +import Darcs.Patch.Info ( PatchInfo, just_name ) import Darcs.Patch ( RepoPatch ) import ByteStringUtils ( gzReadFilePS ) -import Darcs.Patch.Depends ( deep_optimize_patchset, slightly_optimize_patchset, +import Darcs.Patch.Depends ( slightly_optimize_patchset, get_patches_beyond_tag, get_patches_in_tag, ) import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS ) import Darcs.RepoPath ( toFilePath ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage ) -import Printer ( putDocLn, text, ($$) ) import Darcs.SlurpDirectory ( slurp, list_slurpy_files ) import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory ) -import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal ) +import Darcs.Witnesses.Sealed ( FlippedSeal(..), unsafeUnseal ) import Darcs.Global ( darcsdir ) #include "impossible.h" +-- imports for optimize --upgrade; to be tidied +import qualified Data.ByteString as B (empty) +import System.Directory ( createDirectoryIfMissing, removeFile ) +import System.FilePath.Posix ( takeExtension, () ) -optimize_description :: String -optimize_description = "Optimize the repository." +import Progress ( beginTedious, endTedious, tediousSize, progress ) +import SHA1 ( sha1PS ) +import Darcs.Flags ( compression ) +import Darcs.Lock ( rm_recursive ) +import Darcs.Witnesses.Ordered ( mapFL, mapRL_RL, bunchFL, lengthRL ) +import Darcs.ProgressPatches ( progressFL ) +import Darcs.Repository.Cache ( hashedDir, HashedDir(HashedPristineDir) ) +import Darcs.Repository.Format ( identifyRepoFormat, + createRepoFormat, writeRepoFormat, formatHas, + RepoProperty ( HashedInventory ) ) +import qualified Darcs.Repository.HashedRepo as HashedRepo +import Darcs.Repository.Prefs ( getCaches ) +import Darcs.Repository.Repair ( replayRepository, RepositoryConsistency(..) ) +import Darcs.Repository.State ( readRecorded ) +import Darcs.Utils ( catchall ) +#include "gadts.h" -optimize_help :: String -optimize_help = +optimizeDescription :: String +optimizeDescription = "Optimize the repository." + +optimizeHelp :: String +optimizeHelp = "The `darcs optimize' command modifies the current repository in an\n" ++ "attempt to reduce its resource requirements. By default a single\n" ++ "fast, safe optimization is performed; additional optimization\n" ++ "techniques can be enabled by passing options to `darcs optimize'.\n" ++ - "\n" ++ optimize_help_inventory ++ + "\n" ++ optimizeHelpInventory ++ -- "\n" ++ optimize_help_reorder ++ - "\n" ++ optimize_help_relink ++ - -- checkpoints and uncompression are least useful, so they are last. - "\n" ++ optimize_help_compression ++ - "\n" ++ optimize_help_checkpoint ++ + "\n" ++ optimizeHelpRelink ++ + -- uncompression is least useful, so it is last. + "\n" ++ optimizeHelpCompression ++ "\n" ++ "There is one more optimization which CAN NOT be performed by this\n" ++ "command. Every time your record a patch, a new inventory file is\n" ++ @@ -89,102 +110,56 @@ "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n" optimize :: DarcsCommand -optimize = DarcsCommand {command_name = "optimize", - command_help = optimize_help, - command_description = optimize_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = optimize_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [uncompress_nocompress, umask_option], - command_basic_options = [checkpoint, - tagname, - working_repo_dir, - reorder_patches, +optimize = DarcsCommand {commandName = "optimize", + commandHelp = optimizeHelp, + commandDescription = optimizeDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = optimizeCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [uncompressNocompress, umaskOption], + commandBasicOptions = [workingRepoDir, + reorderPatches, sibling, relink, - relink_pristine]} + relinkPristine, + upgradeFormat, + optimizePristine]} -optimize_cmd :: [DarcsFlag] -> [String] -> IO () -optimize_cmd origopts _ = withRepoLock opts $- \repository -> do - cleanRepository repository - do_reorder opts repository - do_optimize_inventory repository - when (CheckPoint `elem` opts) $ do_checkpoint opts repository - when (Compress `elem` opts || UnCompress `elem` opts) $ optimize_compression opts - when (Relink `elem` opts || (RelinkPristine `elem` opts)) $ - do_relink opts repository +optimizeCmd :: [DarcsFlag] -> [String] -> IO () +optimizeCmd origopts _ = do + when (UpgradeFormat `elem` origopts) optimizeUpgradeFormat + withRepoLock opts $- \repository -> do + if (OptimizePristine `elem` opts) + then doOptimizePristine repository + else do cleanRepository repository + doReorder opts repository + doOptimizeInventory repository + when (Compress `elem` opts || UnCompress `elem` opts) $ + optimizeCompression opts + when (Relink `elem` opts || (RelinkPristine `elem` opts)) $ + doRelink opts repository putStrLn "Done optimizing!" where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts -is_tag :: PatchInfo -> Bool -is_tag pinfo = take 4 (just_name pinfo) == "TAG " +isTag :: PatchInfo -> Bool +isTag pinfo = take 4 (just_name pinfo) == "TAG " -optimize_help_inventory :: String -optimize_help_inventory = +optimizeHelpInventory :: String +optimizeHelpInventory = "The default optimization moves recent patches (those not included in\n" ++ "the latest tag) to the `front', reducing the amount that a typical\n" ++ "remote command needs to download. It should also reduce the CPU time\n" ++ "needed for some operations.\n" -do_optimize_inventory :: RepoPatch p => Repository p -> IO () -do_optimize_inventory repository = do +doOptimizeInventory :: RepoPatch p => Repository p -> IO () +doOptimizeInventory repository = do debugMessage "Writing out a nice copy of the inventory." optimizeInventory repository debugMessage "Done writing out a nice copy of the inventory." -optimize_help_checkpoint :: String -optimize_help_checkpoint = - "If the repository is in `old-fashioned-inventory' format, the `darcs\n" ++ - "optimize --checkpoint' command creates a checkpoint of the latest tag.\n" ++ - "This checkpoint is used by `darcs get --partial' to create partial\n" ++ - "repositories. With the `--tag' option, checkpoints for older tags can\n" ++ - "be created. In newer repository formats, this feature has been\n" ++ - "replaced by `darcs get --lazy', which does not require checkpoints.\n" - -do_checkpoint :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () -do_checkpoint opts repository = do - mpi <- get_tag opts repository - case mpi of - Nothing -> return () - Just pinfo -> do putDocLn $ text "Checkpointing tag:" - $$ human_friendly pinfo - write_checkpoint repository pinfo - -get_tag :: RepoPatch p => [DarcsFlag] -> Repository p -> IO (Maybe PatchInfo) -get_tag [] r = do ps <- read_repo r - case filter is_tag $ lasts $ mapRL (mapRL info) ps of - [] -> do putStrLn "There is no tag to checkpoint!" - return Nothing - (pinfo:_) -> return $ Just pinfo -get_tag (TagName t:_) r = - do ps <- read_repo r - case filter (match_tag t) $ lasts $ mapRL (mapRL info) ps of - (pinfo:_) -> return $ Just pinfo - _ -> case filter (match_tag t) $ - lasts $ mapRL (mapRL info) $ deep_optimize_patchset ps of - (pinfo:_) -> return $ Just pinfo - _ -> do putStr "Cannot checkpoint any tag " - putStr $ "matching '"++t++"'\n" - return Nothing -get_tag (_:fs) r = get_tag fs r - -lasts :: [[a]] -> [a] -lasts [] = [] -lasts (x@(_:_):ls) = last x : lasts ls -lasts ([]:ls) = lasts ls - -mymatch :: String -> PatchInfo -> Bool -mymatch r = match_name $ matchRegex (mkRegex r) -match_name :: (String -> Maybe a) -> PatchInfo -> Bool -match_name ch pinfo = isJust $ ch (just_name pinfo) -match_tag :: String -> PatchInfo -> Bool -match_tag ('^':n) = mymatch $ "^TAG "++n -match_tag n = mymatch $ "^TAG .*"++n - - -optimize_help_compression :: String -optimize_help_compression = +optimizeHelpCompression :: String +optimizeHelpCompression = "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++ "storage (and download) size. In exceptional circumstances, it may be\n" ++ "preferable to avoid compression. In this case the `--dont-compress'\n" ++ @@ -196,8 +171,8 @@ "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++ "extension on patch files even when uncompressed.\n" -optimize_compression :: [DarcsFlag] -> IO () -optimize_compression opts = do +optimizeCompression :: [DarcsFlag] -> IO () +optimizeCompression opts = do putStrLn "Optimizing (un)compression of patches..." do_compress (darcsdir++"/patches") putStrLn "Optimizing (un)compression of inventories..." @@ -213,8 +188,8 @@ notdot ('.':_) = False notdot _ = True -optimize_help_relink :: String -optimize_help_relink = +optimizeHelpRelink :: String +optimizeHelpRelink = "The `darcs optimize --relink' command hard-links patches that the\n" ++ "current repository has in common with its peers. Peers are those\n" ++ "repositories listed in _darcs/prefs/sources, or defined with the\n" ++ @@ -229,10 +204,24 @@ "generally SHOULD NOT be used. It results in a relatively small space\n" ++ "saving at the cost of making many Darcs commands MUCH slower.\n" -do_relink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () -do_relink opts repository = +doOptimizePristine :: RepoPatch p => Repository p -> IO () +doOptimizePristine repo = do + hashed <- doesFileExist $ "_darcs" "hashed_inventory" + when hashed $ do + inv <- BS.readFile ("_darcs" "hashed_inventory") + let linesInv = BS.split '\n' inv + case linesInv of + [] -> return () + (pris_line:_) -> + let size = decodeDarcsSize $ BS.drop 9 pris_line + in when (isJust size) $ do putStrLn "Optimizing hashed pristine..." + readRecorded repo >>= replacePristine repo + cleanRepository repo + +doRelink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () +doRelink opts repository = do some_siblings <- return (flagsToSiblings opts) - defrepolist <- get_preflist "defaultrepo" + defrepolist <- getPreflist "defaultrepo" siblings <- return (map toFilePath some_siblings ++ defrepolist) if (siblings == []) then putStrLn "No siblings -- no relinking done." @@ -281,7 +270,7 @@ \begin{code} -- FIXME: someone needs to grovel through the source and determine --- just how optimizeInventory differs from do_reorder. The following +-- just how optimizeInventory differs from doReorder. The following -- is purely speculation. --twb, 2009-04 -- optimize_help_reorder :: String -- optimize_help_reorder = @@ -289,26 +278,88 @@ -- "of the default optimization. It reorders patches with respect to ALL\n" ++ -- "tags, rather than just the latest tag.\n" -do_reorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () -do_reorder opts _ | not (Reorder `elem` opts) = return () -do_reorder opts repository = do +doReorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () +doReorder opts _ | not (Reorder `elem` opts) = return () +doReorder opts repository = do debugMessage "Reordering the inventory." - psnew <- choose_order `fmap` read_repo repository + psnew <- chooseOrder `fmap` read_repo repository let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew withGutsOf repository $ do tentativelyReplacePatches repository opts ps finalizeRepositoryChanges repository debugMessage "Done reordering the inventory." -choose_order :: RepoPatch p => PatchSet p -> PatchSet p -choose_order ps | isJust last_tag = +chooseOrder :: RepoPatch p => PatchSet p -> PatchSet p +chooseOrder ps | isJust last_tag = case slightly_optimize_patchset $ unsafeUnseal $ get_patches_in_tag lt ps of ((t:<:NilRL):<:pps) -> case get_patches_beyond_tag lt ps of - FlippedSeal (p :<: NilRL) -> (p+<+(t:<:NilRL)) :<: pps - _ -> impossible + FlippedSeal p -> (p+<+(t:<:NilRL)) :<: pps _ -> impossible - where last_tag = case filter is_tag $ mapRL info $ concatRL ps of + where last_tag = case filter isTag $ mapRL info $ concatRL ps of (t:_) -> Just t _ -> Nothing lt = fromJust last_tag -choose_order ps = ps +chooseOrder ps = ps +\end{code} + +The \verb|--upgrade| option for \verb!darcs optimize! performs an inplace +upgrade of your repository to the lastest \emph{compatible} format. Right now +means that darcs 1 old-fashioned repositories will be upgraded to darcs-1 +hashed repositories (and notably, not to darcs 2 repositories as that would not +be compatible; see \verb!darcs convert!). + +\begin{code} +optimizeUpgradeFormat :: IO () +optimizeUpgradeFormat = do + debugMessage $ "Upgrading to hashed..." + rf <- either fail return =<< identifyRepoFormat "." + debugMessage $ "Found our format" + if formatHas HashedInventory rf + then putStrLn "No action taken because this repository already is hashed." + else do putStrLn "Checking repository in case of corruption..." + withRepoLock [] $- \repository -> do + state <- replayRepository repository [] return + case state of + RepositoryConsistent -> do + putStrLn "The repository is consistent." + actuallyUpgradeFormat repository + _repoIsBroken -> + putStrLn "Corruption detected! Please run darcs repair first." + +actuallyUpgradeFormat :: RepoPatch p => Repository p C(r u t) -> IO () +actuallyUpgradeFormat repository = do + -- convert patches/inventory + patches <- read_repo repository + let k = "Hashing patch" + beginTedious k + tediousSize k (lengthRL $ concatRL patches) + let patches' = mapRL_RL (mapRL_RL (progress k)) patches + cache <- getCaches [] "." + let compr = compression [] -- default compression + HashedRepo.write_tentative_inventory cache compr patches' + endTedious k + -- convert pristine by applying patches + -- the faster alternative would be to copy pristine, but the apply method is more reliable + let patchesToApply = progressFL "Applying patch" $ reverseRL $ concatRL $ patches' + createDirectoryIfMissing False $ darcsdir hashedDir HashedPristineDir + writeFile (darcsdir hashedDir HashedPristineDir sha1PS B.empty) "" + sequence_ $ mapFL (HashedRepo.apply_to_tentative_pristine cache []) $ bunchFL 100 patchesToApply + -- now make it official + HashedRepo.finalize_tentative_changes repository compr + writeRepoFormat (createRepoFormat [UseHashedInventory]) (darcsdir "format") + -- clean out old-fashioned junk + debugMessage "Cleaning out old-fashioned repository files..." + removeFile $ darcsdir "inventory" + removeFile $ darcsdir "tentative_inventory" + rm_recursive (darcsdir "pristine") `catchall` rm_recursive (darcsdir "current") + rmGzsIn (darcsdir "patches") + rmGzsIn (darcsdir "inventories") + let checkpointDir = darcsdir "checkpoints" + hasCheckPoints <- doesDirectoryExist checkpointDir + when hasCheckPoints $ rm_recursive checkpointDir + putStrLn "Done upgrading!" + where + rmGzsIn dir = + withCurrentDirectory dir $ do + gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "." + mapM_ removeFile gzs \end{code} diff --git a/src/Darcs/Commands/Pull.lhs b/src/Darcs/Commands/Pull.lhs --- a/src/Darcs/Commands/Pull.lhs +++ b/src/Darcs/Commands/Pull.lhs @@ -26,47 +26,48 @@ import Control.Monad ( when ) import Data.List ( nub ) -import Darcs.Commands ( DarcsCommand(..), loggers ) +import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo ) import Darcs.CommandsAux ( check_paths ) -import Darcs.Arguments ( DarcsFlag( Verbose, Quiet, DryRun, MarkConflicts, XMLOutput, - Intersection, Complement, AllowConflicts, NoAllowConflicts ), +import Darcs.Arguments ( DarcsFlag( Verbose, DryRun, MarkConflicts, + Intersection, Complement, AllowConflicts, + NoAllowConflicts ), nocompress, ignoretimes, definePatches, - deps_sel, pull_conflict_options, use_external_merge, - match_several, fixUrl, - all_interactive, repo_combinator, - print_dry_run_message_and_exit, - test, dry_run, - set_default, summary, working_repo_dir, remote_repo, - set_scripts_executable, nolinks, - network_options, umask_option, allow_unrelated_repos, restrict_paths + depsSel, pullConflictOptions, useExternalMerge, + matchSeveral, fixUrl, + allInteractive, repoCombinator, + printDryRunMessageAndExit, + test, dryRun, + setDefault, summary, workingRepoDir, remoteRepo, + setScriptsExecutableOption, nolinks, + networkOptions, umaskOption, allowUnrelatedRepos, restrictPaths ) import Darcs.Repository ( Repository, SealedPatchSet, identifyRepositoryFor, withGutsOf, amInRepository, withRepoLock, ($-), tentativelyMergePatches, - sync_repo, finalizeRepositoryChanges, applyToWorking, - read_repo, checkUnrelatedRepos ) + finalizeRepositoryChanges, applyToWorking, + read_repo, checkUnrelatedRepos, invalidateIndex ) import Darcs.Hopefully ( info ) import Darcs.Patch ( RepoPatch, description ) -import Darcs.Ordered ( (:>)(..), (:\/:)(..), RL(..), unsafeUnRL, concatRL, +import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), RL(..), mapFL, nullFL, reverseRL, mapRL ) import Darcs.Patch.Permutations ( partitionFL ) -import Darcs.SlurpDirectory ( wait_a_moment ) -import Darcs.Repository.Prefs ( add_to_preflist, defaultrepo, set_defaultrepo, get_preflist ) +import Darcs.Repository.Prefs ( addToPreflist, defaultrepo, setDefaultrepo, getPreflist ) import Darcs.Repository.Motd (show_motd ) import Darcs.Patch.Depends ( get_common_and_uncommon, patchset_intersection, patchset_union ) -import Darcs.SelectChanges ( with_selected_changes ) -import Darcs.Utils ( clarify_errors, formatPath ) -import Darcs.Sealed ( Sealed(..), seal ) +import Darcs.SelectChanges ( with_selected_changes, filterOutConflicts ) +import Darcs.Utils ( clarifyErrors, formatPath ) +import Darcs.Witnesses.Sealed ( Sealed(..), seal ) import Printer ( putDocLn, vcat, ($$), text ) -import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -pull_description :: String -pull_description = +#include "gadts.h" + +pullDescription :: String +pullDescription = "Copy and apply patches from another repository to this one." -pull_help :: String -pull_help = +pullHelp :: String +pullHelp = "Pull is used to bring changes made in another repository into the current\n"++ "repository (that is, either the one in the current directory, or the one\n"++ "specified with the --repodir option). Pull allows you to bring over all or\n"++ @@ -76,99 +77,99 @@ "recently either pushed or pulled.\n" pull :: DarcsCommand -pull = DarcsCommand {command_name = "pull", - command_help = pull_help, - command_description = pull_description, - command_extra_args = -1, - command_extra_arg_help = ["[REPOSITORY]..."], - command_command = pull_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = get_preflist "repos", - command_argdefaults = defaultrepo, - command_advanced_options = [repo_combinator, +pull = DarcsCommand {commandName = "pull", + commandHelp = pullHelp, + commandDescription = pullDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[REPOSITORY]..."], + commandCommand = pullCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = getPreflist "repos", + commandArgdefaults = defaultrepo, + commandAdvancedOptions = [repoCombinator, nocompress, nolinks, ignoretimes, - remote_repo, - set_scripts_executable, - umask_option, - restrict_paths] ++ - network_options, - command_basic_options = [match_several, - all_interactive, - pull_conflict_options, - use_external_merge, - test]++dry_run++[summary, - deps_sel, - set_default, - working_repo_dir, - allow_unrelated_repos]} - -pull_cmd :: [DarcsFlag] -> [String] -> IO () + remoteRepo, + setScriptsExecutableOption, + umaskOption, + restrictPaths] ++ + networkOptions, + commandBasicOptions = [matchSeveral, + allInteractive, + pullConflictOptions, + useExternalMerge, + test]++dryRun++[summary, + depsSel, + setDefault, + workingRepoDir, + allowUnrelatedRepos]} -pull_cmd opts unfixedrepodirs@(_:_) = - let (logMessage, _, logDocLn) = loggers opts - putInfo = if (Quiet `elem` opts || XMLOutput `elem` opts) then \_ -> return () else logDocLn - putVerbose = if Verbose `elem` opts then putDocLn else \_ -> return () - in withRepoLock opts $- \repository -> do +pullCmd :: [DarcsFlag] -> [String] -> IO () +pullCmd opts unfixedrepodirs@(_:_) = withRepoLock opts $- \repository -> do here <- getCurrentDirectory repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts) unfixedrepodirs -- Test to make sure we aren't trying to pull from the current repo when (null repodirs) $ fail "Can't pull from current repository!" - (Sealed them, Sealed compl) <- read_repos repository opts repodirs - old_default <- get_preflist "defaultrepo" - set_defaultrepo (head repodirs) opts - mapM_ (add_to_preflist "repos") repodirs + (Sealed them, Sealed compl) <- readRepos repository opts repodirs + old_default <- getPreflist "defaultrepo" + setDefaultrepo (head repodirs) opts + mapM_ (addToPreflist "repos") repodirs when (old_default == repodirs) $ let pulling = if DryRun `elem` opts then "Would pull" else "Pulling" - in putInfo $ text $ pulling++" from "++concatMap formatPath repodirs++"..." + in putInfo opts $ text $ pulling++" from "++concatMap formatPath repodirs++"..." mapM_ (show_motd opts) repodirs us <- read_repo repository (common, us' :\/: them'') <- return $ get_common_and_uncommon (us, them) (_ , _ :\/: compl') <- return $ get_common_and_uncommon (us, compl) checkUnrelatedRepos opts common us them - let avoided = mapRL info (concatRL compl') - ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $ reverseRL $ concatRL them'' + let avoided = mapRL info compl' + ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $ reverseRL them'' do when (Verbose `elem` opts) $ do case us' of - (x@(_:<:_):<:_) -> putDocLn $ text "We have the following new (to them) patches:" - $$ (vcat $ mapRL description x) + (x@(_:<:_)) -> putDocLn $ text "We have the following new (to them) patches:" + $$ (vcat $ mapRL description x) _ -> return () when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:" - $$ (vcat $ mapFL description ps) - when (nullFL ps) $ do putInfo $ text "No remote changes to pull in!" - definePatches ps + $$ (vcat $ mapFL description ps) + let merge_opts | NoAllowConflicts `elem` opts = opts + | AllowConflicts `elem` opts = opts + | otherwise = MarkConflicts : opts + (hadConflicts, Sealed psFiltered) <- filterOutConflicts merge_opts us' repository ps + when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts." + when (nullFL psFiltered) + $ do putInfo opts $ text "No remote changes to pull in!" + definePatches psFiltered exitWith ExitSuccess - with_selected_changes "pull" opts ps $ - \ (to_be_pulled:>_) -> do - print_dry_run_message_and_exit "pull" opts to_be_pulled - definePatches to_be_pulled - when (nullFL to_be_pulled) $ do - logMessage "You don't want to pull any patches, and that's fine with me!" - exitWith ExitSuccess - check_paths opts to_be_pulled - putVerbose $ text "Getting and merging the following patches:" - putVerbose $ vcat $ mapFL description to_be_pulled - let merge_opts | NoAllowConflicts `elem` opts = opts - | AllowConflicts `elem` opts = opts - | otherwise = MarkConflicts : opts - Sealed pw <- tentativelyMergePatches repository "pull" merge_opts - (reverseRL $ head $ unsafeUnRL us') to_be_pulled - invalidateIndex repository - withGutsOf repository $ do finalizeRepositoryChanges repository - -- so work will be more recent than rec: - revertable $ do wait_a_moment - applyToWorking repository opts pw - sync_repo repository - putInfo $ text "Finished pulling and applying." - where revertable x = x `clarify_errors` unlines - ["Error applying patch to the working directory.","", - "This may have left your working directory an inconsistent", - "but recoverable state. If you had no un-recorded changes", - "by using 'darcs revert' you should be able to make your", - "working directory consistent again."] -pull_cmd _ [] = fail "No default repository to pull from, please specify one" + with_selected_changes "pull" opts Nothing psFiltered $ + \ (to_be_pulled:>_) -> + do + printDryRunMessageAndExit "pull" opts to_be_pulled + definePatches to_be_pulled + when (nullFL to_be_pulled) $ do + putStrLn "You don't want to pull any patches, and that's fine with me!" + exitWith ExitSuccess + check_paths opts to_be_pulled + putVerbose opts $ text "Getting and merging the following patches:" + putVerbose opts $ vcat $ mapFL description to_be_pulled + Sealed pw <- tentativelyMergePatches repository "pull" merge_opts + (reverseRL us') to_be_pulled + invalidateIndex repository + withGutsOf repository $ do finalizeRepositoryChanges repository + revertable $ applyToWorking repository opts pw + putInfo opts $ text "Finished pulling and applying." +pullCmd _ [] = fail "No default repository to pull from, please specify one" + +revertable :: IO a -> IO a +revertable x = + x `clarifyErrors` unlines + ["Error applying patch to the working directory.","", + "This may have left your working directory an inconsistent", + "but recoverable state. If you had no un-recorded changes", + "by using 'darcs revert' you should be able to make your", + "working directory consistent again."] + {- Read in the specified pull-from repositories. Perform Intersection, Union, or Complement read. In patch-theory terms (stated in set algebra, where + is union and & is intersection @@ -182,14 +183,14 @@ R1 = 1st specified pull repo R2, R3, Rn = other specified pull repo -Since Rc is not provided here yet, the result of read_repos is a +Since Rc is not provided here yet, the result of readRepos is a tuple: the first patchset(s) to be complemented against Rc and then the second patchset(s) to be complemented against Rc. -} -read_repos :: RepoPatch p => Repository p -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p) -read_repos _ _ [] = impossible -read_repos to_repo opts us = +readRepos :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p) +readRepos _ _ [] = impossible +readRepos to_repo opts us = do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u ps <- read_repo r return $ seal ps) us diff --git a/src/Darcs/Commands/Push.lhs b/src/Darcs/Commands/Push.lhs --- a/src/Darcs/Commands/Push.lhs +++ b/src/Darcs/Commands/Push.lhs @@ -18,166 +18,173 @@ \darcsCommand{push} \begin{code} {-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TypeOperators #-} module Darcs.Commands.Push ( push ) where import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) ) import Control.Monad ( when ) import Data.Char ( toUpper ) import Workaround ( getCurrentDirectory ) -import Darcs.Commands ( DarcsCommand(..) ) -import Darcs.Arguments ( DarcsFlag( DryRun, Verbose, Quiet, Sign, SignAs, NoSign, SignSSL ), +import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo, abortRun ) +import Darcs.Arguments ( DarcsFlag( DryRun, Sign, SignAs, NoSign, SignSSL ), definePatches, - working_repo_dir, summary, - print_dry_run_message_and_exit, - applyas, match_several, fixUrl, deps_sel, - all_interactive, dry_run, nolinks, - remote_repo, network_options, - set_default, sign, allow_unrelated_repos + workingRepoDir, summary, + printDryRunMessageAndExit, + applyas, matchSeveral, fixUrl, depsSel, + allInteractive, dryRun, nolinks, + remoteRepo, networkOptions, + setDefault, sign, allowUnrelatedRepos ) -import Darcs.Hopefully ( hopefully ) -import Darcs.Repository ( withRepoReadLock, ($-), identifyRepositoryFor, +import Darcs.Hopefully ( PatchInfoAnd, hopefully ) +import Darcs.Repository ( Repository, withRepoReadLock, ($-), identifyRepositoryFor, read_repo, amInRepository, checkUnrelatedRepos ) -import Darcs.Patch ( description ) -import Darcs.Ordered ( RL(..), (:>)(..), (:\/:)(..), - nullFL, reverseRL, mapFL_FL, unsafeUnRL, mapRL, lengthRL ) -import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist ) +import Darcs.Patch ( RepoPatch, description ) +import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), RL, FL, nullRL, + nullFL, reverseRL, mapFL_FL, mapRL, lengthRL ) +import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist ) import Darcs.External ( maybeURLCmd, signString ) import Darcs.URL ( is_url, is_file ) import Darcs.SelectChanges ( with_selected_changes ) import Darcs.Utils ( formatPath ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.Patch.Bundle ( make_bundle ) -import Printer ( vcat, empty, text, ($$), (<+>), putDocLn, errorDoc ) +import Darcs.Patch.Patchy( ShowPatch ) +import Darcs.Patch.Info ( PatchInfo ) +import Darcs.Patch.Set ( PatchSet ) +import Printer ( Doc, vcat, empty, text, ($$) ) import Darcs.RemoteApply ( remote_apply, apply_as ) import Darcs.Email ( make_email ) import English (englishNum, Noun(..)) #include "impossible.h" -push_description :: String -push_description = +#include "gadts.h" + +pushDescription :: String +pushDescription = "Copy and apply patches from this repository to another one." -push_help :: String -push_help = +pushHelp :: String +pushHelp = "Push is the opposite of pull. Push allows you to copy changes from the\n"++ "current repository into another repository.\n" push :: DarcsCommand -push = DarcsCommand {command_name = "push", - command_help = push_help, - command_description = push_description, - command_extra_args = 1, - command_extra_arg_help = ["[REPOSITORY]"], - command_command = push_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = get_preflist "repos", - command_argdefaults = defaultrepo, - command_advanced_options = [applyas, +push = DarcsCommand {commandName = "push", + commandHelp = pushHelp, + commandDescription = pushDescription, + commandExtraArgs = 1, + commandExtraArgHelp = ["[REPOSITORY]"], + commandCommand = pushCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = getPreflist "repos", + commandArgdefaults = defaultrepo, + commandAdvancedOptions = [applyas, nolinks, - remote_repo] ++ - network_options, - command_basic_options = [match_several, deps_sel, - all_interactive, - sign]++dry_run++[summary, - working_repo_dir, - set_default, - allow_unrelated_repos]} + remoteRepo] ++ + networkOptions, + commandBasicOptions = [matchSeveral, depsSel, + allInteractive, + sign]++dryRun++[summary, + workingRepoDir, + setDefault, + allowUnrelatedRepos]} -push_cmd :: [DarcsFlag] -> [String] -> IO () -push_cmd opts [""] = push_cmd opts [] -push_cmd opts [unfixedrepodir] = - let am_verbose = Verbose `elem` opts - am_quiet = Quiet `elem` opts - putVerbose s = when am_verbose $ putDocLn s - putInfo s = when (not am_quiet) $ putDocLn s - in +pushCmd :: [DarcsFlag] -> [String] -> IO () +pushCmd _ [""] = impossible +pushCmd opts [unfixedrepodir] = do repodir <- fixUrl opts unfixedrepodir -- Test to make sure we aren't trying to push to the current repo here <- getCurrentDirectory + checkOptionsSanity opts repodir when (repodir == here) $ fail "Cannot push from repository to itself." -- absolute '.' also taken into account by fix_filepath - (bundle,num_to_pull) <- withRepoReadLock opts $- \repository -> do - if is_url repodir then do - when (apply_as opts /= Nothing) $ - let msg = text "Cannot --apply-as when pushing to URLs" in - if DryRun `elem` opts - then putInfo $ text "NOTE: " <+> msg - $$ text "" - else errorDoc msg - maybeapply <- maybeURLCmd "APPLY" repodir - when (maybeapply == Nothing) $ - let lprot = takeWhile (/= ':') repodir - prot = map toUpper lprot - msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++ - "You may be able to hack this to work"++ - " using DARCS_APPLY_"++prot) in - if DryRun `elem` opts - then putInfo $ text "NOTE:" <+> msg - $$ text "" - else errorDoc msg - else do - when (want_sign opts) $ - let msg = text "Signing doesn't make sense for local repositories or when pushing over ssh." - in if DryRun `elem` opts - then putInfo $ text "NOTE:" <+> msg - else errorDoc msg + (bundle) <- withRepoReadLock opts $- + prepareBundle opts repodir + sbundle <- signString opts bundle + let body = if is_file repodir + then sbundle + else make_email repodir [] Nothing sbundle Nothing + rval <- remote_apply opts repodir body + case rval of ExitFailure ec -> do putStrLn $ "Apply failed!" + exitWith (ExitFailure ec) + ExitSuccess -> putInfo opts $ text "Push successful." +pushCmd _ _ = impossible + +prepareBundle :: forall p C(r u t) . (RepoPatch p) => [DarcsFlag] -> String -> Repository p C(r u t) -> + IO (Doc) +prepareBundle opts repodir repository = do them <- identifyRepositoryFor repository repodir >>= read_repo - old_default <- get_preflist "defaultrepo" - set_defaultrepo repodir opts + old_default <- getPreflist "defaultrepo" + setDefaultrepo repodir opts when (old_default == [repodir]) $ let pushing = if DryRun `elem` opts then "Would push" else "Pushing" - in putInfo $ text $ pushing++" to "++formatPath repodir++"..." + in putInfo opts $ text $ pushing++" to "++formatPath repodir++"..." us <- read_repo repository case get_common_and_uncommon (us, them) of (common, us' :\/: them') -> do - checkUnrelatedRepos opts common us them - putVerbose $ text "We have the following patches to push:" - $$ (vcat $ mapRL description $ head $ unsafeUnRL us') - firstUs <- case us' of - NilRL:<:NilRL -> do putInfo $ text "No recorded local changes to push!" - exitWith ExitSuccess - NilRL -> bug "push_cmd: us' is empty!" - (x:<:_) -> return x - with_selected_changes "push" opts (reverseRL firstUs) $ - \ (to_be_pushed:>_) -> do + prePushChatter opts common us us' them them' + with_selected_changes "push" opts Nothing (reverseRL us') $ bundlePatches opts common + +prePushChatter :: forall p a C(x y t) . (ShowPatch a) => + [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> + RL a C(t x) -> PatchSet p C(y) -> RL a C(t y) -> IO () +prePushChatter opts common us us' them them' = do + checkUnrelatedRepos opts common us them + let num_to_pull = lengthRL them' + let pull_reminder = if num_to_pull > 0 + then text $ "The remote repository has " ++ show num_to_pull + ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull." + else empty + putVerbose opts $ text "We have the following patches to push:" $$ (vcat $ mapRL description us') + when (not $ nullRL us') $ do putInfo opts $ pull_reminder + when (nullRL us') $ do putInfo opts $ text "No recorded local changes to push!" + exitWith ExitSuccess + +bundlePatches :: forall t p C(x y z w). RepoPatch p => [DarcsFlag] -> [PatchInfo] + -> (FL (PatchInfoAnd p) :> t) C(z w) + -> IO (Doc) +bundlePatches opts common (to_be_pushed :> _) = + do definePatches to_be_pushed - print_dry_run_message_and_exit "push" opts to_be_pushed + printDryRunMessageAndExit "push" opts to_be_pushed when (nullFL to_be_pushed) $ do - putInfo $ + putInfo opts $ text "You don't want to push any patches, and that's fine with me!" exitWith ExitSuccess - let num_to_pull = lengthRL $ head $ unsafeUnRL them' - bundle = make_bundle [] + bundle <- make_bundle [] (bug "using slurpy in make_bundle called from Push") common (mapFL_FL hopefully to_be_pushed) - return (bundle, num_to_pull) - sbundle <- signString opts bundle - let body = if is_file repodir - then sbundle - else make_email repodir [] Nothing sbundle Nothing - rval <- remote_apply opts repodir body - let pull_reminder = - if num_to_pull > 0 - then text $ "(By the way, the remote repository has " ++ show num_to_pull ++ " " - ++ englishNum num_to_pull (Noun "patch") " to pull.)" - else empty - case rval of ExitFailure ec -> do putStrLn $ "Apply failed!" - exitWith (ExitFailure ec) - ExitSuccess -> putInfo $ text "Push successful." $$ pull_reminder - -push_cmd _ _ = impossible + return (bundle) -want_sign :: [DarcsFlag] -> Bool -want_sign opts = case opts of +wantSign :: [DarcsFlag] -> Bool +wantSign opts = case opts of [] -> False Sign:_ -> True (SignAs _):_ -> True (SignSSL _):_ -> True NoSign:_ -> False - _:opts' -> want_sign opts' + _:opts' -> wantSign opts' + + +checkOptionsSanity :: [DarcsFlag] -> String -> IO () +checkOptionsSanity opts repodir = + if is_url repodir then do + when (apply_as opts /= Nothing) $ + abortRun opts $ text "Cannot --apply-as when pushing to URLs" + maybeapply <- maybeURLCmd "APPLY" repodir + when (maybeapply == Nothing) $ + let lprot = takeWhile (/= ':') repodir + prot = map toUpper lprot + msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++ + "You may be able to hack this to work"++ + " using DARCS_APPLY_"++prot) in + abortRun opts msg + else do + when (wantSign opts) $ + abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh." + \end{code} For obvious reasons, you can only push to repositories to which you have diff --git a/src/Darcs/Commands/Put.lhs b/src/Darcs/Commands/Put.lhs --- a/src/Darcs/Commands/Put.lhs +++ b/src/Darcs/Commands/Put.lhs @@ -8,38 +8,38 @@ import Control.Monad ( when ) import Data.Maybe ( catMaybes ) import System.Directory ( createDirectory ) -import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, - UseFormat2, UseHashedInventory, UseOldFashionedInventory ), - applyas, match_one_context, fixUrl, - network_options, flagToString, get_inventory_choices, - set_scripts_executable, working_repo_dir, set_default +import Storage.Hashed.Tree( emptyTree ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, putVerbose, putInfo ) +import Darcs.Arguments ( DarcsFlag( UseFormat2, UseHashedInventory, UseOldFashionedInventory ), + applyas, matchOneContext, fixUrl, + networkOptions, flagToString, getInventoryChoices, + setScriptsExecutableOption, workingRepoDir, setDefault ) import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository ) import Darcs.Repository.Format ( identifyRepoFormat, - RepoProperty ( Darcs2, HashedInventory ), format_has ) + RepoProperty ( Darcs2, HashedInventory ), formatHas ) import Darcs.Patch.Bundle ( make_bundle2 ) -import Darcs.Ordered ( FL(..) ) -import Darcs.Match ( have_patchset_match, get_one_patchset ) -import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo ) +import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Match ( havePatchsetMatch, getOnePatchset ) +import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo ) import Darcs.URL ( is_url, is_file ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) -import Darcs.SlurpDirectory ( empty_slurpy ) import Darcs.External ( execSSH ) import Darcs.RemoteApply ( remote_apply ) import Darcs.Commands.Init ( initialize ) import Darcs.Email ( make_email ) -import Darcs.Sealed ( Sealed(..), seal ) +import Darcs.Witnesses.Sealed ( Sealed(..), seal ) +import Printer ( text ) #include "impossible.h" -put_description :: String -put_description = +putDescription :: String +putDescription = "Makes a copy of the repository" -put_help :: String -put_help = +putHelp :: String +putHelp = "The `darcs put' command creates a copy of the current repository. It\n" ++ "is currently very inefficient, so when creating local copies you\n" ++ "should use `darcs get . x' instead of `darcs put x'.\n" ++ @@ -50,27 +50,23 @@ "appropriate. See those commands for an explanation of each option.\n" put ::DarcsCommand -put = DarcsCommand {command_name = "put", - command_help = put_help, - command_description = put_description, - command_extra_args = 1, - command_extra_arg_help = [""], - command_command = put_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = get_preflist "repos", - command_argdefaults = nodefaults, - command_advanced_options = [applyas] ++ network_options, - command_basic_options = [match_one_context, set_scripts_executable, - get_inventory_choices, - set_default, working_repo_dir]} +put = DarcsCommand {commandName = "put", + commandHelp = putHelp, + commandDescription = putDescription, + commandExtraArgs = 1, + commandExtraArgHelp = [""], + commandCommand = putCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = getPreflist "repos", + commandArgdefaults = nodefaults, + commandAdvancedOptions = [applyas] ++ networkOptions, + commandBasicOptions = [matchOneContext, setScriptsExecutableOption, + getInventoryChoices, + setDefault, workingRepoDir]} -put_cmd :: [DarcsFlag] -> [String] -> IO () -put_cmd _ [""] = fail "Empty repository argument given to put." -put_cmd opts [unfixedrepodir] = - let am_quiet = Quiet `elem` opts - putInfo s = when (not am_quiet) $ putStrLn s - putVerbose = when (Verbose `elem` opts) . putStrLn - in +putCmd :: [DarcsFlag] -> [String] -> IO () +putCmd _ [""] = fail "Empty repository argument given to put." +putCmd opts [unfixedrepodir] = do repodir <- fixUrl opts unfixedrepodir -- Test to make sure we aren't trying to push to the current repo @@ -83,52 +79,52 @@ when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!" debugMessage "Creating repository" - putVerbose "Creating repository" + putVerbose opts $ text "Creating repository" rf_or_e <- identifyRepoFormat "." rf <- case rf_or_e of Left e -> fail e Right x -> return x - let initopts = if format_has Darcs2 rf + let initopts = if formatHas Darcs2 rf then UseFormat2:filter (/= UseOldFashionedInventory) opts - else if format_has HashedInventory rf && + else if formatHas HashedInventory rf && not (UseOldFashionedInventory `elem` opts) then UseHashedInventory:filter (/= UseFormat2) opts else UseOldFashionedInventory:filter (/= UseFormat2) opts if is_file req_absolute_repo_dir then do createDirectory req_absolute_repo_dir - withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts [] + withCurrentDirectory req_absolute_repo_dir $ (commandCommand initialize) initopts [] else do -- is_ssh req_absolute_repo_dir remoteInit req_absolute_repo_dir initopts withCurrentDirectory cur_absolute_repo_dir $ withRepoReadLock opts $- \repository -> do - set_defaultrepo req_absolute_repo_dir opts - Sealed patchset <- if have_patchset_match opts - then get_one_patchset repository opts -- todo: make sure get_one_patchset has the right type + setDefaultrepo req_absolute_repo_dir opts + Sealed patchset <- if havePatchsetMatch opts + then getOnePatchset repository opts -- todo: make sure getOnePatchset has the right type else read_repo repository >>= (return . seal) - Sealed patchset2 <- if have_patchset_match opts - then get_one_patchset repository opts -- todo: make sure get_one_patchset has the right type + Sealed patchset2 <- if havePatchsetMatch opts + then getOnePatchset repository opts -- todo: make sure getOnePatchset has the right type else read_repo repository >>= (return . seal) let patches = patchSetToPatches patchset patches2 = patchSetToPatches patchset2 nullFL NilFL = True nullFL _ = False when (nullFL patches) $ do - putInfo "No patches were selected to put. Nothing to be done." + putInfo opts $ text "No patches were selected to put. Nothing to be done." exitWith ExitSuccess - let bundle = (make_bundle2 opts empty_slurpy [] patches patches2) - message = if is_file req_absolute_repo_dir + bundle <- make_bundle2 opts emptyTree [] patches patches2 + let message = if is_file req_absolute_repo_dir then bundle else make_email req_absolute_repo_dir [] Nothing bundle Nothing - putVerbose "Applying patches in new repository..." + putVerbose opts $ text "Applying patches in new repository..." rval <- remote_apply opts req_absolute_repo_dir message case rval of ExitFailure ec -> do putStrLn $ "Apply failed!" exitWith (ExitFailure ec) - ExitSuccess -> putInfo "Put successful." -put_cmd _ _ = impossible + ExitSuccess -> putInfo opts $ text "Put successful." +putCmd _ _ = impossible remoteInit :: FilePath -> [DarcsFlag] -> IO () remoteInit repo opts = do - let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts + let args = catMaybes $ map (flagToString $ commandBasicOptions initialize) opts command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args exitCode <- execSSH addr command when (exitCode /= ExitSuccess) $ diff --git a/src/Darcs/Commands/Record.lhs b/src/Darcs/Commands/Record.lhs --- a/src/Darcs/Commands/Record.lhs +++ b/src/Darcs/Commands/Record.lhs @@ -17,148 +17,142 @@ \darcsCommand{record} \begin{code} -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP, PatternGuards #-} -module Darcs.Commands.Record ( record, commit, get_date, get_log, file_exists ) where +module Darcs.Commands.Record ( record, commit, getDate, getLog, fileExists ) where +import qualified Ratified( hGetContents ) import Control.Exception ( handleJust, Exception( ExitException ) ) import Control.Monad ( filterM, when ) -import System.IO ( hGetContents, stdin ) +import System.IO ( stdin ) import Data.List ( sort, isPrefixOf ) import System.Exit ( exitWith, exitFailure, ExitCode(..) ) import System.IO ( hPutStrLn ) import System.Directory ( doesFileExist, doesDirectoryExist, removeFile ) import Data.Maybe ( isJust ) -import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile, removeFileMayNotExist ) +import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile ) import Darcs.Hopefully ( info, n2pia ) import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-), - get_unrecorded_in_files, - get_unrecorded_in_files_unsorted, withGutsOf, - sync_repo, read_repo, + withGutsOf, + read_repo, slurp_recorded, - tentativelyAddPatch, finalizeRepositoryChanges, - ) + tentativelyAddPatch, finalizeRepositoryChanges + , invalidateIndex, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Patch, Prim, namepatch, summary, anonymous, adddeps, fromPrims ) -import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+), +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), unsafeUnFL, unsafeCompare, reverseRL, mapFL, mapFL_FL, nullFL ) import Darcs.Patch.Info ( PatchInfo ) +import Darcs.Patch.Split ( primSplitter ) import Darcs.SlurpDirectory ( slurp_hasfile, slurp_hasdir ) -import Darcs.Patch.Choices ( patch_choices_tps, tp_patch, - force_first, get_choices, tag ) +import Darcs.Patch.Choices ( patchChoicesTps, tpPatch, + forceFirst, getChoices, tag ) import Darcs.SelectChanges ( with_selected_changes_to_files', with_selected_changes_reversed ) import Darcs.RepoPath ( FilePathLike, SubPath, sp2fn, toFilePath ) import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_stub ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandStub ) import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment, - EditLongComment, RmLogFile, LogFile, Pipe, + EditLongComment, LogFile, Pipe, PatchName, AskDeps, All ), - get_author, working_repo_dir, lookforadds, + fileHelpAuthor, + getAuthor, workingRepoDir, lookforadds, fixSubPaths, defineChanges, testByDefault, - ask_long_comment, askdeps, patch_select_flag, - all_pipe_interactive, leave_test_dir, notest, - author, patchname_option, umask_option, ignoretimes, - nocompress, rmlogfile, logfile, list_registered_files, - set_scripts_executable ) -import Darcs.Utils ( askUser, promptYorn, edit_file, clarify_errors ) + askLongComment, askdeps, patchSelectFlag, + allPipeInteractive, leaveTestDir, notest, + author, patchnameOption, umaskOption, ignoretimes, + nocompress, rmlogfile, logfile, listRegisteredFiles, + setScriptsExecutableOption ) +import Darcs.Flags (willRemoveLogFile) +import Darcs.Utils ( askUser, promptYorn, edit_file, clarifyErrors ) import Progress ( debugMessage) import Darcs.ProgressPatches( progressFL) import IsoDate ( getIsoDateTime, cleanLocalDate ) -import Printer ( hPutDocLn, text, wrap_text, ($$), renderString ) -import Darcs.Gorsvet( invalidateIndex ) +import Printer ( hPutDocLn, text, wrap_text, ($$) ) #include "impossible.h" -record_description :: String -record_description = - "Save changes in the working copy to the repository as a patch." -\end{code} +recordDescription :: String +recordDescription = "Create a patch from unrecorded changes." -If you provide one or more files or directories as additional arguments -to record, you will only be prompted to changes in those files or -directories. -\begin{code} -record_help :: String -record_help = renderString $ wrap_text 80 $ - "Record is used to name a set of changes and record the patch to the "++ - "repository." +recordHelp :: String +recordHelp = + "The `darcs record' command is used to create a patch from changes in\n" ++ + "the working tree. If you specify a set of files and directories,\n" ++ + "changes to other files will be skipped.\n" ++ + "\n" ++ recordHelp' ++ + "\n" ++ recordHelp'' record :: DarcsCommand -record = DarcsCommand {command_name = "record", - command_help = record_help, - command_description = record_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_command = record_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [logfile, rmlogfile, +record = DarcsCommand {commandName = "record", + commandHelp = recordHelp, + commandDescription = recordDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = recordCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [logfile, rmlogfile, nocompress, ignoretimes, - umask_option, - set_scripts_executable], - command_basic_options = [patchname_option, author, + umaskOption, + setScriptsExecutableOption], + commandBasicOptions = [patchnameOption, author, notest, - leave_test_dir, - all_pipe_interactive, + leaveTestDir, + allPipeInteractive, askdeps, - ask_long_comment, + askLongComment, lookforadds, - working_repo_dir]} + workingRepoDir]} -commit_description :: String -commit_description = - "Does not actually do anything, but offers advice on saving changes" +commitDescription :: String +commitDescription = "Redirect the user to record, push or send." -commit_help :: String -commit_help = +commitHelp :: String +commitHelp = "This command does not do anything.\n"++ "If you want to save changes locally, use the `darcs record' command.\n"++ "If you want to save a recorded patch to another repository, use the\n"++ "`darcs push' or `darcs send' commands instead.\n" commit :: DarcsCommand -commit = command_stub "commit" commit_help commit_description record +commit = commandStub "commit" commitHelp commitDescription record -file_exists :: Slurpy -> SubPath -> IO Bool -file_exists s rp = do file <- doesFileExist fp +fileExists :: Slurpy -> SubPath -> IO Bool +fileExists s rp = do file <- doesFileExist fp dir <- doesDirectoryExist fp return (file || dir || slurp_hasfile (sp2fn rp) s || slurp_hasdir (sp2fn rp) s) where fp = toFilePath rp -record_cmd :: [DarcsFlag] -> [String] -> IO () -record_cmd opts args = do - check_name_is_not_option opts - let (logMessage,_, _) = loggers opts +recordCmd :: [DarcsFlag] -> [String] -> IO () +recordCmd opts args = do + checkNameIsNotOption opts withRepoLock (testByDefault opts) $- \repository -> do rec <- if null args then return empty_slurpy else slurp_recorded repository files <- sort `fmap` fixSubPaths opts args let non_repo_files = if null files && (not $ null args) then args else [] - existing_files <- filterM (file_exists rec) files - non_existent_files <- filterM (fmap not . file_exists rec) files + existing_files <- filterM (fileExists rec) files + non_existent_files <- filterM (fmap not . fileExists rec) files when (not $ null existing_files) $ - logMessage $ "Recording changes in "++unwords (map show existing_files)++":\n" + putStrLn $ "Recording changes in "++unwords (map show existing_files)++":\n" when (not $ null non_existent_files) $ - logMessage $ "Non existent files or directories: "++unwords (map show non_existent_files)++"\n" + putStrLn $ "Non existent files or directories: "++unwords (map show non_existent_files)++"\n" when (((not $ null non_existent_files) || (not $ null non_repo_files)) && null existing_files) $ fail "None of the files you specified exist!" debugMessage "About to get the unrecorded changes." - let existing_fns = map sp2fn existing_files - changes <- if All `elem` opts then get_unrecorded_in_files_unsorted repository existing_fns - else get_unrecorded_in_files repository existing_fns + changes <- unrecordedChanges opts repository files debugMessage "I've gotten unrecorded." case allow_empty_with_askdeps changes of - Nothing -> do when (Pipe `elem` opts) $ do get_date opts + Nothing -> do when (Pipe `elem` opts) $ do getDate opts return () if ((not $ null existing_files) || (not $ null non_existent_files)) - then logMessage "No changes in selected files or directories!" - else logMessage "No changes!" - Just ch -> do_record repository opts existing_files ch + then putStrLn "No changes in selected files or directories!" + else putStrLn "No changes!" + Just ch -> doRecord repository opts existing_files ch where allow_empty_with_askdeps NilFL | AskDeps `elem` opts = Just NilFL | otherwise = Nothing @@ -166,10 +160,9 @@ -- check that what we treat as the patch name is not accidentally a command -- line flag -check_name_is_not_option :: [DarcsFlag] -> IO () -check_name_is_not_option opts = do - let (logMessage, _, _) = loggers opts - patchNames = [n | PatchName n <- opts] +checkNameIsNotOption :: [DarcsFlag] -> IO () +checkNameIsNotOption opts = do + let patchNames = [n | PatchName n <- opts] when (length patchNames == 1) $ do let n = head patchNames oneLetterName = length n == 1 || (length n == 2 && head n == '-') @@ -180,45 +173,45 @@ case yorn of 'y' -> return () 'n' -> do - logMessage "Okay, aborting the record." + putStrLn "Okay, aborting the record." exitFailure _ -> keepAsking keepAsking else return () -do_record :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO () -do_record repository opts files ps = do +doRecord :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO () +doRecord repository opts files ps = do let make_log = world_readable_temp "darcs-record" - date <- get_date opts - my_author <- get_author opts + date <- getDate opts + my_author <- getAuthor opts debugMessage "I'm slurping the repository." debugMessage "About to select changes..." - with_selected_changes_to_files' "record" opts + with_selected_changes_to_files' "record" opts (Just primSplitter) (map toFilePath files) ps $ \ (chs:>_) -> do when (is_empty_but_not_askdeps chs) $ do putStrLn "Ok, if you don't want to record anything, that's fine!" exitWith ExitSuccess - handleJust only_successful_exits (\_ -> return ()) $ + handleJust onlySuccessfulExits (\_ -> return ()) $ do deps <- if AskDeps `elem` opts - then ask_about_depends repository chs opts + then askAboutDepends repository chs opts else return [] when (AskDeps `elem` opts) $ debugMessage "I've asked about dependencies." if nullFL chs && null deps then putStrLn "Ok, if you don't want to record anything, that's fine!" else do defineChanges chs - (name, my_log, logf) <- get_log opts Nothing make_log chs - do_actual_record repository opts name date + (name, my_log, logf) <- getLog opts Nothing make_log chs + doActualRecord repository opts name date my_author my_log logf deps chs where is_empty_but_not_askdeps l | AskDeps `elem` opts = False -- a "partial tag" patch; see below. | otherwise = nullFL l -do_actual_record :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String +doActualRecord :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String -> [String] -> Maybe String -> [PatchInfo] -> FL Prim -> IO () -do_actual_record repository opts name date my_author my_log logf deps chs = +doActualRecord repository opts name date my_author my_log logf deps chs = do debugMessage "Writing the patch file..." mypatch <- namepatch date name my_author my_log $ fromPrims $ progressFL "Writing changes:" chs @@ -226,62 +219,47 @@ invalidateIndex repository debugMessage "Applying to pristine..." withGutsOf repository (finalizeRepositoryChanges repository) - `clarify_errors` failuremessage + `clarifyErrors` failuremessage debugMessage "Syncing timestamps..." - sync_repo repository when (isJust logf) $ removeFile (fromJust logf) - logMessage $ "Finished recording patch '"++name++"'" - where (logMessage,_,_) = loggers opts - failuremessage = "Failed to record patch '"++name++"'" ++ + putStrLn $ "Finished recording patch '"++name++"'" + where failuremessage = "Failed to record patch '"++name++"'" ++ case logf of Just lf -> "\nLogfile left in "++lf++"." Nothing -> "" -\end{code} -Each patch is given a name, which typically would consist of a brief -description of the changes. This name is later used to describe the patch. -The name must fit on one line (i.e.\ cannot have any embedded newlines). If -you have more to say, stick it in the log. -\begin{code} -\end{code} -The patch is also flagged with the author of the change, taken by default -from the \verb!DARCS_EMAIL! environment variable, and if that doesn't -exist, from the \verb!EMAIL! environment variable. The date on which the -patch was recorded is also included. Currently there is no provision for -keeping track of when a patch enters a given repository. -\begin{code} -get_date :: [DarcsFlag] -> IO String -get_date opts - | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? " -get_date _ = getIsoDateTime -\end{code} -\label{DARCS_EDITOR} -Finally, each changeset should have a full log (which may be empty). This -log is for detailed notes which are too lengthy to fit in the name. If you -answer that you do want to create a comment file, darcs will open an editor -so that you can enter the comment in. The choice of editor proceeds as -follows. If one of the \verb!$DARCS_EDITOR!, \verb!$VISUAL! or -\verb!$EDITOR! environment variables is defined, its value is used (with -precedence proceeding in the order listed). If not, ``vi'', ``emacs'', -``emacs~-nw'' and ``nano'' are tried in that order. - -\begin{options} ---logfile -\end{options} +recordHelp' :: String +recordHelp' = + "Every patch has a name, an optional description, an author and a date.\n" ++ + "\n" ++ + "The patch name should be a short sentence that concisely describes the\n" ++ + "patch, such as `Add error handling to main event loop.' You can\n" ++ + "supply it in advance with the -m option, or provide it when prompted.\n" ++ + "\n" ++ + "The patch description is an optional block of free-form text. It is\n" ++ + "used to supply additional information that doesn't fit in the patch\n" ++ + "name. For example, it might include a rationale of WHY the change was\n" ++ + "necessary. By default Darcs asks if you want to add a description;\n" ++ + "the --edit-long-comment and --skip-long-comment can be used to answer\n" ++ + "`yes' or `no' (respectively) to this prompt. Finally, the --logfile\n" ++ + "option allows you to supply a file that already contains the patch\n" ++ + "name (first line) and patch description (subsequent lines). This is\n" ++ + "useful if a previous record failed and left a darcs-record-0 file.\n" ++ + "\n" ++ + unlines fileHelpAuthor ++ + "\n" ++ + "The patch date is generated automatically. It can only be spoofed by\n" ++ + "using the --pipe option.\n" -If you wish, you may specify the patch name and log using the -\verb!--logfile! flag. If you do so, the first line of the specified file -will be taken to be the patch name, and the remainder will be the ``long -comment''. This feature can be especially handy if you have a test that -fails several times on the record (thus aborting the record), so you don't -have to type in the long comment multiple times. The file's contents will -override the \verb!--patch-name! option. +getDate :: [DarcsFlag] -> IO String +getDate opts + | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? " +getDate _ = getIsoDateTime -\begin{code} data PName = FlagPatchName String | PriorPatchName String | NoPatchName -get_log :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim -> +getLog :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim -> IO (String, [String], Maybe String) -get_log opts m_old make_log chs = gl opts +getLog opts m_old make_log chs = gl opts where patchname_specified = patchname_helper opts patchname_helper (PatchName n:_) | take 4 n == "TAG " = FlagPatchName $ '.':n | otherwise = FlagPatchName n @@ -296,7 +274,7 @@ PriorPatchName p -> return p NoPatchName -> prompt_patchname False putStrLn "What is the log?" - thelog <- lines `fmap` hGetContents stdin -- ratify hGetContents: stdin not deleted + thelog <- lines `fmap` Ratified.hGetContents stdin return (p, thelog, Nothing) gl (LogFile f:fs) = do -- round 1 (patchname) @@ -311,8 +289,10 @@ when (EditLongComment `elem` fs) $ do edit_file f return () (name, thelog, _) <- read_long_comment f firstname - when (RmLogFile `elem` opts) $ removeFileMayNotExist f - return (name, thelog, Nothing) + let toRemove = if willRemoveLogFile opts + then Just $ toFilePath f + else Nothing + return (name, thelog, toRemove) gl (EditLongComment:_) = case patchname_specified of FlagPatchName p -> actually_get_log p @@ -408,49 +388,45 @@ depended-upon patches. \begin{code} -ask_about_depends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo] -ask_about_depends repository pa' opts = do +askAboutDepends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo] +askAboutDepends repository pa' opts = do pps <- read_repo repository pa <- n2pia `fmap` anonymous (fromPrims pa') let ps = (reverseRL $ headRL pps)+>+(pa:>:NilFL) - (pc, tps) = patch_choices_tps ps - ta = case filter ((pa `unsafeCompare`) . tp_patch) $ unsafeUnFL tps of + (pc, tps) = patchChoicesTps ps + ta = case filter ((pa `unsafeCompare`) . tpPatch) $ unsafeUnFL tps of [tp] -> tag tp - [] -> error "ask_about_depends: []" - _ -> error "ask_about_depends: many" - ps' = mapFL_FL tp_patch $ middle_choice $ force_first ta pc - with_selected_changes_reversed "depend on" (filter askdep_allowed opts) ps' + [] -> error "askAboutDepends: []" + _ -> error "askAboutDepends: many" + ps' = mapFL_FL tpPatch $ middle_choice $ forceFirst ta pc + with_selected_changes_reversed "depend on" (filter askdep_allowed opts) Nothing ps' $ \(deps:>_) -> return $ mapFL info deps where headRL (x:<:_) = x headRL NilRL = impossible - askdep_allowed = not . patch_select_flag - middle_choice p = mc where (_ :> mc :> _) = get_choices p + askdep_allowed = not . patchSelectFlag + middle_choice p = mc where (_ :> mc :> _) = getChoices p -only_successful_exits :: Exception -> Maybe () -only_successful_exits (ExitException ExitSuccess) = Just () -only_successful_exits _ = Nothing -\end{code} - -\begin{options} ---no-test, --test -\end{options} - -If you configure darcs to run a test suite, darcs will run this test on the -recorded repository to make sure it is valid. Darcs first creates a pristine -copy of the source tree (in a temporary directory), then it runs the test, -using its return value to decide if the record is valid. If it is not valid, -the record will be aborted. This is a handy way to avoid making stupid -mistakes like forgetting to `darcs add' a new file. It also can be -tediously slow, so there is an option (\verb!--no-test!) to skip the test. - -\begin{options} ---set-scripts-executable -\end{options} +onlySuccessfulExits :: Exception -> Maybe () +onlySuccessfulExits (ExitException ExitSuccess) = Just () +onlySuccessfulExits _ = Nothing -If you pass \verb!--set-scripts-executable! to \verb!darcs record!, darcs will set scripts -executable in the test directory before running the test. +recordHelp'' :: String +recordHelp'' = + "If a test command has been defined with `darcs setpref', attempting to\n" ++ + "record a patch will cause the test command to be run in a clean copy\n" ++ + "of the working tree (that is, including only recorded changes). If\n" ++ + "the test fails, the record operation will be aborted.\n" ++ + "\n" ++ + "The --set-scripts-executable option causes scripts to be made\n" ++ + "executable in the clean copy of the working tree, prior to running the\n" ++ + "test. See `darcs get' for an explanation of the script heuristic.\n" ++ + "\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" +\end{code} \begin{options} --pipe \end{options} diff --git a/src/Darcs/Commands/Remove.lhs b/src/Darcs/Commands/Remove.lhs --- a/src/Darcs/Commands/Remove.lhs +++ b/src/Darcs/Commands/Remove.lhs @@ -24,29 +24,38 @@ import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults, - command_alias, command_stub, + commandAlias, commandStub, + putWarning ) -import Darcs.Arguments ( DarcsFlag, fixSubPaths, - list_registered_files, - working_repo_dir, umask_option +import Darcs.Arguments ( DarcsFlag (Recursive), fixSubPaths, + listRegisteredFiles, + workingRepoDir, umaskOption, + recursive ) -import Darcs.RepoPath ( SubPath, toFilePath, sp2fn ) +import Darcs.RepoPath ( SubPath, sp2fn ) import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, - slurp_pending, slurp_recorded, - get_unrecorded_in_files, add_to_pending ) -import Darcs.Patch ( RepoPatch, Prim, apply_to_slurpy, adddir, rmdir, addfile, rmfile ) -import Darcs.Ordered ( FL(..), (+>+) ) -import Darcs.SlurpDirectory ( slurp_removedir, slurp_removefile ) -import Darcs.Repository.Prefs ( filetype_function ) -import Darcs.Diff ( unsafeDiff ) -import Darcs.Gorsvet( invalidateIndex ) -#include "impossible.h" + add_to_pending, readRecordedAndPending, readUnrecorded ) +import Darcs.Diff( treeDiff ) +import Darcs.Patch ( RepoPatch, Prim, adddir, rmdir, addfile, rmfile ) +import Darcs.Patch.FileName( fn2fp ) +import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) +import Darcs.Witnesses.Sealed ( Sealed(..) ) +import Darcs.Repository.Prefs ( filetypeFunction ) +import Storage.Hashed.Tree( TreeItem(..), find, modifyTree, expand, list ) +import Storage.Hashed.AnchoredPath( anchorPath ) +import Storage.Hashed( floatPath ) -remove_description :: String -remove_description = "Remove files from version control." +import Darcs.Commands.Add( expandDirs ) +import Printer ( text ) +import Debug.Trace -remove_help :: String -remove_help = +#include "gadts.h" + +removeDescription :: String +removeDescription = "Remove files from version control." + +removeHelp :: String +removeHelp = "The `darcs remove' command exists primarily for symmetry with `darcs\n" ++ "add', as the normal way to remove a file from version control is\n" ++ "simply to delete it from the working tree. This command is only\n" ++ @@ -57,64 +66,70 @@ "the patch) will ALWAYS affect the working tree of that repository.\n" remove :: DarcsCommand -remove = DarcsCommand {command_name = "remove", - command_help = remove_help, - command_description = remove_description, - command_extra_args = -1, - command_extra_arg_help = [" ..."], - command_command = remove_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = - [working_repo_dir]} +remove = DarcsCommand {commandName = "remove", + commandHelp = removeHelp, + commandDescription = removeDescription, + commandExtraArgs = -1, + commandExtraArgHelp = [" ..."], + commandCommand = removeCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = + [workingRepoDir, recursive "recurse into subdirectories"]} -remove_cmd :: [DarcsFlag] -> [String] -> IO () -remove_cmd opts relargs = +removeCmd :: [DarcsFlag] -> [String] -> IO () +removeCmd opts relargs = withRepoLock opts $- \repository -> do - args <- fixSubPaths opts relargs + origfiles <- fixSubPaths opts relargs + args <- if Recursive `elem` opts + then reverse `fmap` expandDirs origfiles + else return origfiles when (null args) $ putStrLn "Nothing specified, nothing removed." - p <- make_remove_patch repository args - invalidateIndex repository + Sealed p <- makeRemovePatch opts repository args add_to_pending repository p -make_remove_patch :: RepoPatch p => Repository p -> [SubPath] -> IO (FL Prim) -make_remove_patch repository files = - do s <- slurp_pending repository - srecorded <- slurp_recorded repository - pend <- get_unrecorded_in_files repository (map sp2fn files) - let sunrec = fromJust $ apply_to_slurpy pend srecorded - wt <- filetype_function - mrp wt s sunrec files - where mrp wt s sunrec (f:fs) = - case slurp_removedir fn s of - Just s' -> - case slurp_removedir fn sunrec of - Just sunrec' -> do rest <- mrp wt s' sunrec' fs - return $ rmdir f_fp :>: rest - Nothing -> do rest <- mrp wt s' sunrec fs - return $ adddir f_fp :>: rmdir f_fp :>: rest - Nothing -> - case slurp_removefile fn s of - Nothing -> fail $ "Can't remove "++f_fp - Just s' -> - case slurp_removefile fn sunrec of - Nothing -> do rest <- mrp wt s' sunrec fs - return $ addfile f_fp :>: rmfile f_fp :>: rest - Just sunrec' -> do rest <- mrp wt s' sunrec' fs - let newp = unsafeDiff [] wt sunrec sunrec' - return $ newp +>+ rest - where fn = sp2fn f - f_fp = toFilePath f - mrp _ _ _ [] = return NilFL +makeRemovePatch :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) + -> [SubPath] -> IO (Sealed (FL Prim C(u))) +makeRemovePatch opts repository files = + do recorded <- expand =<< readRecordedAndPending repository + unrecorded <- readUnrecorded repository + ftf <- filetypeFunction + mrp ftf recorded unrecorded $ map (floatPath . fn2fp . sp2fn) files + where mrp ftf recorded unrecorded (f:fs) = do + let recorded' = modifyTree recorded f Nothing + unrecorded' = modifyTree unrecorded f Nothing + Sealed rest <- mrp ftf recorded' unrecorded' fs + let f_fp = anchorPath "" f + skipAndWarn reason = + do putWarning opts . text $ "Can't remove " ++ f_fp + ++ " (" ++ reason ++ ")" + return $ Sealed rest -rm_description :: String -rm_description = "Help newbies find `darcs remove'." + case (find recorded f, find unrecorded f) of + (Just (SubTree _), Just (SubTree unrecordedChildren)) -> do + if not $ null (list unrecordedChildren) + then skipAndWarn "it is not empty" + else return . Sealed $ rmdir f_fp :>: rest + (Just (File _), Just (File _)) -> + do diff <- treeDiff ftf unrecorded unrecorded' + return . Sealed $ diff +>+ rest + (Just (File _), _) -> + return . Sealed $ addfile f_fp :>: rmfile f_fp :>: rest + (Just (SubTree _), _) -> + return . Sealed $ adddir f_fp :>: rmdir f_fp :>: rest + (_, _) -> skipAndWarn "it is not tracked by darcs" + -rm_help :: String -rm_help = + mrp _ _ _ [] = return (Sealed NilFL) + +rmDescription :: String +rmDescription = "Help newbies find `darcs remove'." + +rmHelp :: String +rmHelp = "The `darcs rm' command does nothing.\n" ++ "\n" ++ "The normal way to remove a file from version control is simply to\n" ++ @@ -122,10 +137,10 @@ "control WITHOUT affecting the working tree, see `darcs remove'.\n" rm :: DarcsCommand -rm = command_stub "rm" rm_help rm_description remove +rm = commandStub "rm" rmHelp rmDescription remove unadd :: DarcsCommand -unadd = command_alias "unadd" remove +unadd = commandAlias "unadd" remove \end{code} diff --git a/src/Darcs/Commands/Repair.lhs b/src/Darcs/Commands/Repair.lhs --- a/src/Darcs/Commands/Repair.lhs +++ b/src/Darcs/Commands/Repair.lhs @@ -17,54 +17,59 @@ \darcsCommand{repair} \begin{code} -module Darcs.Commands.Repair ( repair ) where +module Darcs.Commands.Repair ( repair, repairCmd ) where import System.IO +import Control.Monad( unless ) +import System.Directory( renameFile ) import Darcs.Commands -import Darcs.Arguments ( DarcsFlag(), - working_repo_dir, umask_option, +import Darcs.Arguments ( DarcsFlag( Quiet ), + workingRepoDir, umaskOption, ) import Darcs.Repository ( withRepoLock, ($-), amInRepository, - replacePristineFromSlurpy, writePatchSet ) -import Darcs.Repository.Repair( replayRepository, - RepositoryConsistency(..) ) + replacePristine, writePatchSet ) +import Darcs.Repository.Repair( replayRepository, checkIndex + , RepositoryConsistency(..) ) -repair_description :: String -repair_description = "Repair a corrupted repository." +repairDescription :: String +repairDescription = "Repair a corrupted repository." -repair_help :: String -repair_help = +repairHelp :: String +repairHelp = "The `darcs repair' command attempts to fix corruption in the current\n" ++ "repository. Currently it can only repair damage to the pristine tree,\n" ++ "which is where most corruption occurs.\n" repair :: DarcsCommand -repair = DarcsCommand {command_name = "repair", - command_help = repair_help, - command_description = repair_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = repair_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = [working_repo_dir]} +repair = DarcsCommand {commandName = "repair", + commandHelp = repairHelp, + commandDescription = repairDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = repairCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = [workingRepoDir]} -repair_cmd :: [DarcsFlag] -> [String] -> IO () -repair_cmd opts _ = withRepoLock opts $- \repository -> do +repairCmd :: [DarcsFlag] -> [String] -> IO () +repairCmd opts _ = withRepoLock opts $- \repository -> do replayRepository repository opts $ \state -> case state of RepositoryConsistent -> putStrLn "The repository is already consistent, no changes made." - BrokenPristine s -> do + BrokenPristine tree -> do putStrLn "Fixing pristine tree..." - replacePristineFromSlurpy repository s - BrokenPatches s newps -> do + replacePristine repository tree + BrokenPatches tree newps -> do putStrLn "Writing out repaired patches..." writePatchSet newps opts putStrLn "Fixing pristine tree..." - replacePristineFromSlurpy repository s + replacePristine repository tree return () + index_ok <- checkIndex repository (Quiet `elem` opts) + unless index_ok $ do renameFile "_darcs/index" "_darcs/index.bad" + putStrLn "Bad index discarded." \end{code} diff --git a/src/Darcs/Commands/Replace.lhs b/src/Darcs/Commands/Replace.lhs --- a/src/Darcs/Commands/Replace.lhs +++ b/src/Darcs/Commands/Replace.lhs @@ -23,37 +23,46 @@ module Darcs.Commands.Replace ( replace ) where import Data.Maybe ( isJust ) -import Control.Monad ( unless ) +import Control.Monad ( unless, filterM ) +import Control.Applicative( (<$>) ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help, - command_description, command_extra_args, - command_extra_arg_help, command_command, command_prereq, - command_get_arg_possibilities, command_argdefaults, - command_advanced_options, command_basic_options), +import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp, + commandDescription, commandExtraArgs, + commandExtraArgHelp, commandCommand, commandPrereq, + commandGetArgPossibilities, commandArgdefaults, + commandAdvancedOptions, commandBasicOptions), nodefaults ) -import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), list_registered_files, - ignoretimes, umask_option, tokens, force_replace, - working_repo_dir, fixSubPaths ) +import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), listRegisteredFiles, + ignoretimes, umaskOption, tokens, forceReplace, + workingRepoDir, fixSubPaths ) import Darcs.Repository ( withRepoLock, ($-), - add_to_pending, slurp_pending, - amInRepository, slurp_recorded_and_unrecorded, + add_to_pending, + amInRepository, applyToWorking, + readUnrecorded, readRecordedAndPending ) -import Darcs.Patch ( Prim, apply_to_slurpy, tokreplace, force_replace_slurpy ) -import Darcs.Ordered ( FL(..), unsafeFL, (+>+), concatFL ) -import Darcs.SlurpDirectory ( slurp_hasfile, Slurpy ) -import RegChars ( regChars ) +import Darcs.Patch ( Prim, tokreplace, applyToTree ) +import Darcs.Patch.Apply ( forceTokReplace ) +import Darcs.Patch.FileName( fn2fp ) +import Darcs.Patch.Patchy ( Apply ) +import Darcs.Witnesses.Ordered ( FL(..), unsafeFL, (+>+), concatFL ) +import Darcs.Patch.RegChars ( regChars ) import Data.Char ( isSpace ) -import Darcs.Diff ( unsafeDiff ) -import Darcs.RepoPath ( SubPath, sp2fn, toFilePath ) +import Darcs.RepoPath ( SubPath, toFilePath, sp2fn ) import Darcs.Repository.Prefs ( FileType(TextFile) ) +import Darcs.Diff( treeDiff ) +import Storage.Hashed.Tree( readBlob, modifyTree , findFile, TreeItem(..), Tree, makeBlobBS ) +import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath ) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS #include "impossible.h" -replace_description :: String -replace_description = "Substitute one word for another." +replaceDescription :: String +replaceDescription = "Substitute one word for another." -replace_help :: String -replace_help = +replaceHelp :: String +replaceHelp = "In addition to line-based patches, Darcs supports a limited form of\n" ++ "lexical substitution. Files are treated as sequences of words, and\n" ++ "each occurrence of the old word is replaced by the new word.\n" ++ @@ -135,85 +144,99 @@ \begin{code} replace :: DarcsCommand -replace = DarcsCommand {command_name = "replace", - command_help = replace_help, - command_description = replace_description, - command_extra_args = -1, - command_extra_arg_help = ["","", +replace = DarcsCommand {commandName = "replace", + commandHelp = replaceHelp, + commandDescription = replaceDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["","", " ..."], - command_command = replace_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [ignoretimes, umask_option], - command_basic_options = - [tokens, force_replace, working_repo_dir]} + commandCommand = replaceCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [ignoretimes, umaskOption], + commandBasicOptions = + [tokens, forceReplace, workingRepoDir]} -replace_cmd :: [DarcsFlag] -> [String] -> IO () -replace_cmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do +replaceCmd :: [DarcsFlag] -> [String] -> IO () +replaceCmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do fs <- fixSubPaths opts relfs - toks <- choose_toks opts old new + toks <- chooseToks opts old new let checkToken tok = - unless (is_tok toks tok) $ fail $ "'"++tok++"' is not a valid token!" + unless (isTok toks tok) $ fail $ "'"++tok++"' is not a valid token!" checkToken old checkToken new - (_, work) <- slurp_recorded_and_unrecorded repository - cur <- slurp_pending repository - pswork <- (concatFL . unsafeFL) `fmap` sequence (map (repl toks cur work) fs) + work <- readUnrecorded repository + cur <- readRecordedAndPending repository + files <- filterM (exists work) fs + pswork <- concatFL . unsafeFL <$> mapM (repl toks cur work) files add_to_pending repository pswork applyToWorking repository opts pswork `catch` \e -> fail $ "Can't do replace on working!\n" ++ "Perhaps one of the files already contains '"++ new++"'?\n" ++ show e where ftf _ = TextFile - - repl :: String -> Slurpy -> Slurpy -> SubPath -> IO (FL Prim) + skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository." + exists tree file = if isJust $ findFile tree (floatSubPath file) + then return True + else do putStrLn $ skipmsg file + return False + repl :: String -> Tree IO -> Tree IO -> SubPath -> IO (FL Prim) repl toks cur work f = - if not $ slurp_hasfile (sp2fn f) work - then do putStrLn $ "Skipping file '"++f_fp++"' which isn't in the repository." - return NilFL - else if ForceReplace `elem` opts || - isJust (apply_to_slurpy (tokreplace f_fp toks old new) work) || - isJust (apply_to_slurpy (tokreplace f_fp toks old new) cur) - then return (get_force_replace f toks work) - else do putStrLn $ "Skipping file '"++f_fp++"'" - putStrLn $ "Perhaps the recorded version of this " ++ - "file already contains '" ++new++"'?" - putStrLn $ "Use the --force option to override." - return NilFL + do work_replaced <- maybeApplyToTree replace_patch work + cur_replaced <- maybeApplyToTree replace_patch cur + if ForceReplace `elem` opts || isJust work_replaced || isJust cur_replaced + then get_force_replace f toks work + else do putStrLn $ "Skipping file '"++f_fp++"'" + putStrLn $ "Perhaps the recorded version of this " ++ + "file already contains '" ++new++"'?" + putStrLn $ "Use the --force option to override." + return NilFL where f_fp = toFilePath f + replace_patch = tokreplace f_fp toks old new - get_force_replace :: SubPath -> String -> Slurpy -> FL Prim - get_force_replace f toks s = - case force_replace_slurpy (tokreplace f_fp toks new old) s of - Nothing -> bug "weird forcing bug in replace." - Just s' -> case unsafeDiff [] ftf s s' of - pfix -> pfix +>+ (tokreplace f_fp toks old new :>: NilFL) + get_force_replace :: SubPath -> String -> Tree IO -> IO (FL Prim) + get_force_replace f toks tree = do + let path = floatSubPath f + content <- readBlob $ fromJust $ findFile tree path + let newcontent = forceTokReplace toks new old (BS.concat $ BL.toChunks content) + tree' = modifyTree tree path (File . makeBlobBS <$> newcontent) + case newcontent of + Nothing -> bug "weird forcing bug in replace." + Just _ -> do pfix <- treeDiff ftf tree tree' + return $ pfix +>+ (tokreplace f_fp toks old new :>: NilFL) where f_fp = toFilePath f -replace_cmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]" +replaceCmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]" -default_toks :: String -default_toks = "A-Za-z_0-9" -filename_toks :: String -filename_toks = "A-Za-z_0-9\\-\\." +floatSubPath :: SubPath -> AnchoredPath +floatSubPath = floatPath . fn2fp . sp2fn +maybeApplyToTree :: Apply p => p -> Tree IO -> IO (Maybe (Tree IO)) +maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree) + (\_ -> return Nothing) + +defaultToks :: String +defaultToks = "A-Za-z_0-9" +filenameToks :: String +filenameToks = "A-Za-z_0-9\\-\\." + -- | Given a set of characters and a string, returns true iff the -- string contains only characters from the set. A set beginning with -- a caret (@^@) is treated as a complementary set. -is_tok :: String -> String -> Bool -is_tok _ "" = False -is_tok toks s = and $ map (regChars toks) s +isTok :: String -> String -> Bool +isTok _ "" = False +isTok toks s = and $ map (regChars toks) s -- | This function checks for @--token-chars@ on the command-line. If -- found, it validates the argument and returns it, without the -- surrounding square brackets. Otherwise, it returns either --- 'default_toks' or 'filename_toks' as explained in 'replace_help'. +-- 'defaultToks' or 'filenameToks' as explained in 'replaceHelp'. -- -- Note: Limitations in the current replace patch file format prevents -- tokens and token-char specifiers from containing any whitespace. -choose_toks :: [DarcsFlag] -> String -> String -> IO String -choose_toks (Toks t:_) a b +chooseToks :: [DarcsFlag] -> String -> String -> IO String +chooseToks (Toks t:_) a b | length t <= 2 = bad_token_spec $ "It must contain more than 2 characters, because " ++ "it should be enclosed in square brackets" @@ -225,16 +248,16 @@ bad_token_spec "Space is not allowed in the spec" | any isSpace a = bad_token_spec $ spacey_token a | any isSpace b = bad_token_spec $ spacey_token b - | not (is_tok tok a) = bad_token_spec $ not_a_token a - | not (is_tok tok b) = bad_token_spec $ not_a_token b + | not (isTok tok a) = bad_token_spec $ not_a_token a + | not (isTok tok b) = bad_token_spec $ not_a_token b | otherwise = return tok where tok = init $ tail t :: String bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")" spacey_token x = x ++ " must not contain any space" not_a_token x = x ++ " is not a token, according to your spec" -choose_toks (_:fs) a b = choose_toks fs a b -choose_toks [] a b = if is_tok default_toks a && is_tok default_toks b - then return default_toks - else return filename_toks +chooseToks (_:fs) a b = chooseToks fs a b +chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b + then return defaultToks + else return filenameToks \end{code} diff --git a/src/Darcs/Commands/Revert.lhs b/src/Darcs/Commands/Revert.lhs --- a/src/Darcs/Commands/Revert.lhs +++ b/src/Darcs/Commands/Revert.lhs @@ -25,33 +25,31 @@ import English (englishNum, This(..), Noun(..)) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( All, Debug ), - ignoretimes, working_repo_dir, - all_interactive, + ignoretimes, workingRepoDir, + allInteractive, fixSubPaths, areFileArgs, - list_registered_files, umask_option, + listRegisteredFiles, umaskOption, ) import Darcs.Utils ( askUser ) -import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.RepoPath ( toFilePath ) import Darcs.Repository ( withRepoLock, ($-), withGutsOf, - get_unrecorded_in_files, - get_unrecorded_in_files_unsorted, - add_to_pending, sync_repo, + add_to_pending, applyToWorking, - amInRepository, slurp_recorded, + amInRepository, readRecorded, + unrecordedChanges ) -import Darcs.Patch ( invert, apply_to_filepaths, commute ) -import Darcs.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) ) +import Darcs.Patch ( invert, applyToFilepaths, commute ) +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) ) import Darcs.SelectChanges ( with_selected_last_changes_to_files' ) import Darcs.Patch.TouchesFiles ( choose_touching ) -import Darcs.Commands.Unrevert ( write_unrevert ) -import Darcs.Sealed ( unsafeUnseal ) -import Darcs.Gorsvet( invalidateIndex ) +import Darcs.Commands.Unrevert ( writeUnrevert ) +import Darcs.Witnesses.Sealed ( unsafeUnseal ) -revert_description :: String -revert_description = "Discard unrecorded changes." +revertDescription :: String +revertDescription = "Discard unrecorded changes." -revert_help :: String -revert_help = +revertHelp :: String +revertHelp = "The `darcs revert' command discards unrecorded changes the working\n" ++ "tree. As with `darcs record', you will be asked which hunks (changes)\n" ++ "to revert. The --all switch can be used to avoid such prompting. If\n" ++ @@ -65,33 +63,30 @@ "revert' ran.\n" revert :: DarcsCommand -revert = DarcsCommand {command_name = "revert", - command_help = revert_help, - command_description = revert_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_command = revert_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [ignoretimes, umask_option], - command_basic_options = [all_interactive, - working_repo_dir]} +revert = DarcsCommand {commandName = "revert", + commandHelp = revertHelp, + commandDescription = revertDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = revertCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [ignoretimes, umaskOption], + commandBasicOptions = [allInteractive, + workingRepoDir]} -revert_cmd :: [DarcsFlag] -> [String] -> IO () -revert_cmd opts args = withRepoLock opts $- \repository -> do +revertCmd :: [DarcsFlag] -> [String] -> IO () +revertCmd opts args = withRepoLock opts $- \repository -> do files <- sort `fmap` fixSubPaths opts args - let files_fn = map sp2fn files when (areFileArgs files) $ putStrLn $ "Reverting changes in "++unwords (map show files)++"..\n" - changes <- if All `elem` opts - then get_unrecorded_in_files_unsorted repository files_fn - else get_unrecorded_in_files repository files_fn - let pre_changed_files = apply_to_filepaths (invert changes) (map toFilePath files) - rec <- slurp_recorded repository + changes <- unrecordedChanges opts repository files + let pre_changed_files = applyToFilepaths (invert changes) (map toFilePath files) + rec <- readRecorded repository case unsafeUnseal $ choose_touching pre_changed_files changes of NilFL -> putStrLn "There are no changes to revert!" - _ -> with_selected_last_changes_to_files' "revert" opts + _ -> with_selected_last_changes_to_files' "revert" opts Nothing pre_changed_files changes $ \ (norevert:>p) -> if nullFL p then putStrLn $ "If you don't want to revert after all," ++ @@ -104,16 +99,14 @@ case yorn of ('y':_) -> return () _ -> exitWith $ ExitSuccess withGutsOf repository $ do - invalidateIndex repository add_to_pending repository $ invert p when (Debug `elem` opts) $ putStrLn "About to write the unrevert file." case commute (norevert:>p) of - Just (p':>_) -> write_unrevert repository p' rec NilFL - Nothing -> write_unrevert repository (norevert+>+p) rec NilFL + Just (p':>_) -> writeUnrevert repository p' rec NilFL + Nothing -> writeUnrevert repository (norevert+>+p) rec NilFL when (Debug `elem` opts) $ putStrLn "About to apply to the working directory." applyToWorking repository opts (invert p) `catch` \e -> fail ("Unable to apply inverse patch!" ++ show e) - sync_repo repository putStrLn "Finished reverting." \end{code} diff --git a/src/Darcs/Commands/Rollback.lhs b/src/Darcs/Commands/Rollback.lhs --- a/src/Darcs/Commands/Rollback.lhs +++ b/src/Darcs/Commands/Rollback.lhs @@ -28,54 +28,45 @@ import Data.Maybe ( isJust ) import System.Directory ( removeFile ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers ) -import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, get_author, +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, getAuthor, definePatches, - working_repo_dir, nocompress, - author, patchname_option, ask_long_comment, - leave_test_dir, notest, list_registered_files, - match_several_or_last, all_interactive, umask_option + workingRepoDir, nocompress, + author, patchnameOption, askLongComment, + leaveTestDir, notest, listRegisteredFiles, + matchSeveralOrLast, allInteractive, umaskOption ) import Darcs.RepoPath ( toFilePath ) -import Darcs.Repository ( amInRepository, withRepoLock, ($-), applyToWorking, +import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-), + applyToWorking, read_repo, slurp_recorded, tentativelyMergePatches, withGutsOf, - finalizeRepositoryChanges, sync_repo ) -import Darcs.Patch ( summary, invert, namepatch, effect, fromPrims, - sort_coalesceFL, canonize ) -import Darcs.Ordered -import Darcs.Hopefully ( n2pia ) + finalizeRepositoryChanges, invalidateIndex ) +import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims, + sortCoalesceFL, canonize ) +import Darcs.Patch.Prim ( Prim ) +import Darcs.Witnesses.Ordered +import Darcs.Hopefully ( PatchInfoAnd, n2pia ) import Darcs.Lock ( world_readable_temp ) -import Darcs.SlurpDirectory ( empty_slurpy, wait_a_moment ) -import Darcs.Match ( first_match ) +import Darcs.SlurpDirectory ( empty_slurpy ) +import Darcs.Match ( firstMatch ) import Darcs.SelectChanges ( with_selected_last_changes_to_files_reversed, with_selected_last_changes_to_files' ) -import Darcs.Commands.Record ( file_exists, get_log ) -import Darcs.Commands.Unrecord ( get_last_patches ) -import Darcs.Utils ( clarify_errors ) +import Darcs.Commands.Record ( fileExists, getLog ) +import Darcs.Commands.Unrecord ( getLastPatches ) +import Darcs.Utils ( clarifyErrors ) import Printer ( renderString ) import Progress ( debugMessage ) -import Darcs.Sealed ( Sealed(..), FlippedSeal(..) ) +import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) ) import IsoDate ( getIsoDateTime ) -import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -rollback_description :: String -rollback_description = +rollbackDescription :: String +rollbackDescription = "Record a new patch reversing some recorded changes." -\end{code} -If you decide you didn't want to roll back a patch -after all, you can reverse its effect by obliterating the rolled-back patch. - -Rollback can actually allow you to roll back a subset of the changes made -by the selected patch or patches. Many of the options available in -rollback behave similarly to the options for unrecord~\ref{unrecord} and -record~\ref{record}. - -\begin{code} -rollback_help :: String -rollback_help = +rollbackHelp :: String +rollbackHelp = "Rollback is used to undo the effects of one or more patches without actually\n"++ "deleting them. Instead, it creates a new patch reversing selected portions.\n"++ "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++ @@ -83,57 +74,60 @@ "of its changes.\n" rollback :: DarcsCommand -rollback = DarcsCommand {command_name = "rollback", - command_help = rollback_help, - command_description = rollback_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_command = rollback_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [nocompress,umask_option], - command_basic_options = [match_several_or_last, - all_interactive, - author, patchname_option, ask_long_comment, - notest, leave_test_dir, - working_repo_dir]} +rollback = DarcsCommand {commandName = "rollback", + commandHelp = rollbackHelp, + commandDescription = rollbackDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = rollbackCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [nocompress,umaskOption], + commandBasicOptions = [matchSeveralOrLast, + allInteractive, + author, patchnameOption, askLongComment, + notest, leaveTestDir, + workingRepoDir]} -rollback_cmd :: [DarcsFlag] -> [String] -> IO () -rollback_cmd opts args = withRepoLock opts $- \repository -> do - let (logMessage,_,_) = loggers opts +rollbackCmd :: [DarcsFlag] -> [String] -> IO () +rollbackCmd opts args = withRepoLock opts $- \repository -> do rec <- if null args then return empty_slurpy else slurp_recorded repository files <- sort `fmap` fixSubPaths opts args - existing_files <- map toFilePath `fmap` filterM (file_exists rec) files - non_existent_files <- map toFilePath `fmap` filterM (fmap not . file_exists rec) files + existing_files <- map toFilePath `fmap` filterM (fileExists rec) files + non_existent_files <- map toFilePath `fmap` filterM (fmap not . fileExists rec) files when (not $ null existing_files) $ - logMessage $ "Recording changes in "++unwords existing_files++":\n" + putStrLn $ "Recording changes in "++unwords existing_files++":\n" when (not $ null non_existent_files) $ - logMessage $ "Non existent files or directories: "++unwords non_existent_files++"\n" + putStrLn $ "Non existent files or directories: "++unwords non_existent_files++"\n" when ((not $ null non_existent_files) && null existing_files) $ fail "None of the files you specified exist!" allpatches <- read_repo repository - FlippedSeal patches <- return $ if first_match opts - then get_last_patches opts allpatches + FlippedSeal patches <- return $ if firstMatch opts + then getLastPatches opts allpatches else FlippedSeal $ concatRL allpatches - with_selected_last_changes_to_files_reversed "rollback" opts existing_files - (reverseRL patches) $ - \ (_ :> ps) -> - do when (nullFL ps) $ do logMessage "No patches selected!" - exitWith ExitSuccess - definePatches ps - with_selected_last_changes_to_files' "rollback" opts - existing_files (concatFL $ mapFL_FL canonize $ - sort_coalesceFL $ effect ps) $ \ (_:>ps'') -> - do when (nullFL ps'') $ do logMessage "No changes selected!" + with_selected_last_changes_to_files_reversed "rollback" opts Nothing existing_files + (reverseRL patches) $ \ (_ :> ps) -> + do when (nullFL ps) $ do putStrLn "No patches selected!" + exitWith ExitSuccess + definePatches ps + with_selected_last_changes_to_files' "rollback" opts Nothing + existing_files (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps) + (rollItBackNow opts repository ps) + +rollItBackNow :: (RepoPatch p1, RepoPatch p) => + [DarcsFlag] -> Repository p1 -> FL (PatchInfoAnd p) + -> (t :> FL Prim) -> IO () +rollItBackNow opts repository ps (_ :> ps'') = + do when (nullFL ps'') $ do putStrLn "No changes selected!" exitWith ExitSuccess let make_log = world_readable_temp "darcs-rollback" newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps )) --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps) - (name, my_log, logf) <- get_log opts newlog make_log $ invert ps'' + (name, my_log, logf) <- getLog opts newlog make_log $ invert ps'' date <- getIsoDateTime - my_author <- get_author opts + my_author <- getAuthor opts rbp <- n2pia `fmap` namepatch date name my_author my_log (fromPrims $ invert ps'') debugMessage "Adding rollback patch to repository." @@ -144,13 +138,10 @@ withGutsOf repository $ do finalizeRepositoryChanges repository debugMessage "About to apply rolled-back changes to working directory." - -- so work will be more recent than rec: - revertable $ do wait_a_moment - applyToWorking repository opts pw + revertable $ applyToWorking repository opts pw when (isJust logf) $ removeFile (fromJust logf) - sync_repo repository - logMessage $ "Finished rolling back." - where revertable x = x `clarify_errors` unlines + putStrLn "Finished rolling back." + where revertable x = x `clarifyErrors` unlines ["Error applying patch to the working directory.","", "This may have left your working directory an inconsistent", "but recoverable state. If you had no un-recorded changes", diff --git a/src/Darcs/Commands/Send.lhs b/src/Darcs/Commands/Send.lhs --- a/src/Darcs/Commands/Send.lhs +++ b/src/Darcs/Commands/Send.lhs @@ -28,33 +28,34 @@ import Control.Monad ( when, unless, forM_ ) import Data.Maybe ( isJust, isNothing ) -import Darcs.Commands ( DarcsCommand(..) ) -import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, RmLogFile, +import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose ) +import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, Target, OutputAutoName, Output, Context, - DryRun, Verbose, Quiet, Unified + DryRun, Quiet, Unified ), fixUrl, definePatches, - get_cc, get_author, working_repo_dir, - edit_description, logfile, rmlogfile, - sign, get_subject, deps_sel, get_in_reply_to, - match_several, set_default, output_auto_name, - output, cc, subject, target, author, sendmail_cmd, - in_reply_to, remote_repo, network_options, - all_interactive, get_sendmail_cmd, - print_dry_run_message_and_exit, - summary, allow_unrelated_repos, - from_opt, dry_run, send_to_context, + getCc, getAuthor, workingRepoDir, + editDescription, logfile, rmlogfile, + sign, getSubject, depsSel, getInReplyTo, + matchSeveral, setDefault, outputAutoName, + output, ccSend, subject, target, author, sendmailCmd, + inReplyTo, remoteRepo, networkOptions, + allInteractive, getSendmailCmd, + printDryRunMessageAndExit, + summary, allowUnrelatedRepos, + fromOpt, dryRun, sendToContext, ) +import Darcs.Flags ( willRemoveLogFile ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) import Darcs.Repository ( PatchSet, Repository, amInRepository, identifyRepositoryFor, withRepoReadLock, ($-), - read_repo, slurp_recorded, prefsUrl, checkUnrelatedRepos ) -import Darcs.Patch ( RepoPatch, description, apply_to_slurpy, invert ) -import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), unsafeUnRL, + read_repo, readRecorded, prefsUrl, checkUnrelatedRepos ) +import Darcs.Patch ( RepoPatch, description, applyToTree, invert ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), mapRL_RL, mapFL, mapRL, reverseRL, mapFL_FL, lengthFL, nullFL ) import Darcs.Patch.Bundle ( make_bundle, scan_context ) import Darcs.Patch.Info ( just_name ) -import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist ) +import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist ) import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail ) import ByteStringUtils ( mmapFilePS ) import qualified Data.ByteString.Char8 as BC (unpack) @@ -64,18 +65,20 @@ import Darcs.Utils ( askUser, catchall, edit_file, formatPath ) import Progress ( debugMessage ) import Darcs.Email ( make_email ) -import Printer ( Doc, vsep, vcat, text, ($$), putDocLn, putDoc ) -import Darcs.RepoPath ( toFilePath, AbsolutePath, AbsolutePathOrStd, +import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc ) +import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd, getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd ) import HTTP ( postUrl ) #include "impossible.h" -send_description :: String -send_description = +#include "gadts.h" + +sendDescription :: String +sendDescription = "Send by email a bundle of one or more patches." -send_help :: String -send_help = +sendHelp :: String +sendHelp = "Send is used to prepare a bundle of patches that can be applied to a target\n"++ "repository. Send accepts the URL of the repository as an argument. When\n"++ "called without an argument, send will use the most recent repository that\n"++ @@ -109,36 +112,36 @@ \begin{code} send :: DarcsCommand -send = DarcsCommand {command_name = "send", - command_help = send_help, - command_description = send_description, - command_extra_args = 1, - command_extra_arg_help = ["[REPOSITORY]"], - command_command = send_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = get_preflist "repos", - command_argdefaults = defaultrepo, - command_advanced_options = [logfile, rmlogfile, - remote_repo, - send_to_context] ++ - network_options, - command_basic_options = [match_several, deps_sel, - all_interactive, - from_opt, author, - target,cc,subject, in_reply_to, - output,output_auto_name,sign] - ++dry_run++[summary, - edit_description, - set_default, working_repo_dir, - sendmail_cmd, - allow_unrelated_repos]} +send = DarcsCommand {commandName = "send", + commandHelp = sendHelp, + commandDescription = sendDescription, + commandExtraArgs = 1, + commandExtraArgHelp = ["[REPOSITORY]"], + commandCommand = sendCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = getPreflist "repos", + commandArgdefaults = defaultrepo, + commandAdvancedOptions = [logfile, rmlogfile, + remoteRepo, + sendToContext] ++ + networkOptions, + commandBasicOptions = [matchSeveral, depsSel, + allInteractive, + fromOpt, author, + target,ccSend,subject, inReplyTo, + output,outputAutoName,sign] + ++dryRun++[summary, + editDescription, + setDefault, workingRepoDir, + sendmailCmd, + allowUnrelatedRepos]} -send_cmd :: [DarcsFlag] -> [String] -> IO () -send_cmd input_opts [""] = send_cmd input_opts [] -send_cmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do +sendCmd :: [DarcsFlag] -> [String] -> IO () +sendCmd input_opts [""] = sendCmd input_opts [] +sendCmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do context_ps <- the_context input_opts case context_ps of - Just them -> send_to_them repository input_opts [] "CONTEXT" them + Just them -> sendToThem repository input_opts [] "CONTEXT" them Nothing -> do repodir <- fixUrl input_opts unfixedrepodir -- Test to make sure we aren't trying to push to the current repo @@ -147,88 +150,84 @@ fail ("Can't send to current repository! Did you mean send -"++"-context?") repo <- identifyRepositoryFor repository repodir them <- read_repo repo - old_default <- get_preflist "defaultrepo" - set_defaultrepo repodir input_opts + old_default <- getPreflist "defaultrepo" + setDefaultrepo repodir input_opts when (old_default == [repodir] && not (Quiet `elem` input_opts)) $ putStrLn $ "Creating patch to "++formatPath repodir++"..." - wtds <- decide_on_behavior input_opts repo - send_to_them repository input_opts wtds repodir them + wtds <- decideOnBehavior input_opts repo + sendToThem repository input_opts wtds repodir them where the_context [] = return Nothing the_context (Context foo:_) = (Just . scan_context )`fmap` mmapFilePS (toFilePath foo) the_context (_:fs) = the_context fs -send_cmd _ _ = impossible +sendCmd _ _ = impossible -send_to_them :: RepoPatch p => Repository p -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p -> IO () -send_to_them repo opts wtds their_name them = do - let am_verbose = Verbose `elem` opts - am_quiet = Quiet `elem` opts - putVerbose s = when am_verbose $ putDocLn s - putInfo s = when (not am_quiet) $ putStrLn s - patch_desc p = just_name $ info p - make_fname tbs = patch_filename $ patch_desc $ headFL tbs - headFL (x:>:_) = x - headFL _ = impossible +sendToThem :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p C(x) -> IO () +sendToThem repo opts wtds their_name them = do us <- read_repo repo case get_common_and_uncommon (us, them) of (common, us' :\/: _) -> do checkUnrelatedRepos opts common us them - case us' of - NilRL:<:NilRL -> do putInfo "No recorded local changes to send!" - exitWith ExitSuccess - _ -> putVerbose $ text "We have the following patches to send:" - $$ (vcat $ mapRL description $ head $ unsafeUnRL us') - s <- slurp_recorded repo - let our_ps = reverseRL $ head $ unsafeUnRL us' - with_selected_changes "send" opts our_ps $ + (case us' of + NilRL -> do putInfo opts $ text "No recorded local changes to send!" + exitWith ExitSuccess + _ -> putVerbose opts $ text "We have the following patches to send:" + $$ (vcat $ mapRL description us')) :: IO () + pristine <- readRecorded repo + let our_ps = reverseRL us' + with_selected_changes "send" opts Nothing our_ps $ \ (to_be_sent :> _) -> do - print_dry_run_message_and_exit "send" opts to_be_sent + printDryRunMessageAndExit "send" opts to_be_sent when (nullFL to_be_sent) $ do - putInfo "You don't want to send any patches, and that's fine with me!" + putInfo opts $ text "You don't want to send any patches, and that's fine with me!" exitWith ExitSuccess definePatches to_be_sent - bundle <- signString opts $ make_bundle (Unified:opts) - (fromJust $ apply_to_slurpy - (invert $ - mapRL_RL hopefully $ head $ unsafeUnRL us') s) - common (mapFL_FL hopefully to_be_sent) - let outname = get_output opts (make_fname to_be_sent) + pristine' <- applyToTree (invert $ mapRL_RL hopefully us') pristine + unsig_bundle <- make_bundle (Unified:opts) pristine' common (mapFL_FL hopefully to_be_sent) + bundle <- signString opts unsig_bundle + let make_fname (tb:>:_) = patchFilename $ patchDesc tb + make_fname _ = impossible + fname = make_fname to_be_sent + outname = getOutput opts fname case outname of - Just fname -> do (d,f) <- get_description opts to_be_sent - let putabs a = do writeDocBinFile a (d $$ bundle) - putStrLn $ "Wrote patch to " ++ toFilePath a ++ "." - putstd = putDoc (d $$ bundle) - useAbsoluteOrStd putabs putstd fname - cleanup f - Nothing -> + Just fname' -> writeBundleToFile opts to_be_sent bundle fname' their_name + Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name + +patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String +patchDesc p = just_name $ info p + +sendBundle :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) + -> Doc -> String -> [WhatToDo] -> String -> IO () +sendBundle opts to_be_sent bundle fname wtds their_name= let - auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patch_desc p) 57 - auto_subject (p:>:ps) = "darcs patch: " ++ trim (patch_desc p) 43 ++ + auto_subject :: forall pp C(x y) . FL (PatchInfoAnd pp) C(x y) -> String + auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patchDesc p) 57 + auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++ " (and " ++ show (lengthFL ps) ++ " more)" auto_subject _ = error "Tried to get a name from empty patch list." trim st n = if length st <= n then st else take (n-3) st ++ "..." in do - thetargets <- get_targets wtds - from <- get_author opts - let thesubject = case get_subject opts of + thetargets <- getTargets wtds + from <- getAuthor opts + let thesubject = case getSubject opts of Nothing -> auto_subject to_be_sent Just subj -> subj - (mailcontents, mailfile) <- get_description opts to_be_sent + (mailcontents, mailfile) <- getDescription opts their_name to_be_sent let body = make_email their_name - (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . get_in_reply_to $ opts) + (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts) (Just mailcontents) bundle - (Just $ make_fname to_be_sent) + (Just fname) contentAndBundle = Just (mailcontents, bundle) sendmail = do - sm_cmd <- get_sendmail_cmd opts - (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (get_cc opts) + sm_cmd <- getSendmailCmd opts + (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (getCc opts) sm_cmd contentAndBundle body >> - putInfo ("Successfully sent patch bundle to: " + (putInfo opts . text $ ("Successfully sent patch bundle to: " ++ lt [ t | SendMail t <- thetargets ] - ++ ccs (get_cc opts) ++".")) + ++ ccs (getCc opts) ++"."))) `catch` \e -> let msg = "Email body left in " in do case mailfile of Just mf -> putStrLn $ msg++mf++"." @@ -239,32 +238,44 @@ when (null [ p | Post p <- thetargets]) sendmail nbody <- withOpenTemp $ \ (fh,fn) -> do - generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (get_cc opts) body + generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (getCc opts) body hClose fh mmapFilePS fn forM_ [ p | Post p <- thetargets] (\url -> do - putInfo $ "Posting patch to " ++ url + putInfo opts . text $ "Posting patch to " ++ url postUrl url (BC.unpack nbody) "message/rfc822") `catch` const sendmail - cleanup mailfile + cleanup opts mailfile + where + lt [t] = t + lt [t,""] = t + lt (t:ts) = t++" , "++lt ts + lt [] = "" - where cleanup (Just mailfile) = when (isNothing (get_fileopt opts) || (RmLogFile `elem` opts)) $ +cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO () +cleanup opts (Just mailfile) = when (isNothing (getFileopt opts) || (willRemoveLogFile opts)) $ removeFileMayNotExist mailfile - cleanup Nothing = return () - lt [t] = t - lt [t,""] = t - lt (t:ts) = t++" , "++lt ts - lt [] = "" +cleanup _ Nothing = return () +writeBundleToFile :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc -> + AbsolutePathOrStd -> String -> IO () +writeBundleToFile opts to_be_sent bundle fname their_name = + do (d,f) <- getDescription opts their_name to_be_sent + let putabs a = do writeDocBinFile a (d $$ bundle) + putStrLn $ "Wrote patch to " ++ toFilePath a ++ "." + putstd = putDoc (d $$ bundle) + useAbsoluteOrStd putabs putstd fname + cleanup opts f + safeFileChar :: Char -> Char safeFileChar c | isAlpha c = toLower c | isDigit c = c | isSpace c = '-' safeFileChar _ = '_' -patch_filename :: String -> String -patch_filename the_summary = name ++ ".dpatch" +patchFilename :: String -> String +patchFilename the_summary = name ++ ".dpatch" where name = map safeFileChar the_summary \end{code} @@ -317,11 +328,11 @@ | SendMail String -- ^ send patch via email -decide_on_behavior :: RepoPatch p => [DarcsFlag] -> Repository p -> IO [WhatToDo] -decide_on_behavior opts the_remote_repo = +decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO [WhatToDo] +decideOnBehavior opts the_remote_repo = case the_targets of [] -> - if isJust $ get_output opts "" + if isJust $ getOutput opts "" then return [] else do wtds <- check_post @@ -329,7 +340,7 @@ return wtds ts -> do announce_recipients ts return ts - where the_targets = collect_targets opts + where the_targets = collectTargets opts #ifdef HAVE_HTTP -- the ifdef above is to so that darcs only checks the remote -- _darcs/post if we have an implementation of postUrl. See @@ -352,27 +363,26 @@ `catchall` return "" if '@' `elem` email then return . map SendMail $ lines email else return [] - putInfoLn s = unless (Quiet `elem` opts) $ putStrLn s announce_recipients emails = let pn (SendMail s) = s pn (Post p) = p in if DryRun `elem` opts - then putInfoLn $ "Patch bundle would be sent to: "++unwords (map pn emails) + then putInfo opts . text $ "Patch bundle would be sent to: "++unwords (map pn emails) else when (null the_targets) $ - putInfoLn $ "Patch bundle will be sent to: "++unwords (map pn emails) + putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails) -get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd -get_output (Output a:_) _ = return a -get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f -get_output (_:flags) f = get_output flags f -get_output [] _ = Nothing +getOutput :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd +getOutput (Output a:_) _ = return a +getOutput (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f +getOutput (_:flags) f = getOutput flags f +getOutput [] _ = Nothing -get_targets :: [WhatToDo] -> IO [WhatToDo] -get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? " -get_targets wtds = return wtds +getTargets :: [WhatToDo] -> IO [WhatToDo] +getTargets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? " +getTargets wtds = return wtds -collect_targets :: [DarcsFlag] -> [WhatToDo] -collect_targets flags = [ f t | Target t <- flags ] where +collectTargets :: [DarcsFlag] -> [WhatToDo] +collectTargets flags = [ f t | Target t <- flags ] where f url@('h':'t':'t':'p':':':_) = Post url f em = SendMail em @@ -416,12 +426,12 @@ \end{verbatim} \begin{code} -get_description :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) -> IO (Doc, Maybe String) -get_description opts patches = +getDescription :: RepoPatch p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO (Doc, Maybe String) +getDescription opts their_name patches = case get_filename of Just f -> do file <- f when (EditDescription `elem` opts) $ do - when (isNothing $ get_fileopt opts) $ + when (isNothing $ getFileopt opts) $ writeDocBinFile file patchdesc debugMessage $ "About to edit file " ++ file edit_file file @@ -429,16 +439,21 @@ doc <- readDocBinFile file return (doc, Just file) Nothing -> return (patchdesc, Nothing) - where patchdesc = vsep $ mapFL description patches - get_filename = case get_fileopt opts of + where patchdesc = text (if lengthFL patches == 1 + then "1 patch" + else show (lengthFL patches) ++ " patches") + <+> text "for repository" <+> text their_name <> text ":" + $$ text "" + $$ vsep (mapFL description patches) + get_filename = case getFileopt opts of Just f -> Just $ return $ toFilePath f Nothing -> if EditDescription `elem` opts then Just tempfile else Nothing tempfile = world_readable_temp "darcs-temp-mail" -get_fileopt :: [DarcsFlag] -> Maybe AbsolutePath -get_fileopt (LogFile f:_) = Just f -get_fileopt (_:flags) = get_fileopt flags -get_fileopt [] = Nothing +getFileopt :: [DarcsFlag] -> Maybe AbsolutePath +getFileopt (LogFile f:_) = Just f +getFileopt (_:flags) = getFileopt flags +getFileopt [] = Nothing \end{code} diff --git a/src/Darcs/Commands/SetPref.lhs b/src/Darcs/Commands/SetPref.lhs --- a/src/Darcs/Commands/SetPref.lhs +++ b/src/Darcs/Commands/SetPref.lhs @@ -26,31 +26,31 @@ import Control.Monad (when) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag, working_repo_dir, umask_option ) +import Darcs.Arguments ( DarcsFlag, workingRepoDir, umaskOption ) import Darcs.Repository ( amInRepository, add_to_pending, withRepoLock, ($-) ) import Darcs.Patch ( changepref ) -import Darcs.Ordered ( FL(..) ) -import Darcs.Repository.Prefs ( get_prefval, change_prefval, ) +import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Repository.Prefs ( getPrefval, changePrefval, ) import English ( orClauses ) #include "impossible.h" -- | A list of all valid preferences for @_darcs/prefs/prefs@. -valid_pref_data :: [(String, String)] -- ^ (name, one line description) -valid_pref_data = +validPrefData :: [(String, String)] -- ^ (name, one line description) +validPrefData = [("test", "a shell command that runs regression tests"), ("predist", "a shell command to run before `darcs dist'"), ("boringfile", "the path to a version-controlled boring file"), ("binariesfile", "the path to a version-controlled binaries file")] -valid_prefs :: [String] -valid_prefs = map fst valid_pref_data +validPrefs :: [String] +validPrefs = map fst validPrefData -setpref_description :: String -setpref_description = - "Set a preference (" ++ orClauses valid_prefs ++ ")." +setprefDescription :: String +setprefDescription = + "Set a preference (" ++ orClauses validPrefs ++ ")." -setpref_help :: String -setpref_help = +setprefHelp :: String +setprefHelp = "When working on project with multiple repositories and contributors,\n" ++ "it is sometimes desirable for a preference to be set consistently\n" ++ "project-wide. This is achieved by treating a preference set with\n" ++ @@ -59,7 +59,7 @@ "\n" ++ "Valid preferences are:\n" ++ "\n" ++ - unlines [" "++x++" -- "++y | (x,y) <- valid_pref_data] ++ + unlines [" "++x++" -- "++y | (x,y) <- validPrefData] ++ "\n" ++ "For example, a project using GNU autotools, with a `make test' target\n" ++ "to perform regression tests, might enable Darcs' integrated regression\n" ++ @@ -73,36 +73,36 @@ "low-priority bug, because preferences are seldom set.\n" setpref :: DarcsCommand -setpref = DarcsCommand {command_name = "setpref", - command_help = setpref_help, - command_description = setpref_description, - command_extra_args = 2, - command_extra_arg_help = ["", +setpref = DarcsCommand {commandName = "setpref", + commandHelp = setprefHelp, + commandDescription = setprefDescription, + commandExtraArgs = 2, + commandExtraArgHelp = ["", ""], - command_command = setpref_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return valid_prefs, - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = - [working_repo_dir]} + commandCommand = setprefCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return validPrefs, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = + [workingRepoDir]} -setpref_cmd :: [DarcsFlag] -> [String] -> IO () -setpref_cmd opts [pref,val] = withRepoLock opts $- \repository -> do +setprefCmd :: [DarcsFlag] -> [String] -> IO () +setprefCmd opts [pref,val] = withRepoLock opts $- \repository -> do when (' ' `elem` pref) $ do putStrLn $ "'"++pref++ "' is not a valid preference name: no spaces allowed!" exitWith $ ExitFailure 1 - when (not $ pref `elem` valid_prefs) $ do + when (not $ pref `elem` validPrefs) $ do putStrLn $ "'"++pref++"' is not a valid preference name!" - putStrLn $ "Try one of: " ++ unwords valid_prefs + putStrLn $ "Try one of: " ++ unwords validPrefs exitWith $ ExitFailure 1 - oval <- get_prefval pref + oval <- getPrefval pref old <- case oval of Just v -> return v Nothing -> return "" - change_prefval pref old val + changePrefval pref old val putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'" add_to_pending repository (changepref pref old val :>: NilFL) -setpref_cmd _ _ = impossible +setprefCmd _ _ = impossible \end{code} diff --git a/src/Darcs/Commands/Show.lhs b/src/Darcs/Commands/Show.lhs --- a/src/Darcs/Commands/Show.lhs +++ b/src/Darcs/Commands/Show.lhs @@ -16,52 +16,52 @@ % Boston, MA 02110-1301, USA. \begin{code} -module Darcs.Commands.Show ( show_command, list, query ) where +module Darcs.Commands.Show ( showCommand, list, query ) where import Darcs.Commands ( DarcsCommand(..), - CommandControl(Command_data, Hidden_command), - command_alias, + CommandControl(CommandData, HiddenCommand), + commandAlias, ) -import Darcs.Commands.ShowAuthors ( show_authors ) -import Darcs.Commands.ShowBug ( show_bug ) -import Darcs.Commands.ShowContents ( show_contents ) -import Darcs.Commands.ShowFiles ( show_files, show_manifest ) -import Darcs.Commands.ShowTags ( show_tags ) -import Darcs.Commands.ShowRepo ( show_repo ) -import Darcs.Commands.ShowIndex ( show_index, show_pristine ) +import Darcs.Commands.ShowAuthors ( showAuthors ) +import Darcs.Commands.ShowBug ( showBug ) +import Darcs.Commands.ShowContents ( showContents ) +import Darcs.Commands.ShowFiles ( showFiles, showManifest ) +import Darcs.Commands.ShowTags ( showTags ) +import Darcs.Commands.ShowRepo ( showRepo ) +import Darcs.Commands.ShowIndex ( showIndex, showPristine ) import Darcs.Repository ( amInRepository ) -show_description :: String -show_description = "Show information which is stored by darcs." +showDescription :: String +showDescription = "Show information which is stored by darcs." -show_help :: String -show_help = +showHelp :: String +showHelp = "Use the --help option with the subcommands to obtain help for\n"++ "subcommands (for example, \"darcs show files --help\").\n" ++ "\n" ++ "In previous releases, this command was called `darcs query'.\n" ++ "Currently this is a deprecated alias.\n" -show_command :: DarcsCommand -show_command = SuperCommand {command_name = "show", - command_help = show_help, - command_description = show_description, - command_prereq = amInRepository, - command_sub_commands = [Hidden_command show_bug, - Command_data show_contents, - Command_data show_files, Hidden_command show_manifest, - Command_data show_index, - Command_data show_pristine, - Command_data show_repo, - Command_data show_authors, - Command_data show_tags] +showCommand :: DarcsCommand +showCommand = SuperCommand {commandName = "show", + commandHelp = showHelp, + commandDescription = showDescription, + commandPrereq = amInRepository, + commandSubCommands = [HiddenCommand showBug, + CommandData showContents, + CommandData showFiles, HiddenCommand showManifest, + CommandData showIndex, + CommandData showPristine, + CommandData showRepo, + CommandData showAuthors, + CommandData showTags] } query :: DarcsCommand -query = command_alias "query" show_command +query = commandAlias "query" showCommand list :: DarcsCommand -list = command_alias "list" show_command +list = commandAlias "list" showCommand \end{code} \subsection{darcs show} diff --git a/src/Darcs/Commands/ShowAuthors.lhs b/src/Darcs/Commands/ShowAuthors.lhs --- a/src/Darcs/Commands/ShowAuthors.lhs +++ b/src/Darcs/Commands/ShowAuthors.lhs @@ -1,4 +1,4 @@ -% Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael +% Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml % % 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 @@ -17,30 +17,37 @@ \darcsCommand{show authors} \begin{code} -{-# OPTIONS_GHC -cpp #-} -module Darcs.Commands.ShowAuthors ( show_authors ) where +module Darcs.Commands.ShowAuthors ( showAuthors ) where +import qualified Ratified( readFile ) import Control.Arrow ((&&&), (***)) -import Data.List ( sort, sortBy, group, groupBy, isInfixOf, isPrefixOf ) +import Data.List ( isInfixOf, sortBy, groupBy, group, sort) import Data.Ord (comparing) import Data.Char ( toLower, isSpace ) +import Data.Maybe( isJust ) +import Text.ParserCombinators.Parsec hiding (lower, count, Line) +import Text.ParserCombinators.Parsec.Error import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir ) -import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, putWarning ) import Darcs.External ( viewDoc ) import Darcs.Hopefully ( info ) import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) import Darcs.Patch.Info ( pi_author ) -import Darcs.Ordered ( mapRL, concatRL ) +import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import Printer ( text ) import Data.Function (on) -show_authors_description :: String -show_authors_description = "List authors by patch count." +data Spelling = Spelling String String [Regex] -- name, email, regexps +type ParsedLine = Maybe Spelling -- Nothing for blank lines -show_authors_help :: String -show_authors_help = + +showAuthorsDescription :: String +showAuthorsDescription = "List authors by patch count." + +showAuthorsHelp :: String +showAuthorsHelp = "The `darcs show authors' command lists the authors of the current\n" ++ "repository, sorted by the number of patches contributed. With the\n" ++ "--verbose option, this command simply lists the author of each patch\n" ++ @@ -50,14 +57,23 @@ "when multiple author strings refer to the same individual, create an\n" ++ "`.authorspellings' file in the root of the working tree. Each line in\n" ++ "this file begins with an author's canonical name and address, and may\n" ++ - "be followed by a comma and zero or more extended regular expressions,\n" ++ - "separated by commas. Blank lines and lines beginning with two\n" ++ - "hyphens, are ignored.\n" ++ + "be followed by a comma separated list of extended regular expressions.\n" ++ + "Blank lines and lines beginning with two hyphens are ignored.\n" ++ + "The format of .authorspelling can be described by this pattern:\n" ++ "\n" ++ + " name
[, regexp ]*\n" ++ + "\n" ++ + "There are some pitfalls concerning special characters:\n" ++ + "Whitespaces are stripped, if you need space in regexp use [ ]. \n" ++ + "Because comma serves as a separator you have to escape it if you want\n" ++ + "it in regexp. Note that .authorspelingfile use extended regular\n" ++ + "expressions so +, ? and so on are metacharacters and you need to \n" ++ + "escape them to be interpreted literally.\n" ++ + "\n" ++ "Any patch with an author string that matches the canonical address or\n" ++ "any of the associated regexps is considered to be the work of that\n" ++ "author. All matching is case-insensitive and partial (it can match a\n" ++ - "substring).\n" ++ + "substring). Use ^,$ to match the whole string in regexps\n" ++ "\n" ++ "Currently this canonicalization step is done only in `darcs show\n" ++ "authors'. Other commands, such as `darcs changes' use author strings\n" ++ @@ -67,26 +83,27 @@ "\n" ++ " -- This is a comment.\n" ++ " Fred Nurk \n" ++ - " John Snagge , John, snagge@, js@(si|mit).edu\n" + " John Snagge , John, snagge@, js@(si|mit).edu\n" ++ + " Chuck Jones\\, Jr. , cj\\+user@example.com\n" -show_authors :: DarcsCommand -show_authors = DarcsCommand { - command_name = "authors", - command_help = show_authors_help, - command_description = show_authors_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = authors_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [working_repo_dir] } +showAuthors :: DarcsCommand +showAuthors = DarcsCommand { + commandName = "authors", + commandHelp = showAuthorsHelp, + commandDescription = showAuthorsDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = authorsCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [workingRepoDir] } -authors_cmd :: [DarcsFlag] -> [String] -> IO () -authors_cmd opts _ = withRepository opts $- \repository -> do +authorsCmd :: [DarcsFlag] -> [String] -> IO () +authorsCmd opts _ = withRepository opts $- \repository -> do patches <- read_repo repository - spellings <- compiled_author_spellings + spellings <- compiledAuthorSpellings opts let authors = mapRL (pi_author . info) $ concatRL patches viewDoc $ text $ unlines $ if Verbose `elem` opts @@ -105,56 +122,72 @@ -- Because it would take a long time to canonize "foo" into -- "foo " once per patch, the code below -- generates a list [(count, canonized name)]. - map (length &&& (canonize_author spellings . head)) $ + map (length &&& (canonizeAuthor spellings . head)) $ group $ sort authors -canonize_author :: [(String,[Regex])] -> String -> String -canonize_author [] a = a -canonize_author spellings a = safehead a $ canonicalsfor a - where - safehead x xs = if null xs then x else head xs - canonicalsfor s = map fst $ filter (ismatch s) spellings - ismatch s (canonical,regexps) = - (not (null email) && (s `contains` email)) || (any (s `contains_regex`) regexps) - where email = takeWhile (/= '>') $ drop 1 $ dropWhile (/= '<') canonical - -contains :: String -> String -> Bool -a `contains` b = lower b `isInfixOf` (lower a) where lower = map toLower +canonizeAuthor :: [Spelling] -> String -> String +canonizeAuthor spells author = getName canonicals + where + getName [] = author + getName ((Spelling name email _):_) = name ++ " <" ++ email ++ ">" + canonicals = filter (ismatch author) spells + ismatch s (Spelling _ mail regexps) = + s `correspondsTo` mail || any (s `contains_regex`) regexps + contains_regex a r = isJust $ matchRegex r a + correspondsTo a b = lower b `isInfixOf` lower a + lower = map toLower -contains_regex :: String -> Regex -> Bool -a `contains_regex` r = case matchRegex r a of - Just _ -> True - _ -> False +compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling] +compiledAuthorSpellings opts = do + let as_file = ".authorspellings" + contents <- (Ratified.readFile -- never unlinked from within darcs + as_file `catch` (\_ -> return "")) + let parse_results = map (parse sentence as_file) $ lines contents + clean 1 parse_results + where + clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling] + clean _ [] = return [] + -- print parse error + clean n ((Left err):xs) = do + let npos = setSourceLine (errorPos err) n + putWarning opts . text . show $ setErrorPos npos err + clean (n+1) xs + -- skip blank line + clean n ((Right Nothing):xs) = clean (n+1) xs + -- unwrap Spelling + clean n ((Right (Just a):xs)) = do + as <- clean (n+1) xs + return (a:as) -compiled_author_spellings :: IO [(String,[Regex])] -compiled_author_spellings = do - ss <- author_spellings_from_file - return $ map compile $ ss - where - compile [] = error "each author spelling should contain at least the canonical form" - compile (canonical:pats) = (canonical, map mkregex pats) - mkregex pat = mkRegexWithOpts pat True False +---------- +-- PARSERS -authorspellingsfile :: FilePath -authorspellingsfile = ".authorspellings" +sentence :: Parser ParsedLine +sentence = spaces >> (comment <|> blank <|> addressline) + where + comment = string "--" >> return Nothing + blank = eof >> return Nothing -author_spellings_from_file :: IO [[String]] -author_spellings_from_file = do - s <- readFile -- ratify readFile: never unlinked from within darcs - authorspellingsfile `catch` (\_ -> return "") - let noncomments = filter (not . ("--" `isPrefixOf`)) $ - filter (not . null) $ map strip $ lines s - return $ map (map strip . split_on ',') noncomments +addressline :: Parser ParsedLine +addressline = do + name <- canonicalName "Canonical name" + addr <- between (char '<') (char '>') (many1 (noneOf ">")) "Address" + spaces + rest <- option [] (char ',' >> regexp `sepBy` char ',') "List of regexps" + return $ Just $ Spelling (strip name) addr (compile rest) + where + strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse + makeRegex s = mkRegexWithOpts s True False + compile = map makeRegex . filter (not . null) . map strip -split_on :: Eq a => a -> [a] -> [[a]] -split_on e l = - case dropWhile (e==) l of - [] -> [] - l' -> first : split_on e rest - where - (first,rest) = break (e==) l' +regexp :: Parser String +regexp = many1 p "Regular expression" + where p = try (string "\\," >> return ',') + <|> noneOf "," -strip :: String -> String -strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse +canonicalName :: Parser String +canonicalName = many1 p + where p = try (string "\\," >> return ',') + <|> noneOf ",<" \end{code} diff --git a/src/Darcs/Commands/ShowBug.lhs b/src/Darcs/Commands/ShowBug.lhs --- a/src/Darcs/Commands/ShowBug.lhs +++ b/src/Darcs/Commands/ShowBug.lhs @@ -20,34 +20,34 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Commands.ShowBug ( show_bug ) where +module Darcs.Commands.ShowBug ( showBug ) where import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag, working_repo_dir ) +import Darcs.Arguments ( DarcsFlag, workingRepoDir ) import Darcs.Repository ( findRepository ) #include "impossible.h" -show_bug_description :: String -show_bug_description = "Simulate a run-time failure." +showBugDescription :: String +showBugDescription = "Simulate a run-time failure." -show_bug_help :: String -show_bug_help = +showBugHelp :: String +showBugHelp = "Show bug can be used to see what darcs would show you if you encountered.\n" ++"a bug in darcs.\n" -show_bug :: DarcsCommand -show_bug = DarcsCommand {command_name = "bug", - command_help = show_bug_help, - command_description = show_bug_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = show_bug_cmd, - command_prereq = findRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [working_repo_dir]} +showBug :: DarcsCommand +showBug = DarcsCommand {commandName = "bug", + commandHelp = showBugHelp, + commandDescription = showBugDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = showBugCmd, + commandPrereq = findRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [workingRepoDir]} -show_bug_cmd :: [DarcsFlag] -> [String] -> IO () -show_bug_cmd _ _ = bug "This is actually a fake bug in darcs." +showBugCmd :: [DarcsFlag] -> [String] -> IO () +showBugCmd _ _ = bug "This is actually a fake bug in darcs." \end{code} diff --git a/src/Darcs/Commands/ShowContents.lhs b/src/Darcs/Commands/ShowContents.lhs --- a/src/Darcs/Commands/ShowContents.lhs +++ b/src/Darcs/Commands/ShowContents.lhs @@ -17,56 +17,70 @@ \darcsCommand{show contents} \begin{code} -module Darcs.Commands.ShowContents ( show_contents ) where +module Darcs.Commands.ShowContents ( showContents ) where -import Control.Monad ( filterM ) +import Control.Monad ( filterM, forM_, unless ) +import Control.Monad.Trans( liftIO ) import System.IO ( stdout ) -import System.FilePath.Posix ( takeFileName ) +import Data.Maybe( fromJust ) import qualified Data.ByteString as B -import Workaround ( getCurrentDirectory ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag, match_one, - working_repo_dir, fixSubPaths ) -import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.Arguments ( DarcsFlag, matchOne, + workingRepoDir, fixSubPaths ) +import Darcs.RepoPath ( sp2fn ) import Darcs.IO ( mReadFilePS, mDoesFileExist ) -import Darcs.Match ( get_partial_nonrange_match, have_nonrange_match ) -import Darcs.Repository ( withRepository, ($-), findRepository, - createPartialsPristineDirectoryTree ) -import Darcs.Lock ( withTempDir ) +import Darcs.Patch.Match( Matcher ) +import Darcs.Match ( haveNonrangeMatch, applyInvToMatcher, nonrangeMatcher + , InclusiveOrExclusive(..), matchExists ) +import Darcs.Repository ( withRepository, ($-), findRepository, read_repo, readRecorded ) +import Darcs.Patch( RepoPatch ) +import Storage.Hashed.Monad( virtualTreeIO ) -show_contents_description :: String -show_contents_description = "Outputs a specific version of a file." +showContentsDescription :: String +showContentsDescription = "Outputs a specific version of a file." -show_contents_help :: String -show_contents_help = +showContentsHelp :: String +showContentsHelp = "Show contents can be used to display an earlier version of some file(s).\n"++ "If you give show contents no version arguments, it displays the recorded\n"++ "version of the file(s).\n" -show_contents :: DarcsCommand -show_contents = DarcsCommand {command_name = "contents", - command_help = show_contents_help, - command_description = show_contents_description, - command_extra_args = -1, - command_extra_arg_help +showContents :: DarcsCommand +showContents = DarcsCommand {commandName = "contents", + commandHelp = showContentsHelp, + commandDescription = showContentsDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE]..."], - command_command = show_contents_cmd, - command_prereq = findRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [match_one, working_repo_dir]} + commandCommand = showContentsCmd, + commandPrereq = findRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [matchOne, workingRepoDir]} -show_contents_cmd :: [DarcsFlag] -> [String] -> IO () -show_contents_cmd opts args = withRepository opts $- \repository -> do - formerdir <- getCurrentDirectory +getMatcher :: (RepoPatch p) => [DarcsFlag] -> Matcher p +getMatcher = fromJust . nonrangeMatcher + +showContentsCmd :: [DarcsFlag] -> [String] -> IO () +showContentsCmd _ [] = fail + "show contents needs at least one argument." +showContentsCmd opts args = withRepository opts $- \repository -> do path_list <- map sp2fn `fmap` fixSubPaths opts args - thename <- return $ takeFileName formerdir - withTempDir thename $ \dir -> do - if have_nonrange_match opts - then get_partial_nonrange_match repository opts path_list - else createPartialsPristineDirectoryTree repository path_list (toFilePath dir) - filterM mDoesFileExist path_list >>= mapM_ (\f -> mReadFilePS f >>= B.hPut stdout) + pristine <- readRecorded repository + let matcher = getMatcher opts + unapply_to_match = applyInvToMatcher Exclusive matcher + matched <- if (haveNonrangeMatch opts) + then do patchset <- read_repo repository + unless (matchExists matcher patchset) $ + fail $ "Couldn't match pattern " ++ show matcher + snd `fmap` virtualTreeIO (unapply_to_match patchset) pristine + else return pristine + let dump = do okpaths <- filterM mDoesFileExist path_list + forM_ okpaths $ \f -> do content <- mReadFilePS f + liftIO (B.hPut stdout content) + virtualTreeIO dump matched + return () \end{code} diff --git a/src/Darcs/Commands/ShowFiles.lhs b/src/Darcs/Commands/ShowFiles.lhs --- a/src/Darcs/Commands/ShowFiles.lhs +++ b/src/Darcs/Commands/ShowFiles.lhs @@ -20,20 +20,24 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h" -module Darcs.Commands.ShowFiles ( show_files, show_manifest ) where -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, - files, directories, pending, nullFlag ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +module Darcs.Commands.ShowFiles ( showFiles, showManifest ) where +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, + files, directories, pending, nullFlag, matchOne ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Repository ( Repository, amInRepository, slurp_pending, slurp_recorded, withRepository ) import Darcs.Patch ( RepoPatch ) -import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs ) +import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs, slurp ) +import Data.List( isPrefixOf ) -show_files_description :: String -show_files_description = "Show version-controlled files in the working copy." +import Darcs.Match ( haveNonrangeMatch, getNonrangeMatch ) +import Workaround ( getCurrentDirectory ) +import Darcs.Lock ( withDelayedDir ) +showFilesDescription :: String +showFilesDescription = "Show version-controlled files in the working copy." -show_files_help :: String -show_files_help = +showFilesHelp :: String +showFilesHelp = "The `darcs show files' command lists those files and directories in\n" ++ "the working tree that are under version control. This command is\n" ++ "primarily for scripting purposes; end users will probably want `darcs\n" ++ @@ -57,43 +61,65 @@ "\n" ++ " darcs show files -0 | xargs -0 ls -ldS\n" -show_files :: DarcsCommand -show_files = DarcsCommand { - command_name = "files", - command_help = show_files_help, - command_description = show_files_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = manifest_cmd to_list_files, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [files, directories, pending, nullFlag, - working_repo_dir] } +showFiles :: DarcsCommand +showFiles = DarcsCommand { + commandName = "files", + commandHelp = showFilesHelp, + commandDescription = showFilesDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = manifestCmd toListFiles, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [files, directories, pending, nullFlag, matchOne, + workingRepoDir] } -show_manifest :: DarcsCommand -show_manifest = command_alias "manifest" show_files { - command_command = manifest_cmd to_list_manifest +showManifest :: DarcsCommand +showManifest = commandAlias "manifest" showFiles { + commandCommand = manifestCmd toListManifest } -to_list_files, to_list_manifest :: [DarcsFlag] -> Slurpy -> [FilePath] -to_list_files opts = files_dirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts) -to_list_manifest opts = files_dirs (NoFiles `notElem` opts) (Directories `elem` opts) +toListFiles, toListManifest :: [DarcsFlag] -> Slurpy -> [FilePath] +toListFiles opts = filesDirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts) +toListManifest opts = filesDirs (NoFiles `notElem` opts) (Directories `elem` opts) -files_dirs :: Bool -> Bool -> Slurpy -> [FilePath] -files_dirs False False = \_ -> [] -files_dirs False True = list_slurpy_dirs -files_dirs True False = list_slurpy_files -files_dirs True True = list_slurpy +filesDirs :: Bool -> Bool -> Slurpy -> [FilePath] +filesDirs False False = \_ -> [] +filesDirs False True = list_slurpy_dirs +filesDirs True False = list_slurpy_files +filesDirs True True = list_slurpy -manifest_cmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO () -manifest_cmd to_list opts _ = do - list <- (to_list opts) `fmap` withRepository opts slurp - mapM_ output list - where slurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy - slurp = if NoPending `notElem` opts - then slurp_pending else slurp_recorded +manifestCmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO () +manifestCmd to_list opts argList = do + list <- (to_list opts) `fmap` withRepository opts myslurp + case argList of + [] -> mapM_ output list + prefixes -> mapM_ output (onlysubdirs prefixes list) + where myslurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy + myslurp = do let fRevisioned = haveNonrangeMatch opts + fPending = Pending `elem` opts + fNoPending = NoPending `elem` opts + -- this covers all 8 options + case (fRevisioned,fPending,fNoPending) of + (True,False,_) -> slurp_revision opts + (True,True,_) -> error $ "can't mix revisioned and pending flags" + (False,False,True) -> slurp_recorded + (False,_,False) -> slurp_pending -- pending is default + (False,True,True) -> error $ "can't mix pending and no-pending flags" output_null name = do { putStr name ; putChar '\0' } output = if NullFlag `elem` opts then output_null else putStrLn + isParentDir a b = a == b + || (a ++ "/") `isPrefixOf` b + || ("./" ++ a ++ "/") `isPrefixOf` b + || "./" ++ a == b + onlysubdirs suffixes = filter $ or . mapM isParentDir suffixes + +slurp_revision :: RepoPatch p => [DarcsFlag] -> Repository p C(r u r) -> IO Slurpy +slurp_revision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do + getNonrangeMatch r opts + slurp =<< getCurrentDirectory + + \end{code} diff --git a/src/Darcs/Commands/ShowIndex.lhs b/src/Darcs/Commands/ShowIndex.lhs --- a/src/Darcs/Commands/ShowIndex.lhs +++ b/src/Darcs/Commands/ShowIndex.lhs @@ -25,56 +25,57 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h" -module Darcs.Commands.ShowIndex ( show_index, show_pristine ) where -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, +module Darcs.Commands.ShowIndex ( showIndex, showPristine ) where +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, directories, nullFlag ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) -import Darcs.Repository ( amInRepository, withRepository, ($-) ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) +import Darcs.Repository ( amInRepository, withRepository, ($-), readIndex ) +import Darcs.Repository.State ( readRecorded ) -import Darcs.Gorsvet( readIndex ) -import Storage.Hashed( readDarcsPristine, floatPath ) -import Storage.Hashed.Darcs( darcsFormatHash ) +import Storage.Hashed( floatPath ) +import Storage.Hashed.Hash( encodeBase16, Hash( NoHash ) ) import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) ) +import Storage.Hashed.Index( updateIndex ) import Storage.Hashed.AnchoredPath( anchorPath ) import qualified Data.ByteString.Char8 as BS -show_index :: DarcsCommand -show_index = DarcsCommand { - command_name = "index", - command_description = "Dump contents of working tree index.", - command_help = +showIndex :: DarcsCommand +showIndex = DarcsCommand { + commandName = "index", + commandDescription = "Dump contents of working tree index.", + commandHelp = "The `darcs show index' command lists all version-controlled files and " ++ "directories along with their hashes as stored in _darcs/index. " ++ "For files, the fields correspond to file size, sha256 of the current " ++ "file content and the filename.", - command_extra_args = 0, - command_extra_arg_help = [], - command_command = show_index_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [files, directories, nullFlag, working_repo_dir] } + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = showIndexCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [files, directories, nullFlag, workingRepoDir] } -show_pristine :: DarcsCommand -show_pristine = command_alias "pristine" show_index { - command_command = show_pristine_cmd, - command_description = "Dump contents of pristine cache.", - command_help = +showPristine :: DarcsCommand +showPristine = commandAlias "pristine" showIndex { + commandCommand = showPristineCmd, + commandDescription = "Dump contents of pristine cache.", + commandHelp = "The `darcs show pristine' command lists all version-controlled files " ++ "and directories along with the hashes of their pristine copies. " ++ "For files, the fields correspond to file size, sha256 of the pristine " ++ "file content and the filename." } -dump :: [DarcsFlag] -> Tree -> IO () +dump :: [DarcsFlag] -> Tree IO -> IO () dump opts tree = do let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0' | otherwise = putStrLn output (p, i) = do let hash = case itemHash i of - Just h -> BS.unpack $ darcsFormatHash h - Nothing -> "(no hash available)" + NoHash -> "(no hash available)" + h -> BS.unpack $ encodeBase16 h path = anchorPath "" p isdir = case i of SubTree _ -> "/" @@ -83,12 +84,12 @@ x <- expand tree mapM_ output $ (floatPath ".", SubTree x) : list x -show_index_cmd :: [DarcsFlag] -> [String] -> IO () -show_index_cmd opts _ = withRepository opts $- \repo -> do - readIndex repo >>= dump opts +showIndexCmd :: [DarcsFlag] -> [String] -> IO () +showIndexCmd opts _ = withRepository opts $- \repo -> do + readIndex repo >>= updateIndex >>= dump opts -show_pristine_cmd :: [DarcsFlag] -> [String] -> IO () -show_pristine_cmd opts _ = withRepository opts $- \_ -> do - readDarcsPristine "." >>= dump opts +showPristineCmd :: [DarcsFlag] -> [String] -> IO () +showPristineCmd opts _ = withRepository opts $- \repo -> do + readRecorded repo >>= dump opts \end{code} diff --git a/src/Darcs/Commands/ShowRepo.lhs b/src/Darcs/Commands/ShowRepo.lhs --- a/src/Darcs/Commands/ShowRepo.lhs +++ b/src/Darcs/Commands/ShowRepo.lhs @@ -17,89 +17,60 @@ \darcsCommand{show repo} -The \verb!show repo! displays information about -the current repository: the location, the type, etc. - -This is provided as informational output for two purposes: curious -users and scripts invoking darcs. For the latter, this information -can be parsed to facilitate the script; for example, -\verb!darcs show repo | grep Root: | awk {print $2}! -can be used to locate the -top-level \verb!_darcs! directory from anyplace within a darcs repository -working directory. - \begin{code} {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h" -module Darcs.Commands.ShowRepo ( show_repo ) where +module Darcs.Commands.ShowRepo ( showRepo ) where import Data.Char ( toLower, isSpace ) import Data.List ( intersperse ) import Control.Monad ( when, unless ) import Text.Html ( tag, stringToHtml ) -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, files, xmloutput ) +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, xmloutput ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Repository ( withRepository, ($-), amInRepository, read_repo ) import Darcs.Repository.Internal ( Repository(..), RepoType(..) ) import Darcs.Repository.Format ( RepoFormat(..) ) -import Darcs.Repository.Prefs ( get_preflist ) +import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository.Motd ( get_motd ) import Darcs.Patch ( RepoPatch ) -import Darcs.Ordered ( lengthRL, concatRL ) +import Darcs.Witnesses.Ordered ( lengthRL, concatRL ) import qualified Data.ByteString.Char8 as BC (unpack) -show_repo_help :: String -show_repo_help = - "The repo command displays information about the current repository\n" ++ - "(location, type, etc.). Some of this information is already available\n" ++ - "by inspecting files within the _darcs directory and some is internal\n" ++ - "information that is informational only (i.e. for developers). This\n" ++ - "command collects all of the repository information into a readily\n" ++ - "available source.\n" - -show_repo_description :: String -show_repo_description = "Show repository summary information" - -show_repo :: DarcsCommand -show_repo = DarcsCommand { command_name = "repo", - command_help = show_repo_help, - command_description = show_repo_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = repo_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [working_repo_dir, files, xmloutput] } -\end{code} - -\begin{options} ---files, --no-files -\end{options} - -If the \verb!--files! option is specified (the default), then the -\verb!show repo! operation will read patch information from the -repository and display the number of patches in the repository. The -\verb!--no-files! option can be used to suppress this operation (and -improve performance). +showRepoHelp :: String +showRepoHelp = + "The `darcs show repo' command displays statistics about the current\n" ++ + "repository, allowing third-party scripts to access this information\n" ++ + "without inspecting _darcs directly (and without breaking when the\n" ++ + "_darcs format changes).\n" ++ + "\n" ++ + "By default, the number of patches is shown. If this data isn't\n" ++ + "needed, use --no-files to accelerate this command from O(n) to O(1).\n" ++ + "\n" ++ + "By default, output is in a human-readable format. The --xml-output\n" ++ + "option can be used to generate output for machine postprocessing.\n" -\begin{code} -repo_cmd :: [DarcsFlag] -> [String] -> IO () -repo_cmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr - in withRepository opts $- \repository -> showRepo (putInfo put_mode) repository -\end{code} +showRepoDescription :: String +showRepoDescription = "Show repository summary information" -\begin{options} ---human-readable, --xml-output -\end{options} +showRepo :: DarcsCommand +showRepo = DarcsCommand { commandName = "repo", + commandHelp = showRepoHelp, + commandDescription = showRepoDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = repoCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [workingRepoDir, files, xmloutput] } -By default, the \verb!show repo! displays output in human readable -form, but the \verb!--xml-output! option can be used to obtain -XML-formatted to facilitate regular parsing by external tools. +repoCmd :: [DarcsFlag] -> [String] -> IO () +repoCmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr + in withRepository opts $- \repository -> actuallyShowRepo (putInfo put_mode) repository -\begin{code} -- Some convenience functions to output a labelled text string or an -- XML tag + value (same API). If no value, output is suppressed -- entirely. Borrow some help from Text.Html to perform XML output. @@ -129,8 +100,8 @@ -- sub-displays. The `out' argument is one of the above operations to -- output a labelled text string or an XML tag and contained value. -showRepo :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () -showRepo out r@(Repo loc opts rf rt) = do +actuallyShowRepo :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () +actuallyShowRepo out r@(Repo loc opts rf rt) = do when (XMLOutput `elem` opts) (putStr "\n") showRepoType out rt when (Verbose `elem` opts) (out "Show" $ show r) @@ -162,9 +133,9 @@ showRepoPrefs :: PutInfo -> IO () showRepoPrefs out = do - get_preflist "prefs" >>= mapM_ prefOut - get_preflist "author" >>= out "Author" . unlines - get_preflist "defaultrepo" >>= out "Default Remote" . unlines + getPreflist "prefs" >>= mapM_ prefOut + getPreflist "author" >>= out "Author" . unlines + getPreflist "defaultrepo" >>= out "Default Remote" . unlines where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () diff --git a/src/Darcs/Commands/ShowTags.lhs b/src/Darcs/Commands/ShowTags.lhs --- a/src/Darcs/Commands/ShowTags.lhs +++ b/src/Darcs/Commands/ShowTags.lhs @@ -17,21 +17,21 @@ \darcsCommand{show tags} \begin{code} -module Darcs.Commands.ShowTags ( show_tags ) where -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir ) +module Darcs.Commands.ShowTags ( showTags ) where +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Hopefully ( info ) import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) import Darcs.Patch.Info ( pi_tag ) -import Darcs.Ordered ( mapRL, concatRL ) +import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import System.IO ( stderr, hPutStrLn ) -- import Printer ( renderPS ) -show_tags_description :: String -show_tags_description = "Show all tags in the repository." +showTagsDescription :: String +showTagsDescription = "Show all tags in the repository." -show_tags_help :: String -show_tags_help = +showTagsHelp :: String +showTagsHelp = "The tags command writes a list of all tags in the repository to standard\n"++ "output.\n" ++ "\n" ++ @@ -39,22 +39,22 @@ "for better interoperability with shell tools. A warning is printed if\n" ++ "this happens." -show_tags :: DarcsCommand -show_tags = DarcsCommand { - command_name = "tags", - command_help = show_tags_help, - command_description = show_tags_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = tags_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [working_repo_dir] } +showTags :: DarcsCommand +showTags = DarcsCommand { + commandName = "tags", + commandHelp = showTagsHelp, + commandDescription = showTagsDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = tagsCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [workingRepoDir] } -tags_cmd :: [DarcsFlag] -> [String] -> IO () -tags_cmd opts _ = withRepository opts $- \repository -> do +tagsCmd :: [DarcsFlag] -> [String] -> IO () +tagsCmd opts _ = withRepository opts $- \repository -> do patches <- read_repo repository sequence_ $ mapRL process $ concatRL patches where process hp = diff --git a/src/Darcs/Commands/Tag.lhs b/src/Darcs/Commands/Tag.lhs --- a/src/Darcs/Commands/Tag.lhs +++ b/src/Darcs/Commands/Tag.lhs @@ -18,36 +18,36 @@ \darcsCommand{tag} \begin{code} module Darcs.Commands.Tag ( tag ) where +import System.Directory ( removeFile ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help, - command_description, command_extra_args, - command_extra_arg_help, command_command, command_prereq, - command_get_arg_possibilities, command_argdefaults, - command_advanced_options, command_basic_options), +import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp, + commandDescription, commandExtraArgs, + commandExtraArgHelp, commandCommand, commandPrereq, + commandGetArgPossibilities, commandArgdefaults, + commandAdvancedOptions, commandBasicOptions), nodefaults ) -import Darcs.Arguments ( nocompress, umask_option, patchname_option, author, - checkpoint, pipe_interactive, ask_long_comment, - working_repo_dir, get_author ) +import Darcs.Arguments ( nocompress, umaskOption, patchnameOption, author, + pipeInteractive, askLongComment, + workingRepoDir, getAuthor ) import Darcs.Hopefully ( n2pia ) import Darcs.Repository ( amInRepository, withRepoLock, ($-), read_repo, tentativelyAddPatch, finalizeRepositoryChanges, ) -import Darcs.Repository.Checkpoint ( write_recorded_checkpoint ) import Darcs.Patch ( infopatch, identity, adddeps ) import Darcs.Patch.Info ( patchinfo ) import Darcs.Patch.Depends ( get_tags_right ) -import Darcs.Commands.Record ( get_date, get_log ) -import Darcs.Ordered ( FL(..) ) +import Darcs.Commands.Record ( getDate, getLog ) +import Darcs.Witnesses.Ordered ( FL(..) ) import Darcs.Lock ( world_readable_temp ) import Darcs.Flags ( DarcsFlag(..) ) import System.IO ( hPutStr, stderr ) -tag_description :: String -tag_description = "Name the current repository state for future reference." +tagDescription :: String +tagDescription = "Name the current repository state for future reference." -tag_help :: String -tag_help = +tagHelp :: String +tagHelp = "The `darcs tag' command names the current repository state, so that it\n" ++ "can easily be referred to later. Every `important' state should be\n" ++ "tagged; in particular it is good practice to tag each stable release\n" ++ @@ -67,46 +67,44 @@ "A tag can have any name, but it is generally best to pick a naming\n" ++ "scheme and stick to it.\n" ++ "\n" ++ - "The `darcs tag' command accepts the --pipe and --checkpoint options,\n" ++ - "which behave as described in `darcs record' and `darcs optimize'\n" ++ - "respectively.\n" + "The `darcs tag' command accepts the --pipe option, which behaves as\n" ++ + "described in `darcs record'.\n" tag :: DarcsCommand -tag = DarcsCommand {command_name = "tag", - command_help = tag_help, - command_description = tag_description, - command_extra_args = -1, - command_extra_arg_help = ["[TAGNAME]"], - command_command = tag_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [nocompress,umask_option], - command_basic_options = [patchname_option, author, - checkpoint, - pipe_interactive, - ask_long_comment, - working_repo_dir]} +tag = DarcsCommand {commandName = "tag", + commandHelp = tagHelp, + commandDescription = tagDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[TAGNAME]"], + commandCommand = tagCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [nocompress,umaskOption], + commandBasicOptions = [patchnameOption, author, + pipeInteractive, + askLongComment, + workingRepoDir]} -tag_cmd :: [DarcsFlag] -> [String] -> IO () -tag_cmd opts args = withRepoLock opts $- \repository -> do - date <- get_date opts - the_author <- get_author opts +tagCmd :: [DarcsFlag] -> [String] -> IO () +tagCmd opts args = withRepoLock opts $- \repository -> do + date <- getDate opts + the_author <- getAuthor opts deps <- get_tags_right `fmap` read_repo repository - (name, long_comment) <- get_name_log opts args + (name, long_comment, mlogf) <- get_name_log opts args myinfo <- patchinfo date name the_author long_comment let mypatch = infopatch myinfo identity tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps finalizeRepositoryChanges repository - when (CheckPoint `elem` opts) $ write_recorded_checkpoint repository myinfo + maybe (return ()) removeFile mlogf putStrLn $ "Finished tagging patch '"++name++"'" - where get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String]) + where get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String], Maybe String) get_name_log o a = do let o2 = if null a then o else (add_patch_name o (unwords a)) - (name, comment, _) <- get_log o2 Nothing (world_readable_temp "darcs-tag") NilFL + (name, comment, mlogf) <- getLog o2 Nothing (world_readable_temp "darcs-tag") NilFL when (length name < 2) $ hPutStr stderr $ "Do you really want to tag '" ++name++"'? If not type: darcs obliterate --last=1\n" - return ("TAG " ++ name, comment) + return ("TAG " ++ name, comment, mlogf) add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag] add_patch_name o a| has_patch_name o = o | otherwise = [PatchName a] ++ o diff --git a/src/Darcs/Commands/TrackDown.lhs b/src/Darcs/Commands/TrackDown.lhs --- a/src/Darcs/Commands/TrackDown.lhs +++ b/src/Darcs/Commands/TrackDown.lhs @@ -25,22 +25,24 @@ import Control.Monad( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), working_repo_dir, - set_scripts_executable ) +import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), workingRepoDir, + setScriptsExecutableOption ) import Darcs.Hopefully ( hopefully ) import Darcs.Repository ( amInRepository, read_repo, withRepoReadLock, ($-), withRecorded, setScriptsExecutable ) -import Darcs.Ordered ( unsafeUnRL, concatRL ) -import Darcs.Patch ( RepoPatch, Named, description, apply, invert ) +import Darcs.Witnesses.Ordered ( FL(..), mapRL_RL, concatRL ) +import Darcs.Patch ( RepoPatch, Named, description, apply, invert, invertRL ) import Printer ( putDocLn ) import Darcs.Test ( get_test ) import Darcs.Lock ( withTempDir ) -trackdown_description :: String -trackdown_description = "Locate the most recent version lacking an error." +#include "gadts.h" -trackdown_help :: String -trackdown_help = +trackdownDescription :: String +trackdownDescription = "Locate the most recent version lacking an error." + +trackdownHelp :: String +trackdownHelp = "Trackdown tries to find the most recent version in the repository which\n"++ "passes a test. Given no arguments, it uses the default repository test.\n"++ "Given one argument, it treats it as a test command. Given two arguments,\n"++ @@ -48,21 +50,21 @@ "second is the test command.\n" trackdown :: DarcsCommand -trackdown = DarcsCommand {command_name = "trackdown", - command_help = trackdown_help, - command_description = trackdown_description, - command_extra_args = -1, - command_extra_arg_help = ["[[INITIALIZATION]", +trackdown = DarcsCommand {commandName = "trackdown", + commandHelp = trackdownHelp, + commandDescription = trackdownDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[[INITIALIZATION]", "COMMAND]"], - command_command = trackdown_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [set_scripts_executable], - command_basic_options = [working_repo_dir]} + commandCommand = trackdownCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [setScriptsExecutableOption], + commandBasicOptions = [workingRepoDir]} -trackdown_cmd :: [DarcsFlag] -> [String] -> IO () -trackdown_cmd opts args = withRepoReadLock opts $- \repository -> do +trackdownCmd :: [DarcsFlag] -> [String] -> IO () +trackdownCmd opts args = withRepoReadLock opts $- \repository -> do patches <- read_repo repository (init,test) <- case args of [] -> @@ -79,10 +81,10 @@ withRecorded repository (withTempDir "trackingdown") $ \_ -> do when (SetScriptsExecutable `elem` opts) setScriptsExecutable init - track_next opts test $ map (invert . hopefully) $ unsafeUnRL $ concatRL patches + trackNext opts test . invertRL . mapRL_RL hopefully . concatRL $ patches -track_next :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> [Named p] -> IO () -track_next opts test (p:ps) = do +trackNext :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> FL (Named p) C(x y) -> IO () +trackNext opts test (p:>:ps) = do test_result <- test if test_result == ExitSuccess then putStrLn "Success!" @@ -90,8 +92,8 @@ putStrLn "Trying without the patch:" putDocLn $ description $ invert p hFlush stdout - track_next opts test ps -track_next _ _ [] = putStrLn "Noone passed the test!" + trackNext opts test ps +trackNext _ _ NilFL = putStrLn "Noone passed the test!" \end{code} Trackdown is helpful for locating when something was broken. It creates diff --git a/src/Darcs/Commands/TransferMode.lhs b/src/Darcs/Commands/TransferMode.lhs --- a/src/Darcs/Commands/TransferMode.lhs +++ b/src/Darcs/Commands/TransferMode.lhs @@ -21,7 +21,7 @@ {-# LANGUAGE CPP, PatternGuards #-} -- The pragma above is only for pattern guards. -module Darcs.Commands.TransferMode ( transfer_mode ) where +module Darcs.Commands.TransferMode ( transferMode ) where import Prelude hiding ( catch ) import Control.Exception ( catch ) @@ -29,18 +29,18 @@ import Darcs.Utils ( withCurrentDirectory, prettyException ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag, working_repo_dir ) +import Darcs.Arguments ( DarcsFlag, workingRepoDir ) import Darcs.Repository ( amInRepository ) import Progress ( setProgressMode ) import Darcs.Global ( darcsdir ) import qualified Data.ByteString as B (hPut, readFile, length, ByteString) -transfer_mode_description :: String -transfer_mode_description = "Internal command for efficient ssh transfers." +transferModeDescription :: String +transferModeDescription = "Internal command for efficient ssh transfers." -transfer_mode_help :: String -transfer_mode_help = +transferModeHelp :: String +transferModeHelp = "When pulling from or pushing to a remote repository over ssh, if both\n" ++ "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++ "will be invoked on the remote end. This allows Darcs to intelligently\n" ++ @@ -51,21 +51,21 @@ "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++ "hundreds of times!\n" -transfer_mode :: DarcsCommand -transfer_mode = DarcsCommand {command_name = "transfer-mode", - command_help = transfer_mode_help, - command_description = transfer_mode_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_get_arg_possibilities = return [], - command_command = transfer_mode_cmd, - command_prereq = amInRepository, - command_argdefaults = nodefaults, - command_advanced_options = [], - command_basic_options = [working_repo_dir]} +transferMode :: DarcsCommand +transferMode = DarcsCommand {commandName = "transfer-mode", + commandHelp = transferModeHelp, + commandDescription = transferModeDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandGetArgPossibilities = return [], + commandCommand = transferModeCmd, + commandPrereq = amInRepository, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [], + commandBasicOptions = [workingRepoDir]} -transfer_mode_cmd :: [DarcsFlag] -> [String] -> IO () -transfer_mode_cmd _ _ = do setProgressMode False +transferModeCmd :: [DarcsFlag] -> [String] -> IO () +transferModeCmd _ _ = do setProgressMode False putStrLn "Hello user, I am darcs transfer mode" hFlush stdout withCurrentDirectory darcsdir $ transfer diff --git a/src/Darcs/Commands/Unrecord.lhs b/src/Darcs/Commands/Unrecord.lhs --- a/src/Darcs/Commands/Unrecord.lhs +++ b/src/Darcs/Commands/Unrecord.lhs @@ -20,41 +20,41 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, get_last_patches ) where +module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) -import Darcs.SlurpDirectory ( wait_a_moment ) +import Printer ( text ) import Darcs.Hopefully ( hopefully ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_alias ) -import Darcs.Arguments ( DarcsFlag( Verbose ), - working_repo_dir, nocompress, definePatches, - match_several_or_last, deps_sel, +import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, + putVerbose ) +import Darcs.Arguments ( DarcsFlag, + workingRepoDir, nocompress, definePatches, + matchSeveralOrLast, depsSel, ignoretimes, - all_interactive, umask_option, summary + allInteractive, umaskOption, summary, dryRun, + printDryRunMessageAndExit ) -import Darcs.Match ( first_match, match_first_patchset, match_a_patchread ) +import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread ) import Darcs.Repository ( PatchSet, PatchInfoAnd, withGutsOf, withRepoLock, ($-), tentativelyRemovePatches, finalizeRepositoryChanges, tentativelyAddToPending, applyToWorking, - get_unrecorded, read_repo, amInRepository, - sync_repo, - ) -import Darcs.Patch ( Patchy, RepoPatch, invert, commutex, effect ) -import Darcs.Ordered ( RL(..), (:<)(..), (:>)(..), (:\/:)(..), (+<+), + read_repo, amInRepository + , invalidateIndex, unrecordedChanges ) +import Darcs.Patch ( Patchy, RepoPatch, invert, commute, effect ) +import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (:\/:)(..), (+<+), mapFL_FL, nullFL, - concatRL, reverseRL, mapRL ) + reverseRL, mapRL ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.SelectChanges ( with_selected_last_changes_reversed ) import Progress ( debugMessage ) -import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) -import Darcs.Gorsvet( invalidateIndex ) +import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) #include "gadts.h" -unrecord_description :: String -unrecord_description = +unrecordDescription :: String +unrecordDescription = "Remove recorded patches without changing the working copy." \end{code} @@ -124,8 +124,8 @@ more or fewer patches. \begin{code} -unrecord_help :: String -unrecord_help = +unrecordHelp :: String +unrecordHelp = "Unrecord does the opposite of record in that it makes the changes from\n"++ "patches active changes again which you may record or revert later. The\n"++ "working copy itself will not change.\n"++ @@ -134,56 +134,54 @@ "another user may have already pulled the patch.\n" unrecord :: DarcsCommand -unrecord = DarcsCommand {command_name = "unrecord", - command_help = unrecord_help, - command_description = unrecord_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = unrecord_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [nocompress,umask_option], - command_basic_options = [match_several_or_last, - deps_sel, - all_interactive, - working_repo_dir]} +unrecord = DarcsCommand {commandName = "unrecord", + commandHelp = unrecordHelp, + commandDescription = unrecordDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = unrecordCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [nocompress,umaskOption], + commandBasicOptions = [matchSeveralOrLast, + depsSel, + allInteractive, + workingRepoDir]} -unrecord_cmd :: [DarcsFlag] -> [String] -> IO () -unrecord_cmd opts _ = withRepoLock opts $- \repository -> do - let (logMessage,_,_) = loggers opts +unrecordCmd :: [DarcsFlag] -> [String] -> IO () +unrecordCmd opts _ = withRepoLock opts $- \repository -> do allpatches <- read_repo repository - FlippedSeal patches <- return $ if first_match opts - then get_last_patches opts allpatches + FlippedSeal patches <- return $ if firstMatch opts + then getLastPatches opts allpatches else matchingHead opts allpatches - with_selected_last_changes_reversed "unrecord" opts + with_selected_last_changes_reversed "unrecord" opts Nothing (reverseRL patches) $ \ (_ :> to_unrecord) -> do - when (nullFL to_unrecord) $ do logMessage "No patches selected!" + when (nullFL to_unrecord) $ do putStrLn "No patches selected!" exitWith ExitSuccess - when (Verbose `elem` opts) $ - logMessage "About to write out (potentially) modified patches..." + putVerbose opts $ text + "About to write out (potentially) modified patches..." definePatches to_unrecord invalidateIndex repository withGutsOf repository $ do tentativelyRemovePatches repository opts $ mapFL_FL hopefully to_unrecord finalizeRepositoryChanges repository - sync_repo repository - logMessage "Finished unrecording." + putStrLn "Finished unrecording." -get_last_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r) +getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r) -get_last_patches opts ps = - case match_first_patchset opts ps of +getLastPatches opts ps = + case matchFirstPatchset opts ps of Sealed p1s -> case get_common_and_uncommon (ps,p1s) of - (_,us :\/: _) -> FlippedSeal $ concatRL us + (_,us :\/: _) -> FlippedSeal us -unpull_description :: String -unpull_description = +unpullDescription :: String +unpullDescription = "Opposite of pull; unsafe if patch is not in remote repository." -unpull_help :: String -unpull_help = +unpullHelp :: String +unpullHelp = "Unpull completely removes recorded patches from your local repository.\n"++ "The changes will be undone in your working copy and the patches will not be\n"++ "shown in your changes list anymore.\n"++ @@ -191,24 +189,24 @@ "will lose precious code by unpulling!\n" unpull :: DarcsCommand -unpull = (command_alias "unpull" obliterate) - {command_help = unpull_help, - command_description = unpull_description, - command_command = unpull_cmd} +unpull = (commandAlias "unpull" obliterate) + {commandHelp = unpullHelp, + commandDescription = unpullDescription, + commandCommand = unpullCmd} -unpull_cmd :: [DarcsFlag] -> [String] -> IO () -unpull_cmd = generic_obliterate_cmd "unpull" +unpullCmd :: [DarcsFlag] -> [String] -> IO () +unpullCmd = genericObliterateCmd "unpull" \end{code} \darcsCommand{obliterate} \begin{code} -obliterate_description :: String -obliterate_description = +obliterateDescription :: String +obliterateDescription = "Delete selected patches from the repository. (UNSAFE!)" -obliterate_help :: String -obliterate_help = +obliterateHelp :: String +obliterateHelp = "Obliterate completely removes recorded patches from your local repository.\n"++ "The changes will be undone in your working copy and the patches will not be\n"++ "shown in your changes list anymore.\n"++ @@ -260,67 +258,65 @@ \begin{code} obliterate :: DarcsCommand -obliterate = DarcsCommand {command_name = "obliterate", - command_help = obliterate_help, - command_description = obliterate_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = obliterate_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [nocompress,ignoretimes,umask_option], - command_basic_options = [match_several_or_last, - deps_sel, - all_interactive, - working_repo_dir, - summary]} -obliterate_cmd :: [DarcsFlag] -> [String] -> IO () -obliterate_cmd = generic_obliterate_cmd "obliterate" +obliterate = DarcsCommand {commandName = "obliterate", + commandHelp = obliterateHelp, + commandDescription = obliterateDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = obliterateCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [nocompress,ignoretimes,umaskOption], + commandBasicOptions = [matchSeveralOrLast, + depsSel, + allInteractive, + workingRepoDir, + summary]++ + dryRun} +obliterateCmd :: [DarcsFlag] -> [String] -> IO () +obliterateCmd = genericObliterateCmd "obliterate" --- | generic_obliterate_cmd is the function that executes the "obliterate" and +-- | genericObliterateCmd is the function that executes the "obliterate" and -- "unpull" commands. -generic_obliterate_cmd :: String -- ^ The name under which the command is invoked (@unpull@ or @obliterate@) +genericObliterateCmd :: String -- ^ The name under which the command is invoked (@unpull@ or @obliterate@) -> [DarcsFlag] -- ^ The flags given on the command line -> [String] -- ^ Files given on the command line (unused) -> IO () -generic_obliterate_cmd cmdname opts _ = withRepoLock opts $- \repository -> do - let (logMessage,_,_) = loggers opts - pend <- get_unrecorded repository +genericObliterateCmd cmdname opts _ = withRepoLock opts $- \repository -> do + pend <- unrecordedChanges opts repository [] allpatches <- read_repo repository - FlippedSeal patches <- return $ if first_match opts - then get_last_patches opts allpatches + FlippedSeal patches <- return $ if firstMatch opts + then getLastPatches opts allpatches else matchingHead opts allpatches - with_selected_last_changes_reversed cmdname opts + with_selected_last_changes_reversed cmdname opts Nothing (reverseRL patches) $ \ (_ :> ps) -> - case commutex (pend :< effect ps) of + case commute (effect ps :> pend) of Nothing -> fail $ "Can't "++ cmdname ++ " patch without reverting some unrecorded change." - Just (p_after_pending:<_) -> do - when (nullFL ps) $ do logMessage "No patches selected!" + Just (_ :> p_after_pending) -> do + when (nullFL ps) $ do putStrLn "No patches selected!" exitWith ExitSuccess + printDryRunMessageAndExit "obliterate" opts ps definePatches ps invalidateIndex repository withGutsOf repository $ do tentativelyRemovePatches repository opts (mapFL_FL hopefully ps) tentativelyAddToPending repository opts $ invert $ effect ps finalizeRepositoryChanges repository - debugMessage "Waiting a bit for timestamps to differ..." - wait_a_moment debugMessage "Applying patches to working directory..." applyToWorking repository opts (invert p_after_pending) `catch` \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e) - sync_repo repository - logMessage $ "Finished " ++ present_participle cmdname ++ "." + putStrLn $ "Finished " ++ presentParticiple cmdname ++ "." matchingHead :: Patchy p => [DarcsFlag] -> PatchSet p C(r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r) -matchingHead opts (x:<:_) | or (mapRL (match_a_patchread opts) x) = FlippedSeal x +matchingHead opts (x:<:_) | or (mapRL (matchAPatchread opts) x) = FlippedSeal x matchingHead opts (x:<:xs) = (x +<+) `mapFlipped` matchingHead opts xs matchingHead _ NilRL = FlippedSeal NilRL -present_participle :: String -> String -present_participle v | last v == 'e' = init v ++ "ing" +presentParticiple :: String -> String +presentParticiple v | last v == 'e' = init v ++ "ing" | otherwise = v ++ "ing" \end{code} diff --git a/src/Darcs/Commands/Unrevert.lhs b/src/Darcs/Commands/Unrevert.lhs --- a/src/Darcs/Commands/Unrevert.lhs +++ b/src/Darcs/Commands/Unrevert.lhs @@ -18,30 +18,29 @@ \darcsCommand{unrevert} \begin{code} {-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, GADTs #-} #include "gadts.h" -module Darcs.Commands.Unrevert ( unrevert, write_unrevert ) where +module Darcs.Commands.Unrevert ( unrevert, writeUnrevert ) where import System.Exit ( ExitCode(..), exitWith ) +import Storage.Hashed.Tree( Tree ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( Unified, MarkConflicts ), - ignoretimes, working_repo_dir, - all_interactive, umask_option, + ignoretimes, workingRepoDir, + allInteractive, umaskOption, ) import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-), unrevertUrl, considerMergeToWorking, tentativelyAddToPending, finalizeRepositoryChanges, - sync_repo, get_unrecorded, read_repo, amInRepository, - slurp_recorded, - applyToWorking ) -import Darcs.Patch ( RepoPatch, Prim, commutex, namepatch, fromPrims ) -import Darcs.Ordered ( RL(..), FL(..), (:<)(..), (:>)(..), (:\/:)(..), reverseRL, + readRecorded, + applyToWorking, unrecordedChanges ) +import Darcs.Patch ( RepoPatch, Prim, commute, namepatch, fromPrims ) +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), reverseRL, (+>+) ) import Darcs.SelectChanges ( with_selected_changes_to_files' ) -import Darcs.SlurpDirectory ( Slurpy ) import qualified Data.ByteString as B import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist ) import Darcs.Patch.Depends ( get_common_and_uncommon ) @@ -50,15 +49,15 @@ import IsoDate ( getIsoDateTime ) import Darcs.SignalHandler ( withSignalsBlocked ) import Progress ( debugMessage ) -import Darcs.Sealed ( Sealed(Sealed) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) #include "impossible.h" -unrevert_description :: String -unrevert_description = +unrevertDescription :: String +unrevertDescription = "Undo the last revert (may fail if changes after the revert)." -unrevert_help :: String -unrevert_help = +unrevertHelp :: String +unrevertHelp = "Unrevert is a rescue command in case you accidentally reverted\n" ++ "something you wanted to keep (for example, typing `darcs rev -a'\n" ++ "instead of `darcs rec -a').\n" ++ @@ -68,31 +67,31 @@ "interactive command that will DEFINITELY prevent unreversion.\n" unrevert :: DarcsCommand -unrevert = DarcsCommand {command_name = "unrevert", - command_help = unrevert_help, - command_description = unrevert_description, - command_extra_args = 0, - command_extra_arg_help = [], - command_command = unrevert_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = return [], - command_argdefaults = nodefaults, - command_advanced_options = [umask_option], - command_basic_options = [ignoretimes, - all_interactive, - working_repo_dir]} +unrevert = DarcsCommand {commandName = "unrevert", + commandHelp = unrevertHelp, + commandDescription = unrevertDescription, + commandExtraArgs = 0, + commandExtraArgHelp = [], + commandCommand = unrevertCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = return [], + commandArgdefaults = nodefaults, + commandAdvancedOptions = [umaskOption], + commandBasicOptions = [ignoretimes, + allInteractive, + workingRepoDir]} -unrevert_cmd :: [DarcsFlag] -> [String] -> IO () -unrevert_cmd opts [] = withRepoLock opts $- \repository -> do +unrevertCmd :: [DarcsFlag] -> [String] -> IO () +unrevertCmd opts [] = withRepoLock opts $- \repository -> do us <- read_repo repository - Sealed them <- unrevert_patch_bundle repository - rec <- slurp_recorded repository - unrec <- get_unrecorded repository + Sealed them <- unrevertPatchBundle repository + rec <- readRecorded repository + unrec <- unrecordedChanges opts repository [] case get_common_and_uncommon (us, them) of - (_, (h_us:<:NilRL) :\/: (h_them:<:NilRL)) -> do + (_, h_us :\/: h_them) -> do Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) (reverseRL h_us) (reverseRL h_them) - with_selected_changes_to_files' "unrevert" opts [] pw $ + with_selected_changes_to_files' "unrevert" opts Nothing [] pw $ \ (p :> skipped) -> do tentativelyAddToPending repository opts p withSignalsBlocked $ @@ -100,34 +99,33 @@ applyToWorking repository opts p `catch` \e -> fail ("Error applying unrevert to working directory...\n" ++ show e) - debugMessage "I'm about to write_unrevert." - write_unrevert repository skipped rec (unrec+>+p) - sync_repo repository + debugMessage "I'm about to writeUnrevert." + writeUnrevert repository skipped rec (unrec+>+p) debugMessage "Finished unreverting." - _ -> impossible -unrevert_cmd _ _ = impossible +unrevertCmd _ _ = impossible -write_unrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> Slurpy -> FL Prim C(r x) -> IO () -write_unrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository -write_unrevert repository ps rec pend = do - case commutex (ps :< pend) of +writeUnrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) + -> Tree IO -> FL Prim C(r x) -> IO () +writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository +writeUnrevert repository ps rec pend = do + case commute (pend :> ps) of Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? " case really of ('y':_) -> return () _ -> exitWith $ ExitSuccess - write_unrevert repository NilFL rec pend - Just (_ :< p') -> do + writeUnrevert repository NilFL rec pend + Just (p' :> _) -> do rep <- read_repo repository case get_common_and_uncommon (rep,rep) of (common,_ :\/: _) -> do date <- getIsoDateTime np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') - writeDocBinFile (unrevertUrl repository) $ - make_bundle [Unified] rec common (np :>: NilFL) + bundle <- make_bundle [Unified] rec common (np :>: NilFL) + writeDocBinFile (unrevertUrl repository) bundle where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y) fromRepoPrims _ xs = fromPrims xs -unrevert_patch_bundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p) -unrevert_patch_bundle repository = do +unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p) +unrevertPatchBundle repository = do pf <- B.readFile (unrevertUrl repository) `catchall` fail "There's nothing to unrevert!" case scan_bundle pf of diff --git a/src/Darcs/Commands/WhatsNew.lhs b/src/Darcs/Commands/WhatsNew.lhs --- a/src/Darcs/Commands/WhatsNew.lhs +++ b/src/Darcs/Commands/WhatsNew.lhs @@ -24,43 +24,43 @@ module Darcs.Commands.WhatsNew ( whatsnew ) where import System.Exit ( ExitCode(..), exitWith ) -import Data.List ( sort ) +import Data.List ( sort, (\\) ) import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, lookforadds, - ignoretimes, noskip_boring, - unified, summary, no_cache, +import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds, + ignoretimes, noskipBoring, + unified, summary, noCache, areFileArgs, fixSubPaths, - list_registered_files, + listRegisteredFiles, ) +import Darcs.Flags( isUnified ) import Darcs.RepoPath ( SubPath, sp2fn ) -import Darcs.Repository ( Repository, withRepository, ($-), slurp_recorded, - get_unrecorded_no_look_for_adds, - get_unrecorded_in_files, amInRepository ) -import Darcs.Repository.Prefs ( filetype_function ) -import Darcs.Diff ( unsafeDiff ) -import Darcs.Patch ( RepoPatch, Prim, summarize, apply_to_slurpy, is_hunk ) +import Darcs.Repository ( Repository, withRepository, ($-), + amInRepository + , unrecordedChanges, readRecordedAndPending, readRecorded, readUnrecorded ) +import Darcs.Repository.State( restrictBoring ) +import Darcs.Repository.Prefs ( filetypeFunction ) +import Darcs.Patch ( RepoPatch, Prim, plainSummary, primIsHunk, applyToTree ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.Real ( RealPatch, prim2real ) import Darcs.Patch.FileName ( fn2fp ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch ) -import Darcs.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL ) +import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL ) +import Darcs.Diff( treeDiff ) -import Darcs.Gorsvet( unrecordedChanges, restrictBoring, readRecordedAndPending ) import Storage.Hashed.Monad( virtualTreeIO, exists ) import Storage.Hashed( readPlainTree ) import Storage.Hashed( floatPath ) import Printer ( putDocLn, renderString, vcat, text ) -#include "impossible.h" -whatsnew_description :: String -whatsnew_description = "List unrecorded changes in the working tree." +whatsnewDescription :: String +whatsnewDescription = "List unrecorded changes in the working tree." -whatsnew_help :: String -whatsnew_help = +whatsnewHelp :: String +whatsnewHelp = "The `darcs whatsnew' command lists unrecorded changes to the working\n" ++ "tree. If you specify a set of files and directories, only unrecorded\n" ++ "changes to those files and directories are listed.\n" ++ @@ -89,26 +89,29 @@ "there are no unrecorded changes.\n" whatsnew :: DarcsCommand -whatsnew = DarcsCommand {command_name = "whatsnew", - command_help = whatsnew_help, - command_description = whatsnew_description, - command_extra_args = -1, - command_extra_arg_help = ["[FILE or DIRECTORY]..."], - command_command = whatsnew_cmd, - command_prereq = amInRepository, - command_get_arg_possibilities = list_registered_files, - command_argdefaults = nodefaults, - command_advanced_options = [ignoretimes, noskip_boring, no_cache], - command_basic_options = [summary, unified, +whatsnew = DarcsCommand {commandName = "whatsnew", + commandHelp = whatsnewHelp, + commandDescription = whatsnewDescription, + commandExtraArgs = -1, + commandExtraArgHelp = ["[FILE or DIRECTORY]..."], + commandCommand = whatsnewCmd, + commandPrereq = amInRepository, + commandGetArgPossibilities = listRegisteredFiles, + commandArgdefaults = nodefaults, + commandAdvancedOptions = [ignoretimes, noskipBoring, noCache], + commandBasicOptions = [summary, unified, lookforadds, - working_repo_dir]} + workingRepoDir]} -announce_files :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO () -announce_files repo files = +announceFiles :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO () +announceFiles repo files = when (areFileArgs files) $ do - nonboring <- restrictBoring - working <- nonboring `fmap` readPlainTree "." pristine <- readRecordedAndPending repo + -- TODO this is slightly inefficient, since we should really somehow + -- extract the unrecorded state as a side-effect of unrecordedChanges + index <- readUnrecorded repo + nonboring <- restrictBoring index + working <- nonboring `fmap` readPlainTree "." let paths = map (fn2fp . sp2fn) files check = virtualTreeIO (mapM exists $ map floatPath paths) (in_working, _) <- check working @@ -121,25 +124,27 @@ putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!" maybe_warn _ = return () -whatsnew_cmd :: [DarcsFlag] -> [String] -> IO () -whatsnew_cmd opts' args +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') $- \repository -> do files <- fixSubPaths opts' args - announce_files repository files - all_changes <- get_unrecorded_in_files repository (map sp2fn files) - chold <- get_unrecorded_no_look_for_adds repository (map sp2fn files) - s <- slurp_recorded repository - ftf <- filetype_function - cho_adds :> _ <- return $ partitionRL is_hunk $ reverseFL chold - cha :> _ <- return $ partitionRL is_hunk $ reverseFL all_changes - let chn = unsafeDiff [LookForAdds,Summary] ftf - (fromJust $ apply_to_slurpy (reverseRL cho_adds) s) - (fromJust $ apply_to_slurpy (reverseRL cha) s) + announceFiles repository files + all_changes <- unrecordedChanges opts' repository files + chold <- unrecordedChanges (opts' \\ [LookForAdds]) repository files + pristine <- readRecorded repository + ftf <- filetypeFunction + cho_adds :> _ <- return $ partitionRL primIsHunk $ reverseFL chold + cha :> _ <- return $ partitionRL primIsHunk $ reverseFL all_changes + + cho_adds_t <- applyToTree (reverseRL cho_adds) pristine + cha_t <- applyToTree (reverseRL cha) pristine + chn <- treeDiff ftf cho_adds_t cha_t + exitOnNoChanges (chn, chold) - putDocLn $ summarize chold + putDocLn $ plainSummary chold printSummary chn where lower_as x = vcat $ map (text . l_as) $ lines x l_as ('A':x) = 'a':x @@ -150,21 +155,21 @@ exitOnNoChanges _ = return () printSummary :: FL Prim C(x y) -> IO () printSummary NilFL = return () - printSummary new = putDocLn $ lower_as $ renderString $ summarize new + printSummary new = putDocLn $ lower_as $ renderString $ plainSummary new -whatsnew_cmd opts args +whatsnewCmd opts args | otherwise = withRepository opts $- \repository -> do files <- sort `fmap` fixSubPaths opts args - announce_files repository files + announceFiles repository files changes <- unrecordedChanges opts repository files when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1) printSummary repository $ mapFL_FL prim2real changes where printSummary :: RepoPatch p => Repository p C(r u t) -> FL RealPatch C(r y) -> IO () printSummary _ NilFL = do putStrLn "No changes!" exitWith $ ExitFailure 1 - printSummary r ch | Summary `elem` opts = putDocLn $ summarize ch - | Unified `elem` opts = do s <- slurp_recorded r - contextualPrintPatch s ch + printSummary r ch | Summary `elem` opts = putDocLn $ plainSummary ch + | isUnified opts = do pristine <- readRecorded r + contextualPrintPatch pristine ch | otherwise = printPatch ch \end{code} diff --git a/src/Darcs/CommandsAux.hs b/src/Darcs/CommandsAux.hs --- a/src/Darcs/CommandsAux.hs +++ b/src/Darcs/CommandsAux.hs @@ -23,9 +23,9 @@ module Darcs.CommandsAux ( check_paths, malicious_patches, has_malicious_path, ) where import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) ) -import Darcs.Patch ( Patchy, list_touched_files ) -import Darcs.Ordered ( FL, mapFL ) -import Darcs.Sealed ( Sealed2(..), unseal2 ) +import Darcs.Patch ( Patchy, listTouchedFiles ) +import Darcs.Witnesses.Ordered ( FL, mapFL ) +import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 ) import Darcs.Global ( darcsdir ) import Data.List ( intersect ) import System.FilePath ( splitDirectories ) @@ -74,7 +74,7 @@ malicious_paths :: Patchy p => p C(x y) -> [String] malicious_paths patch = - let paths = list_touched_files patch in + let paths = listTouchedFiles patch in filter is_malicious_path paths {-| diff --git a/src/Darcs/Diff.hs b/src/Darcs/Diff.hs --- a/src/Darcs/Diff.hs +++ b/src/Darcs/Diff.hs @@ -1,375 +1,85 @@ --- Copyright (C) 2002-2003 David Roundy +-- Copyright (C) 2009 Petr Rockai -- --- 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. +-- 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: -- --- 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. +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. -- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} -{-# LANGUAGE CPP #-} - -#include "gadts.h" - -module Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff, sync, cmp -#ifndef GADT_WITNESSES - , diff_files -#endif - ) where - -import System.Posix - ( setFileTimes ) -import System.IO ( IOMode(ReadMode), hFileSize, hClose ) -import System.Directory ( doesDirectoryExist, doesFileExist, - getDirectoryContents, - ) -import Control.Monad ( when ) -import Data.List ( sort -#ifndef GADT_WITNESSES - , intersperse, isPrefixOf -#endif - ) -#ifndef GADT_WITNESSES -import Data.Maybe ( catMaybes ) -#endif - -#ifndef GADT_WITNESSES -import ByteStringUtils ( is_funky, linesPS) -import qualified Data.ByteString.Char8 as BC (last) -import qualified Data.ByteString as B (null, empty, take, ByteString) -#endif -import qualified Data.ByteString as B (hGet, length) +-- 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. -import Darcs.SlurpDirectory ( Slurpy, slurp_name, is_dir, is_file, -#ifndef GADT_WITNESSES - get_slurp, -#endif - get_dircontents, get_filecontents, - get_mtime, get_length, - undefined_time -#ifndef GADT_WITNESSES - , FileContents, undefined_size -#endif - ) -#ifndef GADT_WITNESSES -import System.FilePath.Posix ( () ) -#endif -import Darcs.Patch ( Prim -#ifndef GADT_WITNESSES - , hunk, canonize, rmfile, rmdir - , addfile, adddir - , binary, invert -#endif - ) -#ifndef GADT_WITNESSES -import Darcs.Patch.FileName( fp2fn, breakup ) -#endif -import System.IO ( openBinaryFile ) +module Darcs.Diff( treeDiff ) where +import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) import Darcs.Repository.Prefs ( FileType(..) ) -import Darcs.Flags ( DarcsFlag(..) ) -import Darcs.Utils ( catchall ) -import Darcs.Ordered ( FL(..) -#ifndef GADT_WITNESSES - , (+>+) -#endif - ) -#ifndef GADT_WITNESSES -#include "impossible.h" -#endif - --- | The unsafeDiffAtPaths function calls diff_at_path for a set of files and --- and directories, and returns all changes to those files. It recurses into --- given directories when searching for changes. --- --- Comparing paths and not slurpies is useful when the user --- requests a diff for a file that is created or removed in the working copy: --- then there is no slurpy for the file in the /current/ or /working/ slurpy --- respectively. --- --- The given paths must always be fixed repository paths starting with a --- ".". It is safe to pass overlapping paths. --- --- The booleans in the first argument tell whether to ignore mtimes, whether --- we must look for additions and if we're diffing for a summary only. --- --- It returns an FL of patches, that contains all the changes that have been --- made at all those paths. -unsafeDiffAtPaths :: (Bool, Bool, Bool) -> (FilePath -> FileType) -> - Slurpy -> Slurpy -> [FilePath] -> FL Prim C(x y) -#ifdef GADT_WITNESSES -unsafeDiffAtPaths = undefined -#else -unsafeDiffAtPaths flags filetypeFunction s1 s2 paths = - foldr (+>+) NilFL (catMaybes diffsPerPath) - where diffsPerPath = map differ safePaths - differ = diff_at_path flags filetypeFunction s1 s2 - safePaths = make_nonoverlapping_path_set paths +import Darcs.Patch ( Prim, hunk, canonize, binary + , addfile, rmfile, adddir, rmdir, invert) -diff_at_path :: (Bool, Bool, Bool) -> (FilePath -> FileType) - -> Slurpy -> Slurpy -> FilePath -> Maybe (FL Prim) -diff_at_path (ignoreTimes, lookForAdds, summary) filetypeFunction s1 s2 path = - case (pathIn1, pathIn2) of - (Nothing, Nothing) -> Nothing - (Nothing, Just s2PathSlurpy) -> do - Just $ diff_added summary filetypeFunction initialFps s2PathSlurpy NilFL - (Just s1PathSlurpy, Nothing) -> do - Just $ diff_removed filetypeFunction initialFps s1PathSlurpy NilFL - (Just s1PathSlurpy, Just s2PathSlurpy) -> - Just $ gendiff (ignoreTimes, lookForAdds, summary) filetypeFunction - initialFps s1PathSlurpy s2PathSlurpy NilFL - where pathIn1 = get_slurp (fp2fn path) s1 - pathIn2 = get_slurp (fp2fn path) s2 - initialFps = tail $ reverse (breakup path) +import Storage.Hashed.Tree( diffTrees, zipTrees, TreeItem(..), Tree + , readBlob, emptyBlob ) +import Storage.Hashed.AnchoredPath( AnchoredPath, anchorPath ) -make_nonoverlapping_path_set :: [FilePath] -> [FilePath] -make_nonoverlapping_path_set = map unbreakup . delete_overlapping . map breakup . sort - where - delete_overlapping :: [[FilePath]] -> [[FilePath]] - delete_overlapping (p1:p2:ps) = if p1 `isPrefixOf` p2 - then delete_overlapping (p1:ps) - else p1 : delete_overlapping (p2:ps) - delete_overlapping ps = ps - unbreakup = concat . intersperse "/" -#endif +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import ByteStringUtils( is_funky ) --- The diff function takes a recursive diff of two slurped-up directory trees. --- The code involved is actually pretty trivial. \verb!paranoid_diff! runs a --- diff in which we don't make the assumption that files with the same --- modification time are identical. +#include "gadts.h" -unsafeDiff :: [DarcsFlag] - -> (FilePath -> FileType) -> Slurpy -> Slurpy -> FL Prim C(x y) +treeDiff :: (FilePath -> FileType) -> Tree IO -> Tree IO -> IO (FL Prim C(x y)) #ifdef GADT_WITNESSES -unsafeDiff = undefined +treeDiff = undefined -- Sigh. #else -unsafeDiff opts wt s1 s2 - = case diff_at_path (ignoreTimes, lookForAdds, summary) wt s1 s2 "" of - Just d -> d - _ -> impossible -- because "" always exists in a slurpy - where -- NoSummary/Summary both present gives False - -- Just Summary gives True - -- Just NoSummary gives False - -- Neither gives False - summary = Summary `elem` opts && NoSummary `notElem` opts - lookForAdds = LookForAdds `elem` opts - ignoreTimes = IgnoreTimes `elem` opts - -mk_filepath :: [FilePath] -> FilePath -mk_filepath fps = concat $ intersperse "/" $ reverse fps - -gendiff :: (Bool,Bool,Bool) - -> (FilePath -> FileType) -> [FilePath] -> Slurpy -> Slurpy - -> (FL Prim -> FL Prim) -gendiff opts@(isparanoid,_,_) wt fps s1 s2 - | is_file s1 && is_file s2 = diff_regular_files isparanoid wt f s1 s2 - | is_dir s1 && is_dir s2 = - let fps' = case n2 of - "." -> fps - _ -> n2:fps - in fps' `seq` recur_diff opts (wt . (n2)) fps' dc1 dc2 - | otherwise = id - where n2 = slurp_name s2 - f = mk_filepath (n2:fps) - dc1 = get_dircontents s1 - dc2 = get_dircontents s2 - --- recur_diff or recursive diff --- First parameter is (IgnoreTimes?, LookforAdds?, Summary?) -recur_diff :: (Bool,Bool,Bool) - -> (FilePath -> FileType) -> [FilePath] -> [Slurpy] -> [Slurpy] - -> (FL Prim -> FL Prim) -recur_diff _ _ _ [] [] = id -recur_diff opts@(_,doadd,summary) wt fps (s:ss) (s':ss') - -- this is the case if a file has been removed in the working directory - | s < s' = diff_removed wt fps s . recur_diff opts wt fps ss (s':ss') - -- this next case is when there is a file in the directory that is not - -- in the repository (ie, not managed by darcs) - | s > s' = let rest = recur_diff opts wt fps (s:ss) ss' - in if not doadd then rest - else diff_added summary wt fps s' . rest - -- actually compare the files because the names match - | s == s' = gendiff opts wt fps s s' . recur_diff opts wt fps ss ss' -recur_diff opts wt fps (s:ss) [] = - diff_removed wt fps s . recur_diff opts wt fps ss [] -recur_diff opts@(_,True,summary) wt fps [] (s':ss') = - diff_added summary wt fps s' . recur_diff opts wt fps [] ss' -recur_diff (_,False,_) _ _ [] _ = id -recur_diff _ _ _ _ _ = impossible - --- diff, taking into account paranoidness and file type, two regular files -diff_regular_files :: Bool -> (FilePath -> FileType) -> FilePath -> Slurpy -> Slurpy -> (FL Prim -> FL Prim) -diff_regular_files ignoreTimes filetypeFunction f s1 s2 = - if maybe_differ - then case filetypeFunction (slurp_name s2) of - TextFile -> diff_files f b1 b2 - BinaryFile -> if b1 /= b2 then (binary f b1 b2:>:) - else id - else id - where maybe_differ = ignoreTimes - || get_mtime s1 == undefined_time - || get_mtime s1 /= get_mtime s2 - || get_length s1 == undefined_size - || get_length s1 /= get_length s2 - b1 = get_filecontents s1 - b2 = get_filecontents s2 - --- creates a diff for a file or directory which needs to be added to the --- repository -diff_added :: Bool -> (FilePath -> FileType) -> [FilePath] -> Slurpy - -> (FL Prim -> FL Prim) -diff_added summary wt fps s - | is_file s = case wt n of - TextFile -> (addfile f:>:) . - (if summary - then id - else diff_from_empty id f (get_filecontents s)) - BinaryFile -> (addfile f:>:) . - (if summary then id else - (bin_patch f B.empty (get_filecontents s))) - | otherwise {- is_dir s -} = - (adddir f:>:) - . foldr (.) id (map (diff_added summary wt (n:fps)) (get_dircontents s)) - where n = slurp_name s - f = mk_filepath (n:fps) - -get_text :: FileContents -> [B.ByteString] -get_text = linesPS - -empt :: FileContents -empt = B.empty - -diff_files :: FilePath -> FileContents -> FileContents - -> (FL Prim -> FL Prim) -diff_files f o n | get_text o == [B.empty] && get_text n == [B.empty] = id - | get_text o == [B.empty] = diff_from_empty id f n - | get_text n == [B.empty] = diff_from_empty invert f o -diff_files f o n = if o == n - then id - else if has_bin o || has_bin n - then (binary f o n:>:) - else (canonize (hunk f 1 (linesPS o) (linesPS n)) +>+) - -diff_from_empty :: (Prim -> Prim) -> FilePath -> FileContents - -> (FL Prim -> FL Prim) -diff_from_empty inv f b = - if b == B.empty - then id - else let p = if has_bin b - then binary f B.empty b - else if BC.last b == '\n' - then hunk f 1 [] $ init $ linesPS b - else hunk f 1 [B.empty] $ linesPS b - in (inv p:>:) - -{- | We take a B.ByteString which represents a file's contents, and we check to see -whether it is a 'binary' file or a 'textual' file. We define a textual file as any file -which does not contain two magic characters, '\0' (the NULL character on Unix) and '^Z' -(Control-Z, a DOS convention). - -Note that to improve performance, we won't examine *all* of the string, because that -falls down on large files, but just the first 4096 characters. -} -has_bin :: FileContents -> Bool -has_bin = is_funky . B.take 4096 -#endif - -#ifndef GADT_WITNESSES -bin_patch :: FilePath -> B.ByteString -> B.ByteString - -> FL Prim -> FL Prim -bin_patch f o n | B.null o && B.null n = id - | otherwise = (binary f o n:>:) -#endif - -#ifndef GADT_WITNESSES -diff_removed :: (FilePath -> FileType) -> [FilePath] -> Slurpy - -> (FL Prim -> FL Prim) -diff_removed wt fps s - | is_file s = case wt n of - TextFile -> diff_files f (get_filecontents s) empt - . (rmfile f:>:) - BinaryFile -> (bin_patch f - (get_filecontents s) B.empty) - . (rmfile f:>:) - | otherwise {- is_dir s -} - = foldr (.) (rmdir f:>:) - $ map (diff_removed wt (n:fps)) (get_dircontents s) - where n = slurp_name s - f = mk_filepath (n:fps) +treeDiff ft t1 t2 = do + (from, to) <- diffTrees t1 t2 + diffs <- sequence $ zipTrees diff from to + return $ foldr (+>+) NilFL diffs + where diff :: AnchoredPath -> Maybe (TreeItem IO) -> Maybe (TreeItem IO) + -> IO (FL Prim) + diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL + diff p (Just (SubTree _)) Nothing = + return $ rmdir (anchorPath "" p) :>: NilFL + diff p Nothing (Just (SubTree _)) = + return $ adddir (anchorPath "" p) :>: NilFL + diff p Nothing b'@(Just (File _)) = + do diff' <- diff p (Just (File emptyBlob)) b' + return $ addfile (anchorPath "" p) :>: diff' + diff p a'@(Just (File _)) Nothing = + do diff' <- diff p a' (Just (File emptyBlob)) + return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL) + diff p (Just (File a')) (Just (File b')) = + do a <- 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 binary path (strict a) (strict b) :>: NilFL + else NilFL + diff p _ _ = fail $ "Missing case at path " ++ show p + text_diff p a b + | BL.null a && BL.null b = NilFL + | BL.null a = diff_from_empty p b + | BL.null b = diff_to_empty p a + | otherwise = line_diff p (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 . is_funky . strict . BL.take 4096 + linesB = map strict . BLC.split '\n' + strict = BS.concat . BL.toChunks #endif -sync :: String -> Slurpy -> Slurpy -> IO () -sync path s1 s2 - | is_file s1 && is_file s2 && - (get_mtime s1 == undefined_time || get_mtime s1 /= get_mtime s2) && - get_length s1 == get_length s2 && - get_filecontents s1 == get_filecontents s2 = - set_mtime n (get_mtime s2) - | is_dir s1 && is_dir s2 - = n2 `seq` recur_sync n (get_dircontents s1) (get_dircontents s2) - | otherwise = return () - where n2 = slurp_name s2 - n = path++"/"++n2 - set_mtime fname ctime = setFileTimes fname ctime ctime - `catchall` return () - recur_sync _ [] _ = return () - recur_sync _ _ [] = return () - recur_sync p (s:ss) (s':ss') - | s < s' = recur_sync p ss (s':ss') - | s > s' = recur_sync p (s:ss) ss' - | otherwise = do sync p s s' - recur_sync p ss ss' - - -cmp :: FilePath -> FilePath -> IO Bool -cmp p1 p2 = do - dir1 <- doesDirectoryExist p1 - dir2 <- doesDirectoryExist p2 - file1 <- doesFileExist p1 - file2 <- doesFileExist p2 - if dir1 && dir2 - then cmpdir p1 p2 - else if file1 && file2 - then cmpfile p1 p2 - else return False -cmpdir :: FilePath -> FilePath -> IO Bool -cmpdir d1 d2 = do - fn1 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d1 - fn2 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d2 - if sort fn1 /= sort fn2 - then return False - else andIO $ map (\fn-> cmp (d1++"/"++fn) (d2++"/"++fn)) fn1 -andIO :: [IO Bool] -> IO Bool -andIO (iob:iobs) = do b <- iob - if b then andIO iobs else return False -andIO [] = return True -cmpfile :: FilePath -> FilePath -> IO Bool -cmpfile f1 f2 = do - h1 <- openBinaryFile f1 ReadMode - h2 <- openBinaryFile f2 ReadMode - l1 <- hFileSize h1 - l2 <- hFileSize h2 - if l1 /= l2 - then do hClose h1 - hClose h2 - putStrLn $ "different file lengths for "++f1++" and "++f2 - return False - else do b <- hcmp h1 h2 - when (not b) $ putStrLn $ "files "++f1++" and "++f2++" differ" - hClose h1 - hClose h2 - return b - where hcmp h1 h2 = do c1 <- B.hGet h1 1024 - c2 <- B.hGet h2 1024 - if c1 /= c2 - then return False - else if B.length c1 == 1024 - then hcmp h1 h2 - else return True diff --git a/src/Darcs/Email.hs b/src/Darcs/Email.hs --- a/src/Darcs/Email.hs +++ b/src/Darcs/Email.hs @@ -4,7 +4,7 @@ import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf ) -import qualified UTF8 ( encode ) +import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS) import ByteStringUtils (dropSpace, linesPS, betweenLinesPS ) @@ -53,7 +53,7 @@ -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte safeEncChunkLength = (qline_max - B.length encoded_word_start - B.length encoded_word_end) `div` 12 - (curSpace, afterCurSpace) = break (not . (== ' ')) s + (curSpace, afterCurSpace) = span (== ' ') s (curWord, afterCurWord) = break (== ' ') afterCurSpace qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord) | otherwise = qEncode curWord diff --git a/src/Darcs/External.hs b/src/Darcs/External.hs --- a/src/Darcs/External.hs +++ b/src/Darcs/External.hs @@ -10,17 +10,19 @@ execDocPipe, execPipeIgnoreError, getTermNColors, pipeDoc, pipeDocSSH, execSSH, + remoteDarcsCmd, maybeURLCmd, Cachable(Cachable, Uncachable, MaxAge), viewDoc, viewDocWith, - sendmail_path, diff_program + sendmail_path, diff_program, darcs_program ) where +import qualified Ratified import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( when, zipWithM_, filterM, liftM2 ) import System.Exit ( ExitCode(..) ) -import System.Environment ( getEnv ) -import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose, +import System.Environment ( getEnv, getProgName ) +import System.IO ( hPutStr, hPutStrLn, hClose, openBinaryFile, IOMode( ReadMode ), openBinaryTempFile, hIsTerminalDevice, stdout, stderr, Handle ) @@ -49,14 +51,14 @@ import System.FilePath.Posix ( (), takeDirectory, normalise ) import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks, - Verify, VerifySSL ) ) + Verify, VerifySSL, RemoteDarcs ) ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, ) import Progress ( withoutProgress, progressList, debugMessage ) import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS) -import qualified Data.ByteString as B (ByteString, empty, null, readFile -- ratify readFile: Just an import from ByteString - ,hGetContents, writeFile, hPut, length -- ratify hGetContents: importing from ByteString +import qualified Data.ByteString as B (ByteString, empty, null, readFile + ,hGetContents, writeFile, hPut, length ,take, concat, drop, isPrefixOf, singleton, append) import qualified Data.ByteString.Char8 as BC (unpack, pack) @@ -88,6 +90,11 @@ when (null l) $ fail "Cannot find the \"diff\" program." return $ head l +-- |Get the name of the darcs executable (as supplied by @getProgName@) +darcs_program :: IO String +darcs_program = getProgName +-- Another option: getEnv "DARCS" `catch` \_ -> getProgName + backupByRenaming :: FilePath -> IO () backupByRenaming = backupBy rename where rename x y = do @@ -123,19 +130,23 @@ -- will use a cache as required by its second argument. fetchFilePS :: String -> Cachable -> IO B.ByteString fetchFilePS fou _ | is_file fou = B.readFile fou -fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache +fetchFilePS fou cache = withTemp $ \t -> do let opts = [] -- FIXME: no network flags + copyFileOrUrl opts fou t cache B.readFile t gzFetchFilePS :: String -> Cachable -> IO B.ByteString gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou -gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache +gzFetchFilePS fou cache = withTemp $ \t-> do let opts = [] -- FIXME: no network flags + copyFileOrUrl opts fou t cache gzReadFilePS t +remoteDarcsCmd :: [DarcsFlag] -> String +remoteDarcsCmd flags = head $ [ c | (RemoteDarcs c) <- flags ] ++ ["darcs"] copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO () copyFileOrUrl opts fou out _ | is_file fou = copyLocal opts fou out copyFileOrUrl _ fou out cache | is_url fou = copyRemote fou out cache -copyFileOrUrl _ fou out _ | is_ssh fou = copySSH fou out +copyFileOrUrl opts fou out _ | is_ssh fou = copySSH (remoteDarcsCmd opts) fou out copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou speculateFileOrUrl :: String -> FilePath -> IO () @@ -240,7 +251,7 @@ copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO () copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out copyFilesOrUrls _ dou ns out c | is_url dou = copyRemotes dou ns out c -copyFilesOrUrls _ dou ns out _ | is_ssh dou = copySSHs dou ns out +copyFilesOrUrls opts dou ns out _ | is_ssh dou = copySSHs (remoteDarcsCmd opts) dou ns out copyFilesOrUrls _ dou _ _ _ = fail $ "unknown transport protocol: "++dou @@ -306,11 +317,11 @@ do debugMessage $ unwords (c:args) (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing mvare <- newEmptyMVar - forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed + forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed hPutStr stderr) `finally` putMVar mvare ()) mvaro <- newEmptyMVar - forkIO ((hGetContents o >>= -- ratify hGetContents: it's immediately consumed + forkIO ((Ratified.hGetContents o >>= -- ratify: immediately consumed hPutStr stdout) `finally` putMVar mvaro ()) hPutDoc i inp @@ -485,7 +496,7 @@ do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing forkIO $ hPutDoc i instr >> hClose i mvare <- newEmptyMVar - forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed + forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed hPutStr stderr) `finally` putMVar mvare ()) out <- B.hGetContents o @@ -503,7 +514,7 @@ do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing forkIO $ hPutDoc i instr >> hClose i mvare <- newEmptyMVar - forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed + forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed hPutStr stderr) `finally` putMVar mvare ()) out <- B.hGetContents o @@ -620,8 +631,9 @@ viewDocWith pr msg = do isTerminal <- hIsTerminalDevice stdout if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg) - then do viewer <- get_viewer - pipeDocToPager viewer [] pr msg + then do viewerPlusArgs <- get_viewer + let (viewer:args) = words viewerPlusArgs + pipeDocToPager viewer args pr msg `ortryrunning` pipeDocToPager "less" [] pr msg `ortryrunning` pipeDocToPager "more" [] pr msg #ifdef WIN32 diff --git a/src/Darcs/FilePathMonad.hs b/src/Darcs/FilePathMonad.hs --- a/src/Darcs/FilePathMonad.hs +++ b/src/Darcs/FilePathMonad.hs @@ -25,7 +25,7 @@ import Data.Maybe ( catMaybes ) import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) -import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, super_name, break_on_dir, +import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, superName, break_on_dir, norm_path, movedirfilename ) #include "impossible.h" @@ -60,7 +60,7 @@ if d == d' then Just f' else Nothing mGetDirectoryContents = - FPM $ \fs -> (fs, filter (\f -> fp2fn "." == super_name f) fs) + FPM $ \fs -> (fs, filter (\f -> fp2fn "." == superName f) fs) mReadFilePS = bug "can't mReadFilePS in FilePathMonad!" instance WriteableDirectory FilePathMonad where diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs --- a/src/Darcs/Flags.hs +++ b/src/Darcs/Flags.hs @@ -15,16 +15,21 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, want_external_merge, isInteractive, - maxCount, +module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, + want_external_merge, isInteractive, + maxCount, willIgnoreTimes, willRemoveLogFile, isUnified, + willStoreInMemory, doHappyForwarding, includeBoring, + doAllowCaseOnly, doAllowWindowsReserved, doReverse, + showChangesOnlyToFiles ) where +import Data.Maybe( fromMaybe ) import Darcs.Patch.MatchData ( PatchMatch ) import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd ) -- | The 'DarcsFlag' type is a list of all flags that can ever be -- passed to darcs, or to one of its commands. data DarcsFlag = Help | ListOptions | NoTest | Test - | OnlyChangesToFiles + | OnlyChangesToFiles | ChangesToAllFiles | LeaveTestDir | NoLeaveTestDir | Timings | Debug | DebugVerbose | DebugHTTP | Verbose | NormalVerbosity | Quiet @@ -38,22 +43,27 @@ | NumberPatches | OneTag String | AfterTag String | UpToTag String | Context AbsolutePath | Count - | LogFile AbsolutePath | RmLogFile + | LogFile AbsolutePath | RmLogFile | DontRmLogFile | DistName String | All | Recursive | NoRecursive | Reorder | RestrictPaths | DontRestrictPaths - | AskDeps | NoAskDeps | IgnoreTimes | LookForAdds | NoLookForAdds + | AskDeps | NoAskDeps | IgnoreTimes | DontIgnoreTimes + | LookForAdds | NoLookForAdds | AnyOrder | CreatorHash String | Intersection | Union | Complement | Sign | SignAs String | NoSign | SignSSL String - | HappyForwarding + | HappyForwarding | NoHappyForwarding | Verify AbsolutePath | VerifySSL AbsolutePath | SSHControlMaster | NoSSHControlMaster + | RemoteDarcs String | EditDescription | NoEditDescription | Toks String | EditLongComment | NoEditLongComment | PromptLongComment | AllowConflicts | MarkConflicts | NoAllowConflicts - | Boring | AllowCaseOnly | AllowWindowsReserved + | SkipConflicts + | Boring | SkipBoring + | AllowCaseOnly | DontAllowCaseOnly + | AllowWindowsReserved | DontAllowWindowsReserved | DontGrabDeps | DontPromptForDependencies | PromptForDependencies | Compress | NoCompress | UnCompress | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String @@ -63,8 +73,8 @@ | Pipe | Interactive | DiffCmd String | ExternalMerge String | Summary | NoSummary - | Unified | Reverse - | CheckPoint | Partial | Complete | Lazy | Ephemeral + | Unified | NonUnified | Reverse | Forward + | Partial | Complete | Lazy | Ephemeral | FixFilePath AbsolutePath AbsolutePath | DiffFlags String | XMLOutput | ForceReplace @@ -78,12 +88,14 @@ | UseFormat2 | PristinePlain | PristineNone | NoUpdateWorking | Sibling AbsolutePath | Relink | RelinkPristine | NoLinks + | OptimizePristine + | UpgradeFormat | Files | NoFiles | Directories | NoDirectories | Pending | NoPending | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook | PrehookCmd String | NoPrehook | AskPrehook | RunPrehook | UMask String - | StoreInMemory + | StoreInMemory | ApplyOnDisk | HTTPPipelining | NoHTTPPipelining | NoCache | AllowUnrelatedRepos @@ -114,3 +126,43 @@ maxCount (MaxCount n : _) = Just n maxCount (_:xs) = maxCount xs maxCount [] = Nothing + +-- | @lastWord [(flag, value)] default opts@ scans @opts@ for a flag +-- in the list and returns the value of the first match, or @default@ +-- if none is found. +lastWord :: [(DarcsFlag,a)] -> a -> [DarcsFlag] -> a +lastWord known_flags = foldr . flip $ \ def -> fromMaybe def . flip lookup known_flags + +getBoolFlag :: DarcsFlag -> DarcsFlag -> [DarcsFlag] -> Bool +getBoolFlag t f = lastWord [(t, True), (f, False)] False + +willIgnoreTimes :: [DarcsFlag] -> Bool +willIgnoreTimes = getBoolFlag IgnoreTimes DontIgnoreTimes + +willRemoveLogFile :: [DarcsFlag] -> Bool +willRemoveLogFile = getBoolFlag RmLogFile DontRmLogFile + +isUnified :: [DarcsFlag] -> Bool +isUnified = getBoolFlag Unified NonUnified + +willStoreInMemory :: [DarcsFlag] -> Bool +willStoreInMemory = getBoolFlag Unified NonUnified + +doHappyForwarding :: [DarcsFlag] -> Bool +doHappyForwarding = getBoolFlag HappyForwarding NoHappyForwarding + +includeBoring :: [DarcsFlag] -> Bool +includeBoring = getBoolFlag Boring SkipBoring + +doAllowCaseOnly :: [DarcsFlag] -> Bool +doAllowCaseOnly = getBoolFlag AllowCaseOnly DontAllowCaseOnly + + +doAllowWindowsReserved :: [DarcsFlag] -> Bool +doAllowWindowsReserved = getBoolFlag AllowWindowsReserved DontAllowWindowsReserved + +doReverse :: [DarcsFlag] -> Bool +doReverse = getBoolFlag Reverse Forward + +showChangesOnlyToFiles :: [DarcsFlag] -> Bool +showChangesOnlyToFiles = getBoolFlag OnlyChangesToFiles ChangesToAllFiles diff --git a/src/Darcs/Global.hs b/src/Darcs/Global.hs --- a/src/Darcs/Global.hs +++ b/src/Darcs/Global.hs @@ -26,9 +26,7 @@ timingsMode, setTimingsMode, whenDebugMode, withDebugMode, setDebugMode, debugMessage, debugFail, putTiming, -#ifdef HAVE_HASKELL_ZLIB addCRCWarning, getCRCWarnings, resetCRCWarnings, -#endif darcsdir ) where @@ -36,9 +34,7 @@ import Control.Concurrent.MVar import Control.Exception (bracket_, catch, block, unblock) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -#ifdef HAVE_HASKELL_ZLIB import Data.IORef ( modifyIORef ) -#endif import System.IO.Unsafe (unsafePerformIO) import System.IO (hPutStrLn, hPutStr, stderr) import System.Time ( calendarTimeToString, toCalendarTime, getClockTime ) @@ -139,7 +135,6 @@ sshControlMasterDisabled :: Bool sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled -#ifdef HAVE_HASKELL_ZLIB type CRCWarningList = [FilePath] {-# NOINLINE _crcWarningList #-} _crcWarningList :: IORef CRCWarningList @@ -153,7 +148,6 @@ resetCRCWarnings :: IO () resetCRCWarnings = writeIORef _crcWarningList [] -#endif darcsdir :: String darcsdir = "_darcs" diff --git a/src/Darcs/Gorsvet.hs b/src/Darcs/Gorsvet.hs deleted file mode 100644 --- a/src/Darcs/Gorsvet.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE CPP, FlexibleInstances #-} -{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} - --- Copyright (C) 2009 Petr Rockai --- --- Permission is hereby granted, free of charge, to any person --- obtaining a copy of this software and associated documentation --- files (the "Software"), to deal in the Software without --- restriction, including without limitation the rights to use, copy, --- modify, merge, publish, distribute, sublicense, and/or sell copies --- of the Software, and to permit persons to whom the Software is --- furnished to do so, subject to the following conditions: --- --- The above copyright notice and this permission notice shall be --- included in all copies or substantial portions of the Software. --- --- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, --- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND --- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS --- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN --- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN --- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE --- SOFTWARE. - -#include "gadts.h" - -module Darcs.Gorsvet where - -import Prelude hiding ( all, filter, lines, read, readFile, writeFile ) - --- darcs stuff -import ByteStringUtils( is_funky ) -import Darcs.Repository ( Repository, slurp_pending ) -import Darcs.Repository.Internal ( read_pending ) -import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply - , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert) -import Darcs.Ordered ( FL(..), (+>+) ) -import Darcs.Repository.Prefs ( filetype_function, FileType(..) ) -import Darcs.IO -import Darcs.Sealed ( Sealed(Sealed), seal ) -import Darcs.Patch( apply_to_filepaths ) -import Darcs.Patch.Patchy ( Apply ) -import Darcs.Patch.TouchesFiles ( choose_touching ) -import Darcs.Patch.FileName ( fn2fp, FileName ) - -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS -import Control.Monad.State.Strict -import System.Directory( removeFile, doesFileExist ) -import Data.Maybe -import Data.List( union ) - -import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) ) -import Darcs.RepoPath ( SubPath, sp2fn ) - -import Text.Regex( matchRegex ) -import Darcs.Repository.Prefs( boring_regexps ) - -import Storage.Hashed -import Storage.Hashed.Tree -import qualified Storage.Hashed.Index as I -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Darcs( darcsFormatHash, darcsTreeHash ) -import Storage.Hashed.Monad - ( virtualTreeIO, hashedTreeIO, plainTreeIO - , unlink, rename, createDirectory, writeFile - , readFile -- ratify readFile: haskell_policy je natvrdlá - , cwd, tree, TreeIO ) -import Storage.Hashed - -floatFn :: FileName -> AnchoredPath -floatFn = floatPath . fn2fp - -instance ReadableDirectory TreeIO where - mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d)) - mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f)) - mInCurrentDirectory d action = do -- TODO bracket? - wd <- gets cwd - modify (\x -> x { cwd = floatFn d }) - x <- action - modify (\x' -> x' { cwd = wd }) - return x - mGetDirectoryContents = error "get dir contents" - mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ... - return $ BS.concat (BL.toChunks x) - -instance WriteableDirectory TreeIO where - mWithCurrentDirectory = mInCurrentDirectory - mSetFileExecutable _ _ = return () - mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid. - (floatFn p) (BL.fromChunks [ps]) - mCreateDirectory p = createDirectory (floatFn p) - mRename from to = rename (floatFn from) (floatFn to) - mRemoveDirectory = unlink . floatFn - mRemoveFile = unlink . floatFn - -treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim C(x y)) -#ifdef GADT_WITNESSES -treeDiff = undefined -- Sigh. -#else -treeDiff ft t1 t2 = do - (from, to) <- diffTrees t1 t2 - diffs <- sequence $ zipTrees diff from to - return $ foldr (+>+) NilFL diffs - where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem - -> IO (FL Prim) - diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL - diff p (Just (SubTree _)) Nothing = - return $ rmdir (anchorPath "" p) :>: NilFL - diff p Nothing (Just (SubTree _)) = - return $ adddir (anchorPath "" p) :>: NilFL - diff p Nothing b'@(Just (File _)) = - do diff' <- diff p (Just (File emptyBlob)) b' - return $ addfile (anchorPath "" p) :>: diff' - diff p a'@(Just (File _)) Nothing = - do diff' <- diff p a' (Just (File emptyBlob)) - return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL) - diff p (Just (File a')) (Just (File b')) = - do a <- read a' - b <- read b' - let path = anchorPath "" p - case ft path of - TextFile | no_bin a && no_bin b -> - return $ text_diff path a b - _ -> return $ if a /= b - then binary path (strict a) (strict b) :>: NilFL - else NilFL - diff p _ _ = fail $ "Missing case at path " ++ show p - text_diff p a b - | BL.null a && BL.null b = NilFL - | BL.null a = diff_from_empty p b - | BL.null b = diff_to_empty p a - | otherwise = line_diff p (lines a) (lines b) - line_diff p a b = canonize (hunk p 1 a b) - diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) [] - | otherwise = line_diff p (lines x) [BS.empty] - diff_from_empty p x = invert (diff_to_empty p x) - no_bin = not . is_funky . strict . BL.take 4096 - lines = map strict . BL.split '\n' - strict = BS.concat . BL.toChunks -#endif - -readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO Tree -readRecorded _ = readDarcsPristine "." - -readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree -readRecordedAndPending repo = do - pristine <- readRecorded repo - Sealed pending <- pendingChanges repo [] - applyToTree pending pristine - -pendingChanges :: (RepoPatch p) => Repository p C(r u t) - -> [SubPath] -> IO (Sealed (FL Prim C(r))) -pendingChanges repo paths = do - slurp_pending repo -- XXX: only here to get us the "pending conflicts" check - -- that I don't know yet how to implement properly - Sealed pending <- read_pending repo - let files = map (fn2fp . sp2fn) paths - pre_files = apply_to_filepaths (invert pending) files - relevant = case paths of - [] -> seal pending - _ -> choose_touching pre_files pending - return relevant - -applyToTree :: (Apply p) => p C(x y) -> Tree -> IO Tree -applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t - -unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) - -> [SubPath] -> IO (FL Prim C(r y)) -unrecordedChanges opts repo paths = do - pristine <- readDarcsPristine "." - Sealed pending <- pendingChanges repo paths - (_, current') <- virtualTreeIO (apply [] pending) pristine - relevant <- restrictSubpaths repo paths - nonboring <- restrictBoring - - let current = relevant current' - working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of - (False, False) -> do - all <- readIndex repo - expand (relevant all) - (False, True) -> do - guide <- expand current - all <- readPlainTree "." - return $ relevant $ (restrict guide) all - -- TODO (True, False) could use a more efficient implementation... - (True, _) -> do - all <- readPlainTree "." - return $ relevant $ nonboring all - - ft <- filetype_function - diff <- treeDiff ft current working - return $ sort_coalesceFL (pending +>+ diff) - -applyToTentativePristine :: (Apply p) => t -> p C(x y) -> IO () -applyToTentativePristine _ patches = - do pristine <- readDarcsPristine "." - (_, t) <- hashedTreeIO (apply [] patches) - pristine "_darcs/pristine.hashed" - BS.writeFile "_darcs/tentative_pristine" $ - BS.concat [BS.pack "pristine:" - , darcsFormatHash (fromJust $ treeHash t)] - -applyToWorking :: (RepoPatch p) => Repository p C(r u t) - -> Sealed (FL Prim C(u)) -> IO Tree -applyToWorking repo (Sealed patches) = - do working <- readIndex repo - snd `fmap` plainTreeIO (apply [] patches) working "." - -filter_paths :: [AnchoredPath] -> AnchoredPath -> t -> Bool -filter_paths files = - \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files - -restrict_paths :: [AnchoredPath] -> Tree -> Tree -restrict_paths files = if null files - then id - else filter $ filter_paths files - -restrict_subpaths :: [SubPath] -> Tree -> Tree -restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn) - -restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree -> Tree) -restrictSubpaths repo subpaths = do - Sealed pending <- read_pending repo - let paths = map (fn2fp . sp2fn) subpaths - paths' = paths `union` apply_to_filepaths pending paths - anchored = map floatPath paths' - return $ restrict_paths anchored - -restrictBoring :: IO (Tree -> Tree) -restrictBoring = do - boring <- boring_regexps - let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False - boring' p _ = not $ any (\rx -> isJust $ matchRegex rx p') boring - where p' = anchorPath "" p - return $ filter boring' - -readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO Tree -readIndex repo = do - invalid <- doesFileExist "_darcs/index_invalid" - exist <- doesFileExist "_darcs/index" - format_valid <- if exist - then I.indexFormatValid "_darcs/index" - else return True - when (exist && not format_valid) $ removeFile "_darcs/index" - if (not exist || invalid || not format_valid) - then do pris <- readRecordedAndPending repo - idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris - when invalid $ removeFile "_darcs/index_invalid" - return idx - else I.readIndex "_darcs/index" darcsTreeHash - -invalidateIndex :: t -> IO () -invalidateIndex _ = do - BS.writeFile "_darcs/index_invalid" BS.empty diff --git a/src/Darcs/Hopefully.hs b/src/Darcs/Hopefully.hs --- a/src/Darcs/Hopefully.hs +++ b/src/Darcs/Hopefully.hs @@ -35,8 +35,8 @@ import Darcs.Patch.Prim ( Effect(..), Conflict(..) ) import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..), ShowPatch(..), Commute(..) ) -import Darcs.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) ) -import Darcs.Sealed ( Sealed(Sealed), seal, mapSeal ) +import Darcs.Witnesses.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) import Darcs.Utils ( prettyException ) -- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a @@ -73,7 +73,7 @@ piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b) piap i p = PIAP i (Hopefully $ Actually p) --- | @n2pia@ creates a PatchInfoAnd represeting a @Named@ patch. +-- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch. n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y) n2pia x = patch2patchinfo x `piap` x @@ -140,9 +140,9 @@ showPatch (PIAP n p) = case hopefully2either p of Right x -> showPatch x Left _ -> human_friendly n - showContextPatch s (PIAP n p) = case hopefully2either p of - Right x -> showContextPatch s x - Left _ -> human_friendly n + showContextPatch (PIAP n p) = case hopefully2either p of + Right x -> showContextPatch x + Left _ -> return $ human_friendly n description (PIAP n _) = human_friendly n summary (PIAP n p) = case hopefully2either p of Right x -> summary x @@ -154,9 +154,10 @@ instance Commute p => Commute (PatchInfoAnd p) where commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) return $ (info y `piap` y') :> (info x `piap` x') - list_touched_files = list_touched_files . hopefully + listTouchedFiles = listTouchedFiles . hopefully merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x') + hunkMatches _ _ = error "hunkmatches not implemented for PatchInfoAnd" instance Apply p => Apply (PatchInfoAnd p) where apply opts p = apply opts $ hopefully p @@ -176,8 +177,8 @@ effectRL = effectRL . hopefully instance Conflict p => Conflict (PatchInfoAnd p) where - list_conflicted_files = list_conflicted_files . hopefully - resolve_conflicts = resolve_conflicts . hopefully + listConflictedFiles = listConflictedFiles . hopefully + resolveConflicts = resolveConflicts . hopefully commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y) return (info y `piap` y' :> info x `piap` x') conflictedEffect = conflictedEffect . hopefully diff --git a/src/Darcs/IO.hs b/src/Darcs/IO.hs --- a/src/Darcs/IO.hs +++ b/src/Darcs/IO.hs @@ -33,7 +33,8 @@ ) import ByteStringUtils ( linesPS, unlinesPS) -import qualified Data.ByteString as B (ByteString, empty, null, readFile) +import qualified Data.ByteString as B (ByteString, empty, null, readFile, concat) +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BC (unpack, pack) import Darcs.Utils ( withCurrentDirectory, prettyException ) @@ -43,6 +44,9 @@ import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS ) import Workaround ( setExecutable ) +import qualified Storage.Hashed.Monad as HSM +import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath ) + class (Functor m, MonadPlus m) => ReadableDirectory m where mDoesDirectoryExist :: FileName -> m Bool mDoesFileExist :: FileName -> m Bool @@ -247,3 +251,23 @@ backup :: FileName -> IO () backup f = backupByRenaming $ fn2fp f + +floatFn :: FileName -> AnchoredPath +floatFn = floatPath . fn2fp + +instance (MonadPlus m, MonadError e m) => ReadableDirectory (HSM.TreeMonad m) where + mDoesDirectoryExist d = HSM.directoryExists (floatFn d) + mDoesFileExist f = HSM.fileExists (floatFn f) + mInCurrentDirectory d action = HSM.withDirectory (floatFn d) action + mGetDirectoryContents = error "get dir contents" + mReadFilePS p = do x <- HSM.readFile (floatFn p) + return $ B.concat (BL.toChunks x) + +instance (Functor m, MonadPlus m, MonadError e m) => WriteableDirectory (HSM.TreeMonad m) where + mWithCurrentDirectory = mInCurrentDirectory + mSetFileExecutable _ _ = return () + mWriteFilePS p ps = HSM.writeFile (floatFn p) (BL.fromChunks [ps]) + mCreateDirectory p = HSM.createDirectory (floatFn p) + mRename from to = HSM.rename (floatFn from) (floatFn to) + mRemoveDirectory = HSM.unlink . floatFn + mRemoveFile = HSM.unlink . floatFn diff --git a/src/Darcs/Lock.hs b/src/Darcs/Lock.hs --- a/src/Darcs/Lock.hs +++ b/src/Darcs/Lock.hs @@ -28,6 +28,7 @@ rm_recursive, removeFileMayNotExist, canonFilename, maybeRelink, world_readable_temp, tempdir_loc, + editText, environmentHelpTmpdir, environmentHelpKeepTmpdir ) where @@ -48,7 +49,7 @@ ) import System.FilePath.Posix ( splitDirectories ) import Workaround ( renameFile ) -import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO ) +import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, run_editor ) import Control.Monad ( unless, when ) import Darcs.URL ( is_relative ) @@ -57,7 +58,7 @@ getCurrentDirectory, setCurrentDirectory ) import ByteStringUtils ( gzWriteFilePSs) -import qualified Data.ByteString as B (null, readFile, hPut, ByteString) +import qualified Data.ByteString as B (null, readFile, writeFile, hPut, ByteString) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.SignalHandler ( withSignalsBlocked ) @@ -272,13 +273,18 @@ wrt 100 = fail $ "Failure creating temp named "++f wrt n = let f_new = f++"-"++show n in do ok <- takeFile f_new - if ok then do atexit $ removeFileMayNotExist f_new - return f_new + if ok then return f_new else wrt (n+1) withNamedTemp :: String -> (String -> IO a) -> IO a withNamedTemp n = bracket get_empty_file removeFileMayNotExist where get_empty_file = world_readable_temp n + +editText :: String -> B.ByteString -> IO B.ByteString +editText desc txt = withNamedTemp desc $ \f -> do + B.writeFile f txt + run_editor f + B.readFile f readBinFile :: FilePathLike p => p -> IO String readBinFile = fmap BC.unpack . B.readFile . toFilePath diff --git a/src/Darcs/Match.lhs b/src/Darcs/Match.lhs --- a/src/Darcs/Match.lhs +++ b/src/Darcs/Match.lhs @@ -21,19 +21,20 @@ #include "gadts.h" -module Darcs.Match ( match_first_patchset, match_second_patchset, - match_patch, - match_a_patch, match_a_patchread, - get_first_match, get_nonrange_match, - get_partial_first_match, get_partial_second_match, - get_partial_nonrange_match, - first_match, second_match, have_nonrange_match, - have_patchset_match, get_one_patchset, - checkMatchSyntax, +module Darcs.Match ( matchFirstPatchset, matchSecondPatchset, + matchPatch, + matchAPatch, matchAPatchread, + getFirstMatch, getNonrangeMatch, + getPartialFirstMatch, getPartialSecondMatch, + getPartialNonrangeMatch, + firstMatch, secondMatch, haveNonrangeMatch, + havePatchsetMatch, getOnePatchset, + checkMatchSyntax, applyInvToMatcher, nonrangeMatcher, + InclusiveOrExclusive(..), matchExists ) where import Text.Regex ( mkRegex, matchRegex ) -import Control.Monad ( when ) +import Control.Monad ( when, unless ) import Data.Maybe ( isJust ) import Darcs.Hopefully ( PatchInfoAnd, info, piap, @@ -44,17 +45,16 @@ slurp_recorded, createPristineDirectoryTree ) import Darcs.Repository.ApplyPatches ( apply_patches ) import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag ) -import Darcs.Ordered ( RL(..), concatRL, consRLSealed ) +import Darcs.Witnesses.Ordered ( RL(..), concatRL, consRLSealed ) import ByteStringUtils ( mmapFilePS ) import qualified Data.ByteString as B (ByteString) import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context, - StoreInMemory, AfterPatch, UpToPatch, LastN, PatchIndexRange, OneTag, AfterTag, UpToTag, OnePattern, SeveralPattern, - AfterPattern, UpToPattern ) ) + AfterPattern, UpToPattern ), willStoreInMemory ) import Darcs.Patch.Bundle ( scan_context ) import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch ) import Darcs.Patch.MatchData ( PatchMatch ) @@ -63,8 +63,8 @@ import Darcs.RepoPath ( toFilePath ) import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy ) -import Darcs.Patch.FileName ( FileName, super_name, norm_path, (///) ) -import Darcs.Sealed ( FlippedSeal(..), Sealed2(..), +import Darcs.Patch.FileName ( FileName, superName, norm_path, (///) ) +import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..), seal, flipSeal, seal2, unsealFlipped, unseal2, unseal ) #include "impossible.h" \end{code} @@ -107,96 +107,96 @@ \begin{code} data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq --- | @have_nonrange_match flags@ tells whether there is a flag in +-- | @haveNonrangeMatch flags@ tells whether there is a flag in -- @flags@ which corresponds to a match that is "non-range". Thus, --- @--match@, @--patch@ and @--index@ make @have_nonrange_match@ +-- @--match@, @--patch@ and @--index@ make @haveNonrangeMatch@ -- true, but not @--from-patch@ or @--to-patch@. -have_nonrange_match :: [DarcsFlag] -> Bool -have_nonrange_match fs = isJust (has_index_range fs) || isJust (nonrange_matcher fs::Maybe (Matcher Patch)) +haveNonrangeMatch :: [DarcsFlag] -> Bool +haveNonrangeMatch fs = isJust (hasIndexRange fs) || isJust (nonrangeMatcher fs::Maybe (Matcher Patch)) --- | @have_patchset_match flags@ tells whether there is a "patchset +-- | @havePatchsetMatch flags@ tells whether there is a "patchset -- match" in the flag list. A patchset match is @--match@ or -- @--patch@, or @--context@, but not @--from-patch@ nor (!) -- @--index@. --- Question: Is it supposed not to be a subset of @have_nonrange_match@? -have_patchset_match :: [DarcsFlag] -> Bool -have_patchset_match fs = isJust (nonrange_matcher fs::Maybe (Matcher Patch)) || hasC fs +-- Question: Is it supposed not to be a subset of @haveNonrangeMatch@? +havePatchsetMatch :: [DarcsFlag] -> Bool +havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher Patch)) || hasC fs where hasC [] = False hasC (Context _:_) = True hasC (_:xs) = hasC xs -get_nonrange_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () -get_nonrange_match r fs = withRecordedMatchSmart fs r (get_nonrange_match_s fs) +getNonrangeMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () +getNonrangeMatch r fs = withRecordedMatchSmart fs r (getNonrangeMatchS fs) -get_partial_nonrange_match :: RepoPatch p => Repository p C(r u t) +getPartialNonrangeMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [FileName] -> IO () -get_partial_nonrange_match r fs files = - withRecordedMatchOnlySomeSmart fs r files (get_nonrange_match_s fs) +getPartialNonrangeMatch r fs files = + withRecordedMatchOnlySomeSmart fs r files (getNonrangeMatchS fs) -get_nonrange_match_s :: (MatchMonad m p, RepoPatch p) => +getNonrangeMatchS :: (MatchMonad m p, RepoPatch p) => [DarcsFlag] -> PatchSet p C(x) -> m () -get_nonrange_match_s fs repo = - case nonrange_matcher fs of - Just m -> if nonrange_matcher_is_tag fs - then get_tag_s m repo - else get_matcher_s Exclusive m repo - Nothing -> fail "Pattern not specified in get_nonrange_match." +getNonrangeMatchS fs repo = + case nonrangeMatcher fs of + Just m -> if nonrangeMatcherIsTag fs + then getTagS m repo + else getMatcherS Exclusive m repo + Nothing -> fail "Pattern not specified in getNonrangeMatch." --- | @first_match fs@ tells whether @fs@ implies a "first match", that +-- | @firstMatch fs@ tells whether @fs@ implies a "first match", that -- is if we match against patches from a point in the past on, rather -- than against all patches since the creation of the repository. -first_match :: [DarcsFlag] -> Bool -first_match fs = isJust (has_lastn fs) - || isJust (first_matcher fs::Maybe (Matcher Patch)) - || isJust (has_index_range fs) +firstMatch :: [DarcsFlag] -> Bool +firstMatch fs = isJust (hasLastn fs) + || isJust (firstMatcher fs::Maybe (Matcher Patch)) + || isJust (hasIndexRange fs) -get_first_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () -get_first_match r fs = withRecordedMatchSmart fs r (get_first_match_s fs) +getFirstMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () +getFirstMatch r fs = withRecordedMatchSmart fs r (getFirstMatchS fs) -get_partial_first_match :: RepoPatch p => Repository p C(r u t) +getPartialFirstMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [FileName] -> IO () -get_partial_first_match r fs files = - withRecordedMatchOnlySomeSmart fs r files (get_first_match_s fs) +getPartialFirstMatch r fs files = + withRecordedMatchOnlySomeSmart fs r files (getFirstMatchS fs) -get_first_match_s :: (MatchMonad m p, RepoPatch p) => +getFirstMatchS :: (MatchMonad m p, RepoPatch p) => [DarcsFlag] -> PatchSet p C(x) -> m () -get_first_match_s fs repo = - case has_lastn fs of +getFirstMatchS fs repo = + case hasLastn fs of Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo) - Nothing -> case first_matcher fs of - Nothing -> fail "Pattern not specified in get_first_match." - Just m -> if first_matcher_is_tag fs - then get_tag_s m repo - else get_matcher_s Inclusive m repo + Nothing -> case firstMatcher fs of + Nothing -> fail "Pattern not specified in getFirstMatch." + Just m -> if firstMatcherIsTag fs + then getTagS m repo + else getMatcherS Inclusive m repo --- | @second_match fs@ tells whether @fs@ implies a "second match", that +-- | @secondMatch fs@ tells whether @fs@ implies a "second match", that -- is if we match against patches up to a point in the past on, rather -- than against all patches until now. -second_match :: [DarcsFlag] -> Bool -second_match fs = isJust (second_matcher fs::Maybe (Matcher Patch)) || isJust (has_index_range fs) +secondMatch :: [DarcsFlag] -> Bool +secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher Patch)) || isJust (hasIndexRange fs) -get_partial_second_match :: RepoPatch p => Repository p C(r u t) +getPartialSecondMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [FileName] -> IO () -get_partial_second_match r fs files = +getPartialSecondMatch r fs files = withRecordedMatchOnlySomeSmart fs r files $ \repo -> - case second_matcher fs of + case secondMatcher fs of Nothing -> fail "Two patterns not specified in get_second_match." - Just m -> if second_matcher_is_tag fs - then get_tag_s m repo - else get_matcher_s Exclusive m repo + Just m -> if secondMatcherIsTag fs + then getTagS m repo + else getMatcherS Exclusive m repo checkMatchSyntax :: [DarcsFlag] -> IO () checkMatchSyntax opts = do - case get_match_pattern opts of + case getMatchPattern opts of Nothing -> return () Just p -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun Patch)) -get_match_pattern :: [DarcsFlag] -> Maybe PatchMatch -get_match_pattern [] = Nothing -get_match_pattern (OnePattern m:_) = Just m -get_match_pattern (SeveralPattern m:_) = Just m -get_match_pattern (_:fs) = get_match_pattern fs +getMatchPattern :: [DarcsFlag] -> Maybe PatchMatch +getMatchPattern [] = Nothing +getMatchPattern (OnePattern m:_) = Just m +getMatchPattern (SeveralPattern m:_) = Just m +getMatchPattern (_:fs) = getMatchPattern fs tagmatch :: String -> Matcher p tagmatch r = make_matcher ("tag-name "++r) tm @@ -219,138 +219,138 @@ -- subset. This subset is formed by the patches in a given interval -- which match a given criterion. If we represent time going left to -- right (which means the 'PatchSet' is written right to left), then --- we have (up to) three 'Matcher's: the 'nonrange_matcher' is the +-- we have (up to) three 'Matcher's: the 'nonrangeMatcher' is the -- criterion we use to select among patches in the interval, the --- 'first_matcher' is the left bound of the interval, and the +-- 'firstMatcher' is the left bound of the interval, and the -- 'last_matcher' is the right bound. Each of these matchers can be -- present or not according to the options. strictJust :: a -> Maybe a strictJust x = Just $! x --- | @nonrange_matcher@ is the criterion that is used to match against +-- | @nonrangeMatcher@ is the criterion that is used to match against -- patches in the interval. It is 'Just m' when the @--patch@, @--match@, -- @--tag@ options are passed (or their plural variants). -nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) -nonrange_matcher [] = Nothing -nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m -nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t -nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p -nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m -nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p -nonrange_matcher (_:fs) = nonrange_matcher fs +nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) +nonrangeMatcher [] = Nothing +nonrangeMatcher (OnePattern m:_) = strictJust $ match_pattern m +nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t +nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p +nonrangeMatcher (SeveralPattern m:_) = strictJust $ match_pattern m +nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p +nonrangeMatcher (_:fs) = nonrangeMatcher fs --- | @nonrange_matcher_is_tag@ returns true if the matching option was +-- | @nonrangeMatcherIsTag@ returns true if the matching option was -- '--tag' -nonrange_matcher_is_tag :: [DarcsFlag] -> Bool -nonrange_matcher_is_tag [] = False -nonrange_matcher_is_tag (OneTag _:_) = True -nonrange_matcher_is_tag (_:fs) = nonrange_matcher_is_tag fs +nonrangeMatcherIsTag :: [DarcsFlag] -> Bool +nonrangeMatcherIsTag [] = False +nonrangeMatcherIsTag (OneTag _:_) = True +nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs --- | @first_matcher@ returns the left bound of the matched interval. +-- | @firstMatcher@ returns the left bound of the matched interval. -- This left bound is also specified when we use the singular versions --- of @--patch@, @--match@ and @--tag@. Otherwise, @first_matcher@ +-- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@ -- returns @Nothing@. -first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) -first_matcher [] = Nothing -first_matcher (OnePattern m:_) = strictJust $ match_pattern m -first_matcher (AfterPattern m:_) = strictJust $ match_pattern m -first_matcher (AfterTag t:_) = strictJust $ tagmatch t -first_matcher (OnePatch p:_) = strictJust $ mymatch p -first_matcher (AfterPatch p:_) = strictJust $ mymatch p -first_matcher (_:fs) = first_matcher fs +firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) +firstMatcher [] = Nothing +firstMatcher (OnePattern m:_) = strictJust $ match_pattern m +firstMatcher (AfterPattern m:_) = strictJust $ match_pattern m +firstMatcher (AfterTag t:_) = strictJust $ tagmatch t +firstMatcher (OnePatch p:_) = strictJust $ mymatch p +firstMatcher (AfterPatch p:_) = strictJust $ mymatch p +firstMatcher (_:fs) = firstMatcher fs -first_matcher_is_tag :: [DarcsFlag] -> Bool -first_matcher_is_tag [] = False -first_matcher_is_tag (AfterTag _:_) = True -first_matcher_is_tag (_:fs) = first_matcher_is_tag fs +firstMatcherIsTag :: [DarcsFlag] -> Bool +firstMatcherIsTag [] = False +firstMatcherIsTag (AfterTag _:_) = True +firstMatcherIsTag (_:fs) = firstMatcherIsTag fs -second_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) -second_matcher [] = Nothing -second_matcher (OnePattern m:_) = strictJust $ match_pattern m -second_matcher (UpToPattern m:_) = strictJust $ match_pattern m -second_matcher (OnePatch p:_) = strictJust $ mymatch p -second_matcher (UpToPatch p:_) = strictJust $ mymatch p -second_matcher (UpToTag t:_) = strictJust $ tagmatch t -second_matcher (_:fs) = second_matcher fs +secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) +secondMatcher [] = Nothing +secondMatcher (OnePattern m:_) = strictJust $ match_pattern m +secondMatcher (UpToPattern m:_) = strictJust $ match_pattern m +secondMatcher (OnePatch p:_) = strictJust $ mymatch p +secondMatcher (UpToPatch p:_) = strictJust $ mymatch p +secondMatcher (UpToTag t:_) = strictJust $ tagmatch t +secondMatcher (_:fs) = secondMatcher fs -second_matcher_is_tag :: [DarcsFlag] -> Bool -second_matcher_is_tag [] = False -second_matcher_is_tag (UpToTag _:_) = True -second_matcher_is_tag (_:fs) = second_matcher_is_tag fs +secondMatcherIsTag :: [DarcsFlag] -> Bool +secondMatcherIsTag [] = False +secondMatcherIsTag (UpToTag _:_) = True +secondMatcherIsTag (_:fs) = secondMatcherIsTag fs --- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in +-- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in -- the flags listed in @fs@. -match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool -match_a_patchread fs = case nonrange_matcher fs of +matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool +matchAPatchread fs = case nonrangeMatcher fs of Nothing -> const True Just m -> apply_matcher m --- | @match_a_patch fs p@ tells whether @p@ matches the matchers in +-- | @matchAPatch fs p@ tells whether @p@ matches the matchers in -- the flags @fs@ -match_a_patch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool -match_a_patch fs p = - case nonrange_matcher fs of +matchAPatch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool +matchAPatch fs p = + case nonrangeMatcher fs of Nothing -> True Just m -> apply_matcher m (patch2patchinfo p `piap` p) -match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p) -match_patch fs ps = - case has_index_range fs of +matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p) +matchPatch fs ps = + case hasIndexRange fs of Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of Just (Sealed2 p) -> seal2 $ hopefully p Nothing -> error "Patch out of range!" - | otherwise -> bug ("Invalid index range match given to match_patch: "++ + | otherwise -> bug ("Invalid index range match given to matchPatch: "++ show (PatchIndexRange a a')) where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p)) myhead (NilRL:<:x) = myhead x myhead ((x:<:_):<:_) = Just $ seal2 x myhead NilRL = Nothing - Nothing -> case nonrange_matcher fs of - Nothing -> bug "Couldn't match_patch" - Just m -> find_a_patch m ps + Nothing -> case nonrangeMatcher fs of + Nothing -> bug "Couldn't matchPatch" + Just m -> findAPatch m ps -get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p) -get_one_patchset repository fs = - case nonrange_matcher fs of +getOnePatchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p) +getOnePatchset repository fs = + case nonrangeMatcher fs of Just m -> do ps <- read_repo repository - if nonrange_matcher_is_tag fs - then return $ get_matching_tag m ps - else return $ match_a_patchset m ps + if nonrangeMatcherIsTag fs + then return $ getMatchingTag m ps + else return $ matchAPatchset m ps Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs) where context_f [] = bug "Couldn't match_nonrange_patchset" context_f (Context f:_) = f context_f (_:xs) = context_f xs --- | @has_lastn fs@ return the @--last@ argument in @fs@, if any. -has_lastn :: [DarcsFlag] -> Maybe Int -has_lastn [] = Nothing -has_lastn (LastN (-1):_) = error "--last requires a positive integer argument." -has_lastn (LastN n:_) = Just n -has_lastn (_:fs) = has_lastn fs +-- | @hasLastn fs@ return the @--last@ argument in @fs@, if any. +hasLastn :: [DarcsFlag] -> Maybe Int +hasLastn [] = Nothing +hasLastn (LastN (-1):_) = error "--last requires a positive integer argument." +hasLastn (LastN n:_) = Just n +hasLastn (_:fs) = hasLastn fs -has_index_range :: [DarcsFlag] -> Maybe (Int,Int) -has_index_range [] = Nothing -has_index_range (PatchIndexRange x y:_) = Just (x,y) -has_index_range (_:fs) = has_index_range fs +hasIndexRange :: [DarcsFlag] -> Maybe (Int,Int) +hasIndexRange [] = Nothing +hasIndexRange (PatchIndexRange x y:_) = Just (x,y) +hasIndexRange (_:fs) = hasIndexRange fs --- | @match_first_patchset fs ps@ returns the part of @ps@ before its +-- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its -- first matcher, ie the one that comes first dependencywise. Hence, --- patches in @match_first_patchset fs ps@ are the ones we don't want. +-- patches in @matchFirstPatchset fs ps@ are the ones we don't want. -- -- Question: are they really? Florent -match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p -match_first_patchset fs patchset = - case has_lastn fs of +matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p +matchFirstPatchset fs patchset = + case hasLastn fs of Just n -> dropn n patchset Nothing -> - case has_index_range fs of + case hasIndexRange fs of Just (_,b) -> dropn b patchset Nothing -> - case first_matcher fs of - Nothing -> bug "Couldn't match_first_patchset" - Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs - then get_matching_tag m patchset - else match_a_patchset m patchset + case firstMatcher fs of + Nothing -> bug "Couldn't matchFirstPatchset" + Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs + then getMatchingTag m patchset + else matchAPatchset m patchset -- | @dropn n ps@ drops the @n@ last patches from @ps@. dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p @@ -359,67 +359,67 @@ dropn _ NilRL = seal $ NilRL:<:NilRL dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs --- | @match_second_patchset fs ps@ returns the part of @ps@ before its +-- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its -- second matcher, ie the one that comes last dependencywise. -match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p -match_second_patchset fs ps = - case has_index_range fs of +matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p +matchSecondPatchset fs ps = + case hasIndexRange fs of Just (a,_) -> dropn (a-1) ps Nothing -> - case second_matcher fs of - Nothing -> bug "Couldn't match_second_patchset" - Just m -> if second_matcher_is_tag fs - then get_matching_tag m ps - else match_a_patchset m ps + case secondMatcher fs of + Nothing -> bug "Couldn't matchSecondPatchset" + Just m -> if secondMatcherIsTag fs + then getMatchingTag m ps + else matchAPatchset m ps --- | @find_a_patch m ps@ returns the last patch in @ps@ matching @m@, and +-- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and -- calls 'error' if there is none. -find_a_patch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p) -find_a_patch m NilRL = error $ "Couldn't find patch matching " ++ show m -find_a_patch m (NilRL:<:xs) = find_a_patch m xs -find_a_patch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p - | otherwise = find_a_patch m (ps:<:xs) +findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p) +findAPatch m NilRL = error $ "Couldn't find patch matching " ++ show m +findAPatch m (NilRL:<:xs) = findAPatch m xs +findAPatch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p + | otherwise = findAPatch m (ps:<:xs) --- | @match_a_patchset m ps@ returns a (the largest?) subset of @ps@ +-- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@ -- ending in patch which matches @m@. Calls 'error' if there is none. -match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p -match_a_patchset m NilRL = error $ "Couldn't find patch matching " ++ show m -match_a_patchset m (NilRL:<:xs) = match_a_patchset m xs -match_a_patchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs) - | otherwise = match_a_patchset m (ps:<:xs) +matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p +matchAPatchset m NilRL = error $ "Couldn't find patch matching " ++ show m +matchAPatchset m (NilRL:<:xs) = matchAPatchset m xs +matchAPatchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs) + | otherwise = matchAPatchset m (ps:<:xs) --- | @get_matching_tag m ps@, where @m@ is a 'Matcher' which matches tags +-- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags -- returns a 'SealedPatchSet' containing all patches in the last tag which -- matches @m@. Last tag means the most recent tag in repository order, -- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls -- 'error' if there is no matching tag. -get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p -get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m -get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs -get_matching_tag m xxx@((p:<:ps):<:xs) +getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p +getMatchingTag m NilRL = error $ "Couldn't find a tag matching " ++ show m +getMatchingTag m (NilRL:<:xs) = getMatchingTag m xs +getMatchingTag m xxx@((p:<:ps):<:xs) | apply_matcher m p = get_patches_in_tag (info p) xxx - | otherwise = get_matching_tag m (ps:<:xs) + | otherwise = getMatchingTag m (ps:<:xs) --- | @match_exists m ps@ tells whether there is a patch matching +-- | @matchExists m ps@ tells whether there is a patch matching -- @m@ in @ps@ -match_exists :: Matcher p -> PatchSet p C(x) -> Bool -match_exists _ NilRL = False -match_exists m (NilRL:<:xs) = match_exists m xs -match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True - | otherwise = match_exists m (ps:<:xs) +matchExists :: Matcher p -> PatchSet p C(x) -> Bool +matchExists _ NilRL = False +matchExists m (NilRL:<:xs) = matchExists m xs +matchExists m ((p:<:ps):<:xs) | apply_matcher m $ p = True + | otherwise = matchExists m (ps:<:xs) -apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () -apply_inv_to_matcher _ _ NilRL = impossible -apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs -apply_inv_to_matcher ioe m ((p:<:ps):<:xs) - | apply_matcher m p = when (ioe == Inclusive) (apply_invp p) - | otherwise = apply_invp p >> apply_inv_to_matcher ioe m (ps:<:xs) +applyInvToMatcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () +applyInvToMatcher _ _ NilRL = impossible +applyInvToMatcher ioe m (NilRL:<:xs) = applyInvToMatcher ioe m xs +applyInvToMatcher ioe m ((p:<:ps):<:xs) + | apply_matcher m p = when (ioe == Inclusive) (applyInvp p) + | otherwise = applyInvp p >> applyInvToMatcher ioe m (ps:<:xs) --- | @maybe_read_file@ recursively gets the contents of all files +-- | @maybeReadFile@ recursively gets the contents of all files -- in a directory, or just the contents of a file if called on a -- simple file. -maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)]) -maybe_read_file file = do +maybeReadFile :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)]) +maybeReadFile file = do d <- mDoesDirectoryExist file if d then do @@ -434,31 +434,30 @@ else return [] where maybe_read_files [] = return [] maybe_read_files (f:fs) = do - x <- maybe_read_file f + x <- maybeReadFile f y <- maybe_read_files fs return $ concat [x,y] -get_matcher_s :: (MatchMonad m p, RepoPatch p) => +getMatcherS :: (MatchMonad m p, RepoPatch p) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () -get_matcher_s ioe m repo = - if match_exists m repo - then apply_inv_to_matcher ioe m repo +getMatcherS ioe m repo = + if matchExists m repo + then applyInvToMatcher ioe m repo else fail $ "Couldn't match pattern "++ show m -get_tag_s :: (MatchMonad m p, RepoPatch p) => +getTagS :: (MatchMonad m p, RepoPatch p) => Matcher p -> PatchSet p C(x) -> m () -get_tag_s match repo = do - let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo) +getTagS match repo = do + let pinfo = patch2patchinfo `unseal2` (findAPatch match repo) case get_patches_beyond_tag pinfo repo of - FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras - _ -> impossible + FlippedSeal extras -> applyInvRL extras --- | @apply_invp@ tries to get the patch that's in a 'PatchInfoAnd +-- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd -- patch', and to apply its inverse. If we fail to fetch the patch -- (presumably in a partial repositiory), then we share our sorrow -- with the user. -apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m () -apply_invp hp = apply [] (invert $ fromHopefully hp) +applyInvp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m () +applyInvp hp = apply [] (invert $ fromHopefully hp) where fromHopefully = conscientiously $ \e -> text "Sorry, partial repository problem. Patch not available:" $$ e @@ -495,7 +494,7 @@ withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m () applyInvRL NilRL = return () - applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps + applyInvRL (p:<:ps) = applyInvp p >> applyInvRL ps withRecordedMatchIO :: RepoPatch p => Repository p C(r u t) -> (PatchSet p C(r) -> IO ()) -> IO () @@ -513,8 +512,8 @@ -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ()) -> IO () withRecordedMatchSmart opts r j = - do if StoreInMemory `elem` opts then withSM r j - else withRecordedMatchIO r j + do if willStoreInMemory opts then withSM r j + else withRecordedMatchIO r j where withSM :: RepoPatch p => Repository p C(r u t) -> (PatchSet p C(r) -> SlurpMonad ()) -> IO () withSM = withRecordedMatch @@ -529,8 +528,8 @@ -> IO () withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j withRecordedMatchOnlySomeSmart opts r files j = - do if StoreInMemory `elem` opts then withSM r files j - else withIO r files j + do if willStoreInMemory opts then withSM r files j + else withIO r files j where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName] -> (PatchSet p C(r) -> SlurpMonad ()) -> IO () withSM = withRecordedMatchOnlySomeFiles @@ -553,16 +552,15 @@ withRecordedMatchOnlySomeFiles r fs job = do ps <- read_repo r s <- slurp_recorded r - case withSlurpy s (job ps >> mapM maybe_read_file fs) of + case withSlurpy s (job ps >> mapM maybeReadFile fs) of Left err -> fail err Right (_,fcs) -> mapM_ createAFile $ concat fcs - where createAFile (p,c) = do ensureDirectories $ super_name p + where createAFile (p,c) = do ensureDirectories $ superName p mWriteFilePS p c ensureDirectories d = do isPar <- mDoesDirectoryExist d - if isPar - then return () - else do ensureDirectories $ super_name d - mCreateDirectory d + unless isPar $ do + ensureDirectories $ superName d + mCreateDirectory d \end{code} diff --git a/src/Darcs/Ordered.hs b/src/Darcs/Ordered.hs deleted file mode 100644 --- a/src/Darcs/Ordered.hs +++ /dev/null @@ -1,277 +0,0 @@ --- Copyright (C) 2007 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} -{-# LANGUAGE CPP #-} --- , MagicHash, TypeOperators, GADTs #-} - -#include "gadts.h" - -module Darcs.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), - FL(..), RL(..),Proof(..), -#ifndef GADT_WITNESSES - unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL, -#endif - lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, - splitAtFL, bunchFL, foldlRL, - lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL, - unsafeMap_l2f, filterE, filterFL, - reverseFL, reverseRL, (+>+), (+<+), - nullFL, concatFL, concatRL, concatReverseFL, headRL, - MyEq, unsafeCompare, (=\/=), (=/\=), - consRLSealed, nullRL, - unsafeCoerceP, unsafeCoerceP2 - ) where - -#include "impossible.h" -import GHC.Base (unsafeCoerce#) -import Darcs.Show -import Darcs.Sealed ( FlippedSeal(..), flipSeal ) - -data EqCheck C(a b) where - IsEq :: EqCheck C(a a) - NotEq :: EqCheck C(a b) - -instance Eq (EqCheck C(a b)) where - IsEq == IsEq = True - NotEq == NotEq = True - _ == _ = False - -isEq :: EqCheck C(a b) -> Bool -isEq IsEq = True -isEq NotEq = False - -instance Show (EqCheck C(a b)) where - show IsEq = "IsEq" - show NotEq = "NotEq" - -data Proof a C(x y) where - Proof :: a -> Proof a C(x x) - -data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y)) -infixr 1 :> -data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z)) -infix 1 :< -infix 1 :/\:, :\/: -data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y)) -data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z)) -class MyEq p where - -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=. - unsafeCompare :: p C(a b) -> p C(c d) -> Bool - unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b) - (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c) - a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq - | otherwise = NotEq - (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b) - a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq - | otherwise = NotEq - -infix 4 =\/=, =/\= - -unsafeCoerceP :: a C(x y) -> a C(b c) -unsafeCoerceP = unsafeCoerce# - -unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d) -unsafeCoerceP2 = unsafeCoerce# - -instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where - showsPrec d (x :> y) = showOp2 1 ":>" d x y - -instance (Show2 a, Show2 b) => Show2 (a :> b) where - showsPrec2 = showsPrec - -instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where - showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y - -instance (Show2 a, Show2 b) => Show2 (a :\/: b) where - showsPrec2 = showsPrec - -infixr 5 :>:, :<:, +>+, +<+ - --- forward list -data FL a C(x z) where - (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z) - NilFL :: FL a C(x x) - -instance Show2 a => Show (FL a C(x z)) where - showsPrec _ NilFL = showString "NilFL" - showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x . - showString " :>: " . showsPrec (prec + 1) xs - where prec = 5 - -instance Show2 a => Show2 (FL a) where - showsPrec2 = showsPrec - --- reverse list -data RL a C(x z) where - (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z) - NilRL :: RL a C(x x) - -nullFL :: FL a C(x z) -> Bool -nullFL NilFL = True -nullFL _ = False - -nullRL :: RL a C(x z) -> Bool -nullRL NilRL = True -nullRL _ = False - -filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z) -filterFL _ NilFL = NilFL -filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs - | otherwise = x :>: filterFL f xs - -filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)] -filterE _ [] = [] -filterE p (x:xs) - | IsEq <- p x = Proof x : filterE p xs - | otherwise = filterE p xs - -(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z) -NilFL +>+ ys = ys -(x:>:xs) +>+ ys = x :>: xs +>+ ys - -(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z) -NilRL +<+ ys = ys -(x:<:xs) +<+ ys = x :<: xs +<+ ys - -reverseFL :: FL a C(x z) -> RL a C(x z) -reverseFL xs = r NilRL xs - where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o) - r ls NilFL = ls - r ls (a:>:as) = r (a:<:ls) as - -reverseRL :: RL a C(x z) -> FL a C(x z) -reverseRL xs = r NilFL xs -- r (xs :> NilFL) - where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o) - r ls NilRL = ls - r ls (a:<:as) = r (a:>:ls) as - -concatFL :: FL (FL a) C(x z) -> FL a C(x z) -concatFL NilFL = NilFL -concatFL (a:>:as) = a +>+ concatFL as - -concatRL :: RL (RL a) C(x z) -> RL a C(x z) -concatRL NilRL = NilRL -concatRL (a:<:as) = a +<+ concatRL as - -spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z) -spanFL f (x:>:xs) | f x = case spanFL f xs of - ys :> zs -> (x:>:ys) :> zs -spanFL _ xs = NilFL :> xs - -splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z) -splitAtFL 0 xs = NilFL :> xs -splitAtFL _ NilFL = NilFL :> NilFL -splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of - (xs':>xs'') -> (x:>:xs' :> xs'') - --- 'bunchFL n' groups patches into batches of n, except that it always puts --- the first patch in its own group, this being a recognition that the --- first patch is often *very* large. - -bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y) -bunchFL _ NilFL = NilFL -bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs - where bFL :: FL a C(x y) -> FL (FL a) C(x y) - bFL NilFL = NilFL - bFL bs = case splitAtFL n bs of - a :> b -> a :>: bFL b - - -allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool -allFL f xs = and $ mapFL f xs - -foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a -foldlFL _ x NilFL = x -foldlFL f x (y:>:ys) = foldlFL f (f x y) ys - -foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a -foldlRL _ x NilRL = x -foldlRL f x (y:<:ys) = foldlRL f (f x y) ys - -mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z) -mapFL_FL _ NilFL = NilFL -mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as - -zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y)) - -> [a] -> FL p C(w z) -> FL q C(w z) -zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys -zipWithFL _ _ NilFL = NilFL -zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list" - -mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z) -mapRL_RL _ NilRL = NilRL -mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as - -mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b] -mapFL _ NilFL = [] -mapFL f (a :>: b) = f a : mapFL f b - -mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b] -mapRL _ NilRL = [] -mapRL f (a :<: b) = f a : mapRL f b - -unsafeMap_l2f :: (FORALL(w z) a -> b C(w z)) -> [a] -> FL b C(x y) -unsafeMap_l2f _ [] = unsafeCoerceP NilFL -unsafeMap_l2f f (x:xs) = f x :>: unsafeMap_l2f f xs - -lengthFL :: FL a C(x z) -> Int -lengthFL xs = l xs 0 - where l :: FL a C(x z) -> Int -> Int - l NilFL n = n - l (_:>:as) n = l as $! n+1 - -lengthRL :: RL a C(x z) -> Int -lengthRL xs = l xs 0 - where l :: RL a C(x z) -> Int -> Int - l NilRL n = n - l (_:<:as) n = l as $! n+1 - -isShorterThanRL :: RL a C(x y) -> Int -> Bool -isShorterThanRL _ n | n <= 0 = False -isShorterThanRL NilRL _ = True -isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1) - -concatReverseFL :: FL (RL a) C(x y) -> RL a C(x y) -concatReverseFL = concatRL . reverseFL - -headRL :: RL a C(x y) -> FlippedSeal a C(y) -headRL (x:<:_) = flipSeal x -headRL _ = impossible - -consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z) -consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as - -#ifndef GADT_WITNESSES --- These are useful for interfacing with modules outside of --- patch theory, such as Show.lhs -unsafeUnFL :: FL a -> [a] -unsafeUnFL NilFL = [] -unsafeUnFL (a:>:as) = a : unsafeUnFL as - -unsafeUnRL :: RL a -> [a] -unsafeUnRL NilRL = [] -unsafeUnRL (a:<:as) = a : unsafeUnRL as - -unsafeFL :: [a] -> FL a -unsafeFL [] = NilFL -unsafeFL (a:as) = a :>: unsafeFL as - -unsafeRL :: [a] -> RL a -unsafeRL [] = NilRL -unsafeRL (a:as) = a :<: unsafeRL as -#endif diff --git a/src/Darcs/Patch.lhs b/src/Darcs/Patch.lhs --- a/src/Darcs/Patch.lhs +++ b/src/Darcs/Patch.lhs @@ -45,7 +45,7 @@ module Darcs.Patch ( RepoPatch, Prim, Patch, RealPatch, Named, Patchy, flattenFL, joinPatches, fromPrim, fromPrims, - is_null_patch, nullP, + isNullPatch, nullP, rmfile, addfile, rmdir, adddir, move, hunk, tokreplace, namepatch, anonymous, binary, @@ -53,32 +53,33 @@ showContextPatch, showPatch, showNicely, infopatch, changepref, thing, things, - is_similar, is_addfile, is_hunk, is_setpref, + isSimilar, primIsAddfile, primIsHunk, primIsSetpref, #ifndef GADT_WITNESSES - merger, is_merger, merge, - commute, commutex, list_touched_files, + merger, isMerger, merge, + commute, listTouchedFiles, hunkMatches, -- for PatchTest - unravel, elegant_merge, + unravel, elegantMerge, #else Commute(..), #endif - resolve_conflicts, + resolveConflicts, Effect, effect, - is_binary, gzWritePatch, writePatch, is_adddir, + primIsBinary, gzWritePatch, writePatch, primIsAdddir, invert, invertFL, invertRL, identity, commuteFL, commuteRL, readPatch, - canonize, sort_coalesceFL, - try_to_shrink, - apply_to_slurpy, patchname, patchcontents, - apply_to_filepaths, force_replace_slurpy, apply, + canonize, sortCoalesceFL, + tryToShrink, + applyToSlurpy, patchname, patchcontents, + applyToFilepaths, forceReplaceSlurpy, apply, + applyToTree, patch2patchinfo, LineMark(AddedLine, RemovedLine, AddedRemovedLine, None), - MarkedUpFile, markup_file, empty_markedup_file, - summary, summarize, xml_summary, + MarkedUpFile, markupFile, emptyMarkedupFile, + summary, plainSummary, xmlSummary, adddeps, getdeps, - list_conflicted_files, - modernize_patch, + listConflictedFiles, + modernizePatch, -- for Population DirMark(..), patchChanges, applyToPop, ) where @@ -88,10 +89,10 @@ adddeps, namepatch, anonymous, #ifndef GADT_WITNESSES - is_merger, + isMerger, #endif getdeps, - is_null_patch, nullP, infopatch, + isNullPatch, nullP, infopatch, patch2patchinfo, patchname, patchcontents ) import Darcs.Patch.Read ( readPatch ) import Darcs.Patch.Patchy ( Patchy, writePatch, gzWritePatch, @@ -101,33 +102,33 @@ commuteFL, commuteRL, apply, description, summary, #ifndef GADT_WITNESSES - commute, commutex, list_touched_files, + commute, listTouchedFiles, hunkMatches, #else Commute(..) #endif ) -import Darcs.Patch.Viewing ( xml_summary, summarize ) -import Darcs.Patch.Apply ( applyToPop, patchChanges, empty_markedup_file, - markup_file, force_replace_slurpy, - apply_to_filepaths, apply_to_slurpy, - LineMark(..), MarkedUpFile ) -import Darcs.Patch.Commute ( modernize_patch, +import Darcs.Patch.Viewing ( xmlSummary, plainSummary ) +import Darcs.Patch.Apply ( applyToPop, patchChanges, emptyMarkedupFile, + markupFile, forceReplaceSlurpy, + applyToFilepaths, applyToSlurpy, + LineMark(..), MarkedUpFile, applyToTree ) +import Darcs.Patch.Commute ( modernizePatch, #ifndef GADT_WITNESSES unravel, - merger, merge, elegant_merge, + merger, merge, elegantMerge, #endif ) import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim, - Conflict, Effect(effect), list_conflicted_files, resolve_conflicts, + Conflict, Effect(effect), listConflictedFiles, resolveConflicts, Prim, canonize, - sort_coalesceFL, + sortCoalesceFL, rmdir, rmfile, tokreplace, adddir, addfile, binary, changepref, hunk, move, - is_adddir, is_addfile, - is_hunk, is_binary, is_setpref, - is_similar, - try_to_shrink ) -import Darcs.Ordered ( FL ) + primIsAdddir, primIsAddfile, + primIsHunk, primIsBinary, primIsSetpref, + isSimilar, + tryToShrink ) +import Darcs.Witnesses.Ordered ( FL ) import Darcs.Patch.Real ( RealPatch ) instance Patchy Patch diff --git a/src/Darcs/Patch/Apply.lhs b/src/Darcs/Patch/Apply.lhs --- a/src/Darcs/Patch/Apply.lhs +++ b/src/Darcs/Patch/Apply.lhs @@ -22,13 +22,14 @@ #include "gadts.h" -module Darcs.Patch.Apply ( apply_to_filepaths, apply_to_slurpy, +module Darcs.Patch.Apply ( applyToFilepaths, applyToSlurpy, forceTokReplace, - markup_file, empty_markedup_file, + markupFile, emptyMarkedupFile, patchChanges, applyToPop, + applyToTree, LineMark(..), MarkedUpFile, - force_replace_slurpy ) + forceReplaceSlurpy ) where import Prelude hiding ( catch, pi ) @@ -54,14 +55,17 @@ import Darcs.Patch.Info ( PatchInfo ) import Control.Monad ( when ) import Darcs.SlurpDirectory ( FileContents, Slurpy, withSlurpy, slurp_modfile ) -import RegChars ( regChars ) -import Darcs.Repository.Prefs ( change_prefval ) +import Darcs.Patch.RegChars ( regChars ) +import Darcs.Repository.Prefs ( changePrefval ) import Darcs.Global ( darcsdir ) import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) import Darcs.FilePathMonad ( withFilePaths ) #include "impossible.h" -import Darcs.Ordered ( FL(..), (:>)(..), +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL, mapFL_FL, spanFL, foldlFL ) + +import Storage.Hashed.Tree( Tree ) +import Storage.Hashed.Monad( virtualTreeIO ) \end{code} @@ -107,11 +111,11 @@ \begin{code} -apply_to_filepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath] -apply_to_filepaths pa fs = withFilePaths fs (apply [] pa) +applyToFilepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath] +applyToFilepaths pa fs = withFilePaths fs (apply [] pa) -apply_to_slurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy -apply_to_slurpy p s = case withSlurpy s (apply [] p) of +applyToSlurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy +applyToSlurpy p s = case withSlurpy s (apply [] p) of Left err -> fail err Right (s', ()) -> return s' @@ -127,10 +131,10 @@ applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x -force_replace_slurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy -force_replace_slurpy (FP f (TokReplace tcs old new)) s = +forceReplaceSlurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy +forceReplaceSlurpy (FP f (TokReplace tcs old new)) s = slurp_modfile f (forceTokReplace tcs old new) s -force_replace_slurpy _ _ = bug "Can only force_replace_slurpy on a replace." +forceReplaceSlurpy _ _ = bug "Can only forceReplaceSlurpy on a replace." instance Apply Prim where apply opts (Split ps) = applyFL opts ps @@ -154,7 +158,7 @@ apply _ (Move f f') = mRename f f' apply _ (ChangePref p f t) = do b <- mDoesDirectoryExist (fp2fn $ darcsdir++"/prefs") - when b $ change_prefval p f t + when b $ changePrefval p f t applyAndTryToFixFL (FP f RmFile) = do x <- mReadFilePS f if B.null x then do mRemoveFile f @@ -296,12 +300,12 @@ | AddedRemovedLine PatchInfo PatchInfo | None deriving (Show) type MarkedUpFile = [(B.ByteString, LineMark)] -empty_markedup_file :: MarkedUpFile -empty_markedup_file = [(B.empty, None)] +emptyMarkedupFile :: MarkedUpFile +emptyMarkedupFile = [(B.empty, None)] -markup_file :: Effect p => PatchInfo -> p C(x y) +markupFile :: Effect p => PatchInfo -> p C(x y) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) -markup_file x p = mps (effect p) +markupFile x p = mps (effect p) where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) mps NilFL = id mps (pp:>:pps) = mps pps . markup_prim x pp @@ -518,5 +522,10 @@ pname :: PopTree -> B.ByteString pname (PopDir i _) = nameI i pname (PopFile i) = nameI i + +-- | Apply a patch to a 'Tree', yielding a new 'Tree'. +applyToTree :: (Apply p) => p C(x y) -> Tree IO -> IO (Tree IO) +applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t + \end{code} diff --git a/src/Darcs/Patch/Bundle.hs b/src/Darcs/Patch/Bundle.hs --- a/src/Darcs/Patch/Bundle.hs +++ b/src/Darcs/Patch/Bundle.hs @@ -24,31 +24,33 @@ make_context, scan_context, ) where -import Darcs.Flags ( DarcsFlag( Unified ) ) +import Darcs.Flags ( DarcsFlag, isUnified ) import Darcs.Hopefully ( PatchInfoAnd, piap, patchInfoAndPatch, unavailable, hopefully ) import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) -import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP, +import Darcs.Witnesses.Ordered ( RL(..), FL(..), unsafeCoerceP, reverseFL, (+<+), mapFL, mapFL_FL ) import Printer ( Doc, renderPS, newline, text, ($$), (<>), vcat, vsep, renderString ) -import Darcs.SlurpDirectory ( Slurpy ) import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS) import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf) import qualified Data.ByteString.Char8 as BC (unpack, break, pack) import SHA1( sha1PS ) -import Darcs.Sealed ( Sealed(Sealed), mapSeal ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), mapSeal ) +import Storage.Hashed.Tree( Tree ) +import Storage.Hashed.Monad( virtualTreeIO ) + hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String hash_bundle _ to_be_sent = sha1PS $ renderPS $ vcat (mapFL showPatch to_be_sent) <> newline -make_bundle :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] -> FL (Named p) C(x y) -> Doc +make_bundle :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo] -> FL (Named p) C(x y) -> IO Doc make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_be_sent -- | In make_bundle2, it is presumed that the two patch sequences are @@ -56,23 +58,24 @@ -- patch sequences are passed, a bundle with a mismatched hash will be -- generated, which is not the end of the world, but isn't very useful -- either. -make_bundle2 :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] - -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> Doc +make_bundle2 :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo] + -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc make_bundle2 opts the_s common to_be_sent to_be_sent2 = - text "" - $$ text "New patches:" - $$ text "" - $$ the_new - $$ text "" - $$ text "Context:" - $$ text "" - $$ (vcat $ map showPatchInfo common) - $$ text "Patch bundle hash:" - $$ text (hash_bundle common to_be_sent2) - $$ text "" - where the_new = if Unified `elem` opts - then showContextPatch the_s to_be_sent - else vsep $ mapFL showPatch to_be_sent + do patches <- case (isUnified opts) of + True -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) the_s + False -> return (vsep $ mapFL showPatch to_be_sent) + return $ format patches + where format the_new = text "" + $$ text "New patches:" + $$ text "" + $$ the_new + $$ text "" + $$ text "Context:" + $$ text "" + $$ (vcat $ map showPatchInfo common) + $$ text "Patch bundle hash:" + $$ text (hash_bundle common to_be_sent2) + $$ text "" scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p) scan_bundle ps @@ -84,7 +87,7 @@ (Sealed patches, rest') -> case silly_lex rest' of ("Context:", rest'') -> - case get_context rest'' of + case getContext rest'' of (cont,maybe_hash) -> case substrPS (BC.pack "Patch bundle hash:") maybe_hash of @@ -102,7 +105,7 @@ (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'" ++ "\n" ++ BC.unpack r ("Context:",rest) -> - case get_context rest of + case getContext rest of (cont, rest') -> case silly_lex rest' of ("New patches:", rest'') -> @@ -153,11 +156,11 @@ pi_unavailable i = (i `patchInfoAndPatch` unavailable ("Patch not stored in patch bundle:\n" ++ renderString (human_friendly i))) -get_context :: B.ByteString -> ([PatchInfo],B.ByteString) -get_context ps = +getContext :: B.ByteString -> ([PatchInfo],B.ByteString) +getContext ps = case readPatchInfo ps of Just (pinfo,r') -> - case get_context r' of + case getContext r' of (pis,r'') -> (pinfo:pis, r'') Nothing -> ([],ps) (-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b) @@ -204,7 +207,7 @@ | otherwise = case silly_lex ps of ("Context:",rest) -> - case get_context rest of + case getContext rest of (cont, _) -> unavailable_patches cont :<: NilRL ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> scan_context $ filter_gpg_dashes rest diff --git a/src/Darcs/Patch/Check.hs b/src/Darcs/Patch/Check.hs deleted file mode 100644 --- a/src/Darcs/Patch/Check.hs +++ /dev/null @@ -1,335 +0,0 @@ --- Copyright (C) 2002-2003 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -module Darcs.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists, - remove_file, remove_dir, create_file, create_dir, - insert_line, delete_line, is_valid, do_verbose_check, - file_empty, - check_move, modify_file, FileContents(..) - ) where - -import System.IO.Unsafe ( unsafePerformIO ) -import qualified Data.ByteString as B (ByteString) -import Data.List ( isPrefixOf, inits ) -import Control.Monad.State ( State, evalState, runState ) -import Control.Monad.State.Class ( get, put, modify ) --- use Map, not IntMap, because Map has mapKeys and IntMap hasn't -import Data.Map ( Map ) -import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null ) -import System.FilePath ( joinPath, splitDirectories ) - --- | File contents are represented by a map from line numbers to line contents. --- If for a certain line number, the line contents are Nothing, that means --- that we are sure that that line exists, but we don't know its contents. --- We must also store the greatest line number that is known to exist in a --- file, to be able to exclude the possibility of it being empty without --- knowing its contents. -data FileContents = FC { fc_lines :: Map Int B.ByteString - , fc_maxline :: Int - } deriving (Eq, Show) -data Prop = FileEx String | DirEx String | NotEx String - | FileLines String FileContents - deriving (Eq) --- | A @KnownState@ is a simulated repository state. The repository is either --- inconsistent, or it has two lists of properties: one list with properties --- that hold for this repo, and one with properties that do not hold for this --- repo. These two lists may not have any common elements: if they had, the --- repository would be inconsistent. -data KnownState = P [Prop] [Prop] - | Inconsistent - deriving (Show) -instance Show Prop where - show (FileEx f) = "FileEx "++f - show (DirEx d) = "DirEx "++d - show (NotEx f) = "NotEx"++f - show (FileLines f l) = "FileLines "++f++": "++show l - --- | PatchCheck is a state monad with a simulated repository state -type PatchCheck = State KnownState - --- | The @FileContents@ structure for an empty file -empty_filecontents :: FileContents -empty_filecontents = FC M.empty 0 - --- | Returns a given value if the repository state is inconsistent, and performs --- a given action otherwise. -handle_inconsistent :: a -- ^ The value to return if the state is inconsistent - -> PatchCheck a -- ^ The action to perform otherwise - -> PatchCheck a -handle_inconsistent v a = do state <- get - case state of - Inconsistent -> return v - _ -> a - -do_check :: PatchCheck a -> a -do_check p = evalState p (P [] []) - --- | Run a check, and print the final repository state -do_verbose_check :: PatchCheck a -> a -do_verbose_check p = - case runState p (P [] []) of - (b, pc) -> unsafePerformIO $ do putStrLn $ show pc - return b - --- | Returns true if the current repository state is not inconsistent -is_valid :: PatchCheck Bool -is_valid = handle_inconsistent False (return True) - -has :: Prop -> [Prop] -> Bool -has _ [] = False -has k (k':ks) = k == k' || has k ks - -modify_file :: String - -> (Maybe FileContents -> Maybe FileContents) - -> PatchCheck Bool -modify_file f change = do - file_exists f - c <- file_contents f - case change c of - Nothing -> assert_not $ FileEx f -- shorthand for "FAIL" - Just c' -> do set_contents f c' - is_valid - -insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool -insert_line f n l = do - c <- file_contents f - case c of - Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent - Just c' -> do - let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c') - lines'' = M.insert n l lines' - maxline' = max n (fc_maxline c') - set_contents f (FC lines'' maxline') - return True - --- deletes a line from a hunk patch (third argument) in the given file (first --- argument) at the given line number (second argument) -delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool -delete_line f n l = do - c <- file_contents f - case c of - Nothing -> assert_not $ FileEx f - Just c' -> - let flines = fc_lines c' - flines' = M.mapKeys (\k -> if k > n then k-1 else k) - (M.delete n flines) - maxlinenum' | n <= fc_maxline c' = fc_maxline c' - 1 - | otherwise = n - 1 - c'' = FC flines' maxlinenum' - do_delete = do - set_contents f c'' - is_valid - in case M.lookup n flines of - Nothing -> do_delete - Just l' -> if l == l' - then do_delete - else assert_not $ FileEx f - -set_contents :: String -> FileContents -> PatchCheck () -set_contents f c = handle_inconsistent () $ do - P ks nots <- get - let ks' = FileLines f c : filter (not . is_file_lines_for f) ks - put (P ks' nots) - where is_file_lines_for file prop = case prop of - FileLines f' _ -> file == f' - _ -> False - --- | Get (as much as we know about) the contents of a file in the current state. --- Returns Nothing if the state is inconsistent. -file_contents :: String -> PatchCheck (Maybe FileContents) -file_contents f = handle_inconsistent Nothing $ do - P ks _ <- get - return (fic ks) - where fic (FileLines f' c:_) | f == f' = Just c - fic (_:ks) = fic ks - fic [] = Just empty_filecontents - --- | Checks if a file is empty -file_empty :: String -- ^ Name of the file to check - -> PatchCheck Bool -file_empty f = do - c <- file_contents f - let empty = case c of - Just c' -> fc_maxline c' == 0 && M.null (fc_lines c') - Nothing -> True - if empty - then do set_contents f empty_filecontents - is_valid - -- Crude way to make it inconsistent and return false: - else assert_not $ FileEx f - return empty - -movedirfilename :: String -> String -> String -> String -movedirfilename d d' f = - if (d ++ "/") `isPrefixOf` f - then d'++drop (length d) f - else if f == d - then d' - else f - --- | Replaces a filename by another in all paths. Returns True if the repository --- is consistent, False if it is not. -do_swap :: String -> String -> PatchCheck Bool -do_swap f f' = handle_inconsistent False $ do - modify (\(P ks nots) -> P (map sw ks) (map sw nots)) - return True - where sw (FileEx a) | f `is_soe` a = FileEx $ movedirfilename f f' a - | f' `is_soe` a = FileEx $ movedirfilename f' f a - sw (DirEx a) | f `is_soe` a = DirEx $ movedirfilename f f' a - | f' `is_soe` a = DirEx $ movedirfilename f' f a - sw (FileLines a c) | f `is_soe` a = FileLines (movedirfilename f f' a) c - | f' `is_soe` a = FileLines (movedirfilename f' f a) c - sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a - | f' `is_soe` a = NotEx $ movedirfilename f' f a - sw p = p - is_soe d1 d2 = -- is_superdir_or_equal - d1 == d2 || (d1 ++ "/") `isPrefixOf` d2 - --- | Assert a property about the repository. If the property is already present --- in the repo state, nothing changes, and the function returns True. If it is --- not present yet, it is added to the repo state, and the function is True. If --- the property is already in the list of properties that do not hold for the --- repo, the state becomes inconsistent, and the function returns false. -assert :: Prop -> PatchCheck Bool -assert p = handle_inconsistent False $ do - P ks nots <- get - if has p nots - then do - put Inconsistent - return False - else if has p ks - then return True - else do - put (P (p:ks) nots) - return True - --- | Like @assert@, but negatively: state that some property must not hold for --- the current repo. -assert_not :: Prop -> PatchCheck Bool -assert_not p = handle_inconsistent False $ do - P ks nots <- get - if has p ks - then do - put Inconsistent - return False - else if has p nots - then return True - else do - put (P ks (p:nots)) - return True - --- | Remove a property from the list of properties that do not hold for this --- repo (if it's there), and add it to the list of properties that hold. --- Returns False if the repo is inconsistent, True otherwise. -change_to_true :: Prop -> PatchCheck Bool -change_to_true p = handle_inconsistent False $ do - modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots)) - return True - --- | Remove a property from the list of properties that hold for this repo (if --- it's in there), and add it to the list of properties that do not hold. --- Returns False if the repo is inconsistent, True otherwise. -change_to_false :: Prop -> PatchCheck Bool -change_to_false p = handle_inconsistent False $ do - modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots)) - return True - -assert_file_exists :: String -> PatchCheck Bool -assert_file_exists f = do assert_not $ NotEx f - assert_not $ DirEx f - assert $ FileEx f -assert_dir_exists :: String -> PatchCheck Bool -assert_dir_exists d = do assert_not $ NotEx d - assert_not $ FileEx d - assert $ DirEx d -assert_exists :: String -> PatchCheck Bool -assert_exists f = assert_not $ NotEx f - -assert_no_such :: String -> PatchCheck Bool -assert_no_such f = do assert_not $ FileEx f - assert_not $ DirEx f - assert $ NotEx f - -create_file :: String -> PatchCheck Bool -create_file fn = do - superdirs_exist fn - assert_no_such fn - change_to_true (FileEx fn) - change_to_false (NotEx fn) - -create_dir :: String -> PatchCheck Bool -create_dir fn = do - substuff_dont_exist fn - superdirs_exist fn - assert_no_such fn - change_to_true (DirEx fn) - change_to_false (NotEx fn) - -remove_file :: String -> PatchCheck Bool -remove_file fn = do - superdirs_exist fn - assert_file_exists fn - file_empty fn - change_to_false (FileEx fn) - change_to_true (NotEx fn) - -remove_dir :: String -> PatchCheck Bool -remove_dir fn = do - substuff_dont_exist fn - superdirs_exist fn - assert_dir_exists fn - change_to_false (DirEx fn) - change_to_true (NotEx fn) - -check_move :: String -> String -> PatchCheck Bool -check_move f f' = do - superdirs_exist f - superdirs_exist f' - assert_exists f - assert_no_such f' - do_swap f f' - -substuff_dont_exist :: String -> PatchCheck Bool -substuff_dont_exist d = handle_inconsistent False $ do - P ks _ <- get - if all noss ks - then return True - else do - put Inconsistent - return False - where noss (FileEx f) = not (is_within_dir f) - noss (DirEx f) = not (is_within_dir f) - noss _ = True - is_within_dir f = (d ++ "/") `isPrefixOf` f - --- the init and tail calls dump the final init (which is just the path itself --- again), the first init (which is empty), and the initial "." from --- splitDirectories -superdirs_exist :: String -> PatchCheck Bool -superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs - where superdirs = map (("./"++) . joinPath) - (init (tail (inits (tail (splitDirectories fn))))) - -file_exists :: String -> PatchCheck Bool -file_exists fn = do - superdirs_exist fn - assert_file_exists fn - -dir_exists :: String -> PatchCheck Bool -dir_exists fn = do - superdirs_exist fn - assert_dir_exists fn diff --git a/src/Darcs/Patch/Choices.hs b/src/Darcs/Patch/Choices.hs --- a/src/Darcs/Patch/Choices.hs +++ b/src/Darcs/Patch/Choices.hs @@ -29,7 +29,7 @@ -- type and associated functions are here to deal with many of the common -- cases that come up when choosing a subset of a group of patches. -- --- 'force_last' tells PatchChoices that a particular patch is required to be in +-- 'forceLast' tells PatchChoices that a particular patch is required to be in -- the "last" group, which also means that any patches that depend on it -- must be in the "last" group. -- @@ -40,17 +40,19 @@ -- about the first-middle-last language, it's because in some cases the -- "yes" answers will be last (as is the case for the revert command), and -- in others first (as in record, pull and push). -module Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps, - patch_slot, - get_choices, - separate_first_middle_from_last, - separate_first_from_middle_last, - force_first, force_firsts, force_last, force_lasts, - force_matching_first, force_matching_last, - select_all_middles, - make_uncertain, make_everything_later, - TaggedPatch, Tag, tag, tp_patch, +module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps, + patchChoicesTpsSub, + patchSlot, + getChoices, + separateFirstMiddleFromLast, + separateFirstFromMiddleLast, + forceFirst, forceFirsts, forceLast, forceLasts, + forceMatchingFirst, forceMatchingLast, + selectAllMiddles, + makeUncertain, makeEverythingLater, + TaggedPatch, Tag, tag, tpPatch, Slot(..), + substitute, ) where import System.IO.Unsafe ( unsafePerformIO ) @@ -58,55 +60,86 @@ import Darcs.Patch import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) import Darcs.Patch.Patchy ( Invert, Commute ) -import Darcs.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, - (:>)(..), (:\/:)(..), (:/\:)(..), - zipWithFL, mapFL_FL, mapFL, +import Darcs.Witnesses.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, EqCheck(..), + (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..), + zipWithFL, mapFL_FL, mapFL, concatFL, (+>+), reverseRL, unsafeCoerceP ) +import Darcs.Witnesses.Sealed ( Sealed2(..) ) -newtype Tag = TG Integer deriving ( Num, Show, Eq, Ord, Enum ) +-- | 'TG' @mp i@ acts as a temporary identifier to help us keep track of patches +-- during the selection process. These are useful for finding patches that +-- may have moved around during patch selection (being pushed forwards or +-- backwards as dependencies arise). +-- +-- The identifier is implemented as a tuple @TG mp i@. The @i@ is just some +-- arbitrary label, expected to be unique within the patches being +-- scrutinised. The @mp@ is motivated by patch splitting; it +-- provides a convenient way to generate a new identifier from the patch +-- being split. For example, if we split a patch identified as @TG Nothing +-- 5@, the resulting sub-patches could be identified as @TG (TG Nothing 5) +-- 1@, @TG (TG Nothing 5) 2@, etc. +data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord ) data TaggedPatch p C(x y) = TP Tag (p C(x y)) + data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y)) +-- | See module documentation for 'Darcs.Patch.Choices' data Slot = InFirst | InMiddle | InLast +negTag :: Tag -> Tag +negTag (TG k n) = TG k (-n) + invertTag :: Slot -> Slot invertTag InFirst = InLast invertTag InLast = InFirst invertTag t = t tag :: TaggedPatch p C(x y) -> Tag -tag (TP (TG t) _) = TG t +tag (TP tg _) = tg -tp_patch :: TaggedPatch p C(x y) -> p C(x y) -tp_patch (TP _ p) = p +tpPatch :: TaggedPatch p C(x y) -> p C(x y) +tpPatch (TP _ p) = p liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b)) liftTP f (TP t p) = TP t (f p) +-- This is dangerous if two patches from different tagged series are compared +-- ideally Tag (and hence TaggedPatch/PatchChoices) would have a witness type +-- to represent the originally tagged sequence. +compareTags :: TaggedPatch p C(a b) -> TaggedPatch p C(c d) -> EqCheck C((a, b) (c, d)) +compareTags (TP t1 _) (TP t2 _) = if t1 == t2 then unsafeCoerceP IsEq else NotEq + instance MyEq p => MyEq (TaggedPatch p) where unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2 instance Invert p => Invert (TaggedPatch p) where invert = liftTP invert - identity = TP (-1) identity + identity = TP (TG Nothing (-1)) identity instance Commute p => Commute (TaggedPatch p) where commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2) return (TP t2 p2' :> TP t1 p1') - list_touched_files (TP _ p) = list_touched_files p + listTouchedFiles (TP _ p) = listTouchedFiles p + hunkMatches f (TP _ p) = hunkMatches f p merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1' -patch_choices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y) -patch_choices = fst . patch_choices_tps +patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y) +patchChoices = fst . patchChoicesTps -patch_choices_tps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y)) -patch_choices_tps ps = let tps = zipWithFL TP [1..] ps - in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps) +-- |Tag a sequence of patches as subpatches of an existing tag. This is intended for +-- use when substituting a patch for an equivalent patch or patches. +patchChoicesTpsSub :: Patchy p + => Maybe Tag -> FL p C(x y) + -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y)) +patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps + in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps) -make_everything_later :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y) +-- |Tag a sequence of patches. +patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y)) +patchChoicesTps = patchChoicesTpsSub Nothing instance MyEq p => MyEq (PatchChoice p) where unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2 @@ -122,26 +155,41 @@ merge (PC t1 x1 :\/: PC t2 x2) = case merge (t1 :\/: t2) of t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1 - list_touched_files (PC t _) = list_touched_files t + listTouchedFiles (PC t _) = listTouchedFiles t + hunkMatches f (PC t _) = hunkMatches f t invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x) invertSeq (x :> y) = (invert y :> invert x) -separate_first_from_middle_last :: Patchy p => PatchChoices p C(x z) +separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) -separate_first_from_middle_last (PCs e) = pull_only_firsts e +separateFirstFromMiddleLast (PCs e) = pull_only_firsts e -separate_first_middle_from_last :: Patchy p => PatchChoices p C(x z) +separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) -separate_first_middle_from_last (PCs e) = pull_firsts_middles e +separateFirstMiddleFromLast (PCs e) = pull_firsts_middles e -get_choices :: Patchy p => PatchChoices p C(x y) +getChoices :: Patchy p => PatchChoices p C(x y) -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) -get_choices (PCs e) = case pull_firsts e of +getChoices (PCs e) = case pull_firsts e of f :> ml -> case pull_firsts (invert ml) of l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l where pc2tp (PC tp _) = tp +{- +This unsafePerformIO hack was reported by Igloo as being necessary for +constant space performance when working with a very large set of changes +(e.g. from an initial import) where the second element of the returned tuple +is expected to be small, and will only be accessed after the entire first +element has been forced. +On a quick scan on 20080729 it seemed like only revert/unrevert actually +make use of both elements of the tuple. +We should (a) add a test case that checks on constant space usage and +(b) clean up this interface and code, perhaps by replacing the FL :> FL +with a custom structure that forces traversal of the first element to +get at the second (but then how would we commute/pattern-match? messy...) +-} + pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) pull_firsts_middles easyPC = let r = unsafePerformIO @@ -214,21 +262,23 @@ Just (TP t2 p2 :> e') -> case commute (p:>p2) of Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e')) - Nothing -> Just (tp :> PC (TP (-t2) p2) InFirst:>:e') + Nothing -> Just (tp :> PC (TP (negTag t2) p2) InFirst:>:e') Nothing -> Nothing -patch_slot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot -patch_slot tp (PCs e) = ipf e +patchSlot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot +patchSlot tp (PCs e) = ipf e where ipf :: FL (PatchChoice p) C(u v) -> Slot ipf (PC a mb:>:e') | tag a == tag tp = mb | otherwise = ipf e' -- actually, the following should be impossible, but this is a reasonable answer ipf NilFL = InLast -set_simplys :: [Tag] -> Bool -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y) -set_simplys ts b e = mapFL_FL ch e +-- | 'setSimplys' @ts s ps@ assigns all patches in @ps@ with a tag in @ts@ to slot @s@ +-- (and any other patch to slot 'InMiddle') +setSimplys :: [Tag] -> Slot -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y) +setSimplys ts s e = mapFL_FL ch e where ch (PC tp@(TP t _) _) - | t `elem` ts = PC tp (if b then InFirst else InLast) + | t `elem` ts = PC tp s | otherwise = PC tp InMiddle @@ -238,55 +288,69 @@ | otherwise = m2ids m e m2ids _ NilFL = [] -force_matching_first :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) +forceMatchingFirst :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> PatchChoices p C(a b) -> PatchChoices p C(a b) -force_matching_first m (PCs e) = +forceMatchingFirst m (PCs e) = let thd (PC (TP t _) _) = t xs = m2ids m e - not_needed = case pull_firsts $ set_simplys xs True e of + not_needed = case pull_firsts $ setSimplys xs InFirst e of _ :> rest -> mapFL thd rest ch pc@(PC tp@(TP t _) _) | t `elem` not_needed = pc | otherwise = PC tp InFirst in PCs $ mapFL_FL ch e -force_firsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -force_firsts ps pc = force_matching_first ((`elem` ps) . tag) pc +forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +forceFirsts ps pc = forceMatchingFirst ((`elem` ps) . tag) pc -force_first :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) -force_first p pc = force_matching_first ((== p) . tag) pc +forceFirst :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) +forceFirst p pc = forceMatchingFirst ((== p) . tag) pc -select_all_middles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y) -select_all_middles b (PCs e) = PCs (mapFL_FL f e) +selectAllMiddles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y) +selectAllMiddles b (PCs e) = PCs (mapFL_FL f e) where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst) f pc = pc reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x) reverse_pc (PCs e) = PCs $ invert e -force_matching_last :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) +forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> PatchChoices p C(a b) -> PatchChoices p C(a b) -force_matching_last m (PCs e) = +forceMatchingLast m (PCs e) = let thd (PC (TP t _) _) = t xs = m2ids m e - not_needed = case pull_lasts $ set_simplys xs False e of + not_needed = case pull_lasts $ setSimplys xs InLast e of rest :> _ -> mapFL thd rest ch pc@(PC tp@(TP t _) _) | t `elem` not_needed = pc | otherwise = PC tp InLast in PCs $ mapFL_FL ch e -force_last :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) -force_last p pc = reverse_pc $ force_first p $ reverse_pc pc +forceLast :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) +forceLast p pc = reverse_pc $ forceFirst p $ reverse_pc pc -force_lasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -force_lasts ps pc = reverse_pc $ force_firsts ps $ reverse_pc pc +forceLasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +forceLasts ps pc = reverse_pc $ forceFirsts ps $ reverse_pc pc -make_uncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) -make_uncertain t (PCs e) = PCs $ mapFL_FL ch e +makeUncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) +makeUncertain t (PCs e) = PCs $ mapFL_FL ch e where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc -make_everything_later (PCs e) = PCs $ mapFL_FL ch e +makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y) +makeEverythingLater (PCs e) = PCs $ mapFL_FL ch e where ch (PC tp InMiddle) = PC tp InLast ch (PC tp InFirst) = PC tp InMiddle ch x = x + +-- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice +-- associated with @a@ +substitute :: forall p C(x y) + . Patchy p + => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p)) + -> PatchChoices p C(x y) + -> PatchChoices p C(x y) +substitute (Sealed2 (tp :||: new_tps)) (PCs pcs) = PCs (concatFL (mapFL_FL translate pcs)) + where translate :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b) + translate (PC tp' c) + | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps + | otherwise = PC tp' c :>: NilFL diff --git a/src/Darcs/Patch/Commute.lhs b/src/Darcs/Patch/Commute.lhs --- a/src/Darcs/Patch/Commute.lhs +++ b/src/Darcs/Patch/Commute.lhs @@ -24,9 +24,9 @@ #include "gadts.h" module Darcs.Patch.Commute ( fromPrims, - modernize_patch, + modernizePatch, #ifndef GADT_WITNESSES - merge, elegant_merge, + merge, elegantMerge, merger, unravel, #endif public_unravel, mangle_unravelled, @@ -40,23 +40,23 @@ import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn ) import Darcs.Patch.Info ( invert_name, idpatchinfo ) -import Darcs.Patch.Patchy ( Commute(..), Invert(..) ) +import Darcs.Patch.Patchy ( Commute(..), Invert(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Core ( Patch(..), Named(..), #ifndef GADT_WITNESSES flattenFL, - is_merger, + isMerger, #endif merger_undo, join_patchesFL ) import Darcs.Patch.Prim ( Prim(..), FromPrims(..), Conflict(..), Effect(..), - is_filepatch, sort_coalesceFL, + is_filepatch, sortCoalesceFL, #ifndef GADT_WITNESSES FilePatchType(..), DirPatchType(..), #else FilePatchType(Hunk), #endif - is_hunk, modernizePrim ) + primIsHunk, modernizePrim ) import qualified Data.ByteString.Char8 as BC (pack, last) import qualified Data.ByteString as B (null, ByteString) import Data.Maybe ( isJust ) @@ -67,12 +67,12 @@ import Darcs.Patch.Patchy ( invertRL ) import Darcs.Patch.Show ( showPatch_ ) import Data.List ( nubBy ) -import Darcs.Sealed ( unsafeUnseal ) +import Darcs.Witnesses.Sealed ( unsafeUnseal ) #endif import Darcs.Utils ( nubsort ) #include "impossible.h" -import Darcs.Sealed ( Sealed(..), mapSeal ) -import Darcs.Ordered ( mapFL, mapFL_FL, unsafeCoerceP, +import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal ) +import Darcs.Witnesses.Ordered ( mapFL, mapFL_FL, unsafeCoerceP, FL(..), RL(..), (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..), #ifndef GADT_WITNESSES @@ -196,17 +196,18 @@ merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2) = case merge (p1 :\/: p2) of (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1' - list_touched_files (NamedP _ _ p) = list_touched_files p + listTouchedFiles (NamedP _ _ p) = listTouchedFiles p + hunkMatches f (NamedP _ _ p) = hunkMatches f p instance Conflict p => Conflict (Named p) where - list_conflicted_files (NamedP _ _ p) = list_conflicted_files p - resolve_conflicts (NamedP _ _ p) = resolve_conflicts p + listConflictedFiles (NamedP _ _ p) = listConflictedFiles p + resolveConflicts (NamedP _ _ p) = resolveConflicts p everything_else_commute :: MaybeCommute -> CommuteFunction everything_else_commute c x = eec x where eec :: CommuteFunction - eec (PP px :< PP py) = toPerhaps $ do y' :< x' <- commutex (px :< py) + eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px) return (PP y' :< PP x') eec (ComP NilFL :< p1) = Succeeded (unsafeCoerceP p1 :< (ComP NilFL)) eec (p2 :< ComP NilFL) = Succeeded (ComP NilFL :< unsafeCoerceP p2) @@ -260,30 +261,36 @@ merge (y :\/: z) = #ifndef GADT_WITNESSES case actual_merge (y:\/:z) of - y' -> case commutex (y' :< z) of + y' -> case commute (z :> y') of Nothing -> bugDoc $ text "merge_patches bug" $$ showPatch_ y $$ showPatch_ z $$ showPatch_ y' - Just (z' :< _) -> z' :/\: y' + Just (_ :> z') -> z' :/\: y' #else - case elegant_merge (y:\/:z) of + case elegantMerge (y:\/:z) of Just (z' :/\: y') -> z' :/\: y' Nothing -> undefined #endif - commutex x = toMaybe $ msum [speedy_commute x, + commute x = toMaybe $ msum + [toFwdCommute speedy_commute x, #ifndef GADT_WITNESSES - clever_commute merger_commute x, + toFwdCommute (clever_commute merger_commute) x, #endif - everything_else_commute commutex x - ] + toFwdCommute (everything_else_commute (toRevCommute commute)) x + ] -- Recurse on everything, these are potentially spoofed patches - list_touched_files (ComP ps) = nubsort $ concat $ mapFL list_touched_files ps - list_touched_files (Merger _ _ p1 p2) = nubsort $ list_touched_files p1 - ++ list_touched_files p2 - list_touched_files c@(Regrem _ _ _ _) = list_touched_files $ invert c - list_touched_files (PP p) = list_touched_files p + listTouchedFiles (ComP ps) = nubsort $ concat $ mapFL listTouchedFiles ps + listTouchedFiles (Merger _ _ p1 p2) = nubsort $ listTouchedFiles p1 + ++ listTouchedFiles p2 + listTouchedFiles c@(Regrem _ _ _ _) = listTouchedFiles $ invert c + listTouchedFiles (PP p) = listTouchedFiles p + hunkMatches f (ComP ps) = or $ mapFL (hunkMatches f) ps + hunkMatches f (Merger _ _ p1 p2) = hunkMatches f p1 || hunkMatches f p2 + hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c + hunkMatches f (PP p) = hunkMatches f p + commute_no_merger :: MaybeCommute commute_no_merger x = #ifndef GADT_WITNESSES @@ -306,19 +313,19 @@ #ifndef GADT_WITNESSES commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) commute_recursive_merger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ - do (pA' :< _) <- commutex (undo :< pA) - commutex (invert undo :< pA') - (pAmid :< _) <- commutex (invert p1 :< pA) - (pAx :< p1') <- commutex (p1 :< pAmid) + do (_ :> pA') <- commute (pA :> undo) + commute (pA' :> invert undo) + (_ :> pAmid) <- commute (pA :> invert p1) + (p1' :> pAx) <- commute (pAmid :> p1) assert (pAx `unsafeCompare` pA) - (_ : _) <- commute (pAmid :> p2) + (p2o :> _) <- commute (invert pAmid :> p2') assert (p2o `unsafeCompare` p2) let p' = if unsafeCompare p1' p1 && unsafeCompare p2' p2 then p else merger "0.0" p1' p2' undo' = merger_undo p' - (_ :< pAo) <- commutex (pA' :< undo') + (pAo :> _) <- commute (undo' :> pA') assert (pAo `unsafeCompare` pA) return (pA' :< p') where undo = merger_undo p @@ -327,19 +334,19 @@ other_commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) other_commute_recursive_merger (pA':< p_old@(Merger _ _ p1' p2')) = toPerhaps $ - do (_ :< pA) <- commutex (pA' :< merger_undo p_old) - (p1 :< pAmid) <- commutex (pA :< p1') - (pAmido :< _) <- commutex (invert p1 :< pA) + do (pA :> _) <- commute (merger_undo p_old :> pA') + (pAmid :> p1) <- commute (p1' :> pA) + (_ :> pAmido) <- commute (pA :> invert p1) assert (pAmido `unsafeCompare` pAmid) - (_ :< p2) <- commutex (p2' :< invert pAmid) - (_ :< p2o') <- commutex (p2 :< pAmid) + (p2 :> _) <- commute (invert pAmid :> p2') + (p2o' :> _) <- commute (pAmid :> p2) assert (p2o' `unsafeCompare` p2') let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2' then p_old else merger "0.0" p1 p2 undo = merger_undo p assert (not $ pA `unsafeCompare` p1) -- special case here... - (pAo' :< _) <- commutex (undo : pAo') <- commute (pA :> undo) assert (pAo' `unsafeCompare` pA') return (p :< pA) other_commute_recursive_merger _ = Unknown @@ -411,16 +418,14 @@ \begin{code} -elegant_merge :: (Patch :\/: Patch) C(x y) +elegantMerge :: (Patch :\/: Patch) C(x y) -> Maybe ((Patch :/\: Patch) C(x y)) -elegant_merge (p1 :\/: p2) = - case commutex (p1 :< invert p2) of - Just (ip2': case commutex (p1' :< p2) of - Nothing -> Nothing -- should be a redundant check - Just (_: if unsafeCompare p1o p1 - then Just (invert ip2' :/\: p1') - else Nothing - Nothing -> Nothing +elegantMerge (p1 :\/: p2) = do + p1' :> ip2' <- commute (invert p2 :> p1) + p1o :> _ <- commute (p2 :> p1') + if unsafeCompare p1o p1 -- should be a redundant check + then return $ invert ip2' :/\: p1' + else Nothing \end{code} @@ -455,7 +460,7 @@ join_patchesFL $ merge_patches_after_patch p1s p2 actual_merge (p1 :\/: ComP p2s) = seq p1 $ merge_patch_after_patches p1 p2s -actual_merge (p1 :\/: p2) = case elegant_merge (p1:\/:p2) of +actual_merge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of Just (_ :/\: p1') -> p1' Nothing -> merger "0.0" p2 p1 @@ -466,8 +471,8 @@ merge_patches_after_patch :: FL Patch -> Patch -> FL Patch merge_patches_after_patch p2s p = - case commutex (merge_patch_after_patches p p2s :< join_patchesFL p2s) of - Just (ComP p2s':< _) -> p2s' + case commute (join_patchesFL p2s :> merge_patch_after_patches p p2s) of + Just (_ :> ComP p2s') -> p2s' _ -> impossible #endif \end{code} @@ -602,8 +607,8 @@ put_before :: Patch -> FL Patch -> Maybe (FL Patch) put_before p1 (p2:>:p2s) = - do p2': p2' <- commute (p2 :> invert p1) + commute (p2' :> p1) (p2' :>:) `fmap` put_before p1' p2s put_before _ NilFL = Just NilFL #endif @@ -636,7 +641,7 @@ commute_no_conflicts (x:>y) = do x' :< y' <- commute_no_merger (y :< x) return (y':>x') #ifndef GADT_WITNESSES - resolve_conflicts patch = rcs NilFL $ reverseFL $ flattenFL patch + resolveConflicts patch = rcs NilFL $ reverseFL $ flattenFL patch where rcs :: FL Patch C(w y) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]] rcs _ NilRL = [] rcs passedby (p@(Merger _ _ _ _):<:ps) = @@ -649,7 +654,7 @@ rcs passedby (p:<:ps) = seq passedby $ rcs (p :>: passedby) ps #else - resolve_conflicts = bug "haven't defined resolve_conflicts with type witnesses." + resolveConflicts = bug "haven't defined resolveConflicts with type witnesses." #endif public_unravel :: Patch C(x y) -> [Sealed (FL Prim C(y))] @@ -662,7 +667,7 @@ #ifndef GADT_WITNESSES unravel :: Patch -> [FL Prim] unravel p = nubBy unsafeCompare $ - map (sort_coalesceFL . concatFL . mapFL_FL effect) $ + map (sortCoalesceFL . concatFL . mapFL_FL effect) $ get_supers $ map reverseRL $ new_ur p $ unwind p get_supers :: [FL Patch] -> [FL Patch] @@ -695,7 +700,7 @@ unwindings = true_unwind fake_p p = Merger identity unwindings p1 p2 undoit = - case (is_merger p1, is_merger p2) of + case (isMerger p1, isMerger p2) of (True ,True ) -> join_patchesFL $ invertRL $ tailRL $ unwind p where tailRL (_:<:t) = t tailRL _ = impossible @@ -721,8 +726,8 @@ only_hunks pss = fn2fp f /= "" && all oh pss where f = get_a_filename pss oh :: Sealed (FL Prim C(x)) -> Bool - oh (Sealed (p:>:ps)) = is_hunk p && - [fn2fp f] == list_touched_files p && + oh (Sealed (p:>:ps)) = primIsHunk p && + [fn2fp f] == listTouchedFiles p && oh (Sealed ps) oh (Sealed NilFL) = True @@ -785,17 +790,17 @@ else "" instance Effect Patch where - effect p@(Merger _ _ _ _) = sort_coalesceFL $ effect $ merger_undo p + effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ merger_undo p effect p@(Regrem _ _ _ _) = invert $ effect $ invert p effect (ComP ps) = concatFL $ mapFL_FL effect ps effect (PP p) = effect p isHunk p = do PP p' <- return p isHunk p' -modernize_patch :: Patch C(x y) -> Patch C(x y) -modernize_patch p@(Merger _ _ _ _) = fromPrims $ effect p -modernize_patch p@(Regrem _ _ _ _) = fromPrims $ effect p -modernize_patch (ComP ps) = ComP $ filtermv $ mapFL_FL modernize_patch ps +modernizePatch :: Patch C(x y) -> Patch C(x y) +modernizePatch p@(Merger _ _ _ _) = fromPrims $ effect p +modernizePatch p@(Regrem _ _ _ _) = fromPrims $ effect p +modernizePatch (ComP ps) = ComP $ filtermv $ mapFL_FL modernizePatch ps where filtermv :: FL Patch C(x y) -> FL Patch C(x y) #ifndef GADT_WITNESSES filtermv (PP (Move _ b):>:xs) | hasadd xs = filtermv xs @@ -809,7 +814,7 @@ filtermv (x:>:xs) = x :>: filtermv xs filtermv NilFL = NilFL -modernize_patch (PP p) = fromPrims $ modernizePrim p +modernizePatch (PP p) = fromPrims $ modernizePrim p instance FromPrims Patch where fromPrims (p :>: NilFL) = PP p @@ -828,7 +833,7 @@ $$ vcat (mapRL showPatch_ $ unwind p) new_ur op ps = - case filter (is_merger.headRL) $ head_permutationsRL ps of + case filter (isMerger.headRL) $ head_permutationsRL ps of [] -> [ps] (ps':_) -> new_ur op ps' diff --git a/src/Darcs/Patch/Core.lhs b/src/Darcs/Patch/Core.lhs --- a/src/Darcs/Patch/Core.lhs +++ b/src/Darcs/Patch/Core.lhs @@ -28,10 +28,10 @@ module Darcs.Patch.Core ( Patch(..), Named(..), join_patchesFL, concatFL, flattenFL, - nullP, is_null_patch, infopatch, + nullP, isNullPatch, infopatch, n_fn, adddeps, namepatch, anonymous, - merger_undo, is_merger, + merger_undo, isMerger, getdeps, patch2patchinfo, patchname, patchcontents, ) @@ -40,7 +40,7 @@ import Prelude hiding ( pi ) import Darcs.Patch.Info ( PatchInfo, patchinfo, make_filename ) import Darcs.Patch.Patchy ( Patchy ) -import Darcs.Ordered +import Darcs.Witnesses.Ordered import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), n_fn ) #include "impossible.h" @@ -61,26 +61,34 @@ instance FromPrim Patch where fromPrim = PP +-- | The @Named@ type adds a patch info about a patch, that is a name. data Named p C(x y) where - NamedP :: !PatchInfo -> ![PatchInfo] -> !(p C(x y)) -> Named p C(x y) + NamedP :: !PatchInfo + -> ![PatchInfo] + -> !(p C(x y)) + -> Named p C(x y) +-- ^ @NamedP info deps p@ represents patch @p@ with name +-- @info@. @deps@ is a list of dependencies added at the named patch +-- level, compared with the unnamed level (ie, dependencies added with +-- @darcs record --ask-deps@). instance Effect p => Effect (Named p) where effect (NamedP _ _ p) = effect p effectRL (NamedP _ _ p) = effectRL p -is_null_patch :: Patch C(x y) -> Bool -is_null_patch (ComP ps) = and $ mapFL is_null_patch ps -is_null_patch _ = False +isNullPatch :: Patch C(x y) -> Bool +isNullPatch (ComP ps) = and $ mapFL isNullPatch ps +isNullPatch _ = False nullP :: Patch C(x y) -> EqCheck C(x y) nullP (ComP NilFL) = IsEq nullP (ComP (x:>:xs)) | IsEq <- nullP x = nullP (ComP xs) nullP _ = NotEq -is_merger :: Patch C(a b) -> Bool -is_merger (Merger _ _ _ _) = True -is_merger (Regrem _ _ _ _) = True -is_merger _ = False +isMerger :: Patch C(a b) -> Bool +isMerger (Merger _ _ _ _) = True +isMerger (Regrem _ _ _ _) = True +isMerger _ = False merger_undo :: Patch C(x y) -> Patch C(x y) merger_undo (Merger undo _ _ _) = undo diff --git a/src/Darcs/Patch/Depends.hs b/src/Darcs/Patch/Depends.hs --- a/src/Darcs/Patch/Depends.hs +++ b/src/Darcs/Patch/Depends.hs @@ -33,10 +33,10 @@ import Control.Monad ( liftM2 ) import Control.Monad.Error ( Error(..) ) -import Darcs.Patch ( RepoPatch, Named, getdeps, commutex, +import Darcs.Patch ( RepoPatch, Named, getdeps, commute, commuteFL, patch2patchinfo, merge ) -import Darcs.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..), +import Darcs.Witnesses.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..), RL(..), FL(..), (+<+), reverseFL, mapFL_FL, mapFL, concatReverseFL, @@ -49,15 +49,15 @@ import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia, hopefully, conscientiously, hopefullyM ) import Darcs.ProgressPatches ( progressRL ) -import Darcs.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..) - , flipSeal, seal, unseal ) +import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..) + , flipSeal, seal, unseal, mapFlipped ) import Printer ( errorDoc, renderString, ($$), text ) #include "impossible.h" get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> - ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> - Either PatchInfo ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + Either PatchInfo ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) get_common_and_uncommon = either missingPatchError id . get_common_and_uncommon_err @@ -66,7 +66,7 @@ either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> - Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2 {-| @@ -184,15 +184,15 @@ -} gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y) - -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) -gcau NilRL ps2 = return ([], NilRL:<:NilRL :\/: concatRL ps2 :<: NilRL) -gcau ps1 NilRL = return ([], concatRL ps1 :<: NilRL :\/: NilRL:<:NilRL) + -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) +gcau NilRL ps2 = return ([], NilRL :\/: concatRL ps2) +gcau ps1 NilRL = return ([], concatRL ps1 :\/: NilRL) gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2 gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2 gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_) | info pi1 == info pi2 , IsEq <- sloppyIdentity pi1 - , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL:<:NilRL :\/: unsafeCoerceP (NilRL:<:NilRL)) + , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL :\/: unsafeCoerceP NilRL) gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) = f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s (lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s @@ -200,7 +200,7 @@ lx = last $ concatReverseFL psx -} f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r) -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u) - -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s | l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2)) f n1 l1 ps1 ps1s n2 l2 ps2 ps2s @@ -242,12 +242,12 @@ -- | Filters the common elements from @ps1@ and @ps2@ and returns the simplified sequences. gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y) -- ^ @ps1@ -> RL (PatchInfoAnd p) C(u v) -- ^ @ps2@ - -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(y v)) + -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(y v)) gcau_simple ps1 ps2 = do FlippedSeal ex1 <- get_extra common ps1 FlippedSeal ex2 <- get_extra common ps2 let ps1' = filter (`elem` common) $ ps1_info - return (ps1', (unsafeCoerceP ex1 :<: NilRL) :\/: ex2 :<: NilRL) + return (ps1', (unsafeCoerceP ex1 :\/: ex2)) where common = ps1_info `intersect` mapRL info ps2 ps1_info = mapRL info ps1 @@ -258,7 +258,33 @@ noMsg = bug "MissingPatch doesn't define noMsg." -- | Returns a sub-sequence from @patches@, where all the elements of @common@ have --- been removed by commuting them out. +-- been removed by commuting them back into the early part of the history. +-- +-- An informal illustration of this process as it traverses a mixed list of patches +-- where C and x denote common patches and extra patches accordingly. Variants of +-- patches obtained through commutation are indicated by letters following the +-- patch name. +-- +-- > in: x6 < x5 < C4 < x3 < C2 < x1 skip: extra: +-- > in: x5 < C4 < x3 < C2 < x1 skip: extra: x6 +-- > in: C4 < x3 < C2 < x1 skip: extra: x5 > x6 +-- > in: x3 < C2 < x1 skip: C4 extra: x5 > x6 +-- > in: C2 < x1 skip: C4b extra: x3b > x5 > x6 +-- > in: x1 skip: C2 > C4b extra: x3b > x5 > x6 +-- > in: skip: C2b > C4c extra: x1b > x3b > x5 > x6 +-- +-- This function is undefined if for any reason we fail to commute an extra +-- patch past one of the common ones. Such a failure would indicate that the +-- common patch depends on the extra one, contradicting the claim that the +-- \"common\" patch is shared with another repository lacking the extra patches. +-- Unfortunately, such cases have crept up in practice. Some notable cases can +-- be found on the bugtracker as: +-- +-- * issue27 - different patches with identical patch info; mistaken identity. +-- Note how @common@ consists only of a list of 'PatchInfo' which +-- we trust to uniquely identify such patches. +-- +-- * issue1014 - duplicate patches get_extra :: RepoPatch p => [PatchInfo] -- ^ @common@ -> RL (PatchInfoAnd p) C(u x) -- ^ @patches@ -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y)) @@ -313,19 +339,14 @@ get_extra_old common pps = either missingPatchError id (get_extra common pps) -get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) -get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal $ NilRL :<: NilRL +get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x) +get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal NilRL get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) = if info hp == t then if get_tags_right patchset == [info hp] - then flipSeal $ NilRL :<: NilRL -- special case to avoid looking at redundant patches - else case get_extra_old [t] (concatRL patchset) of - FlippedSeal x -> flipSeal $ x :<: NilRL - else hp `prepend` get_patches_beyond_tag t (ps:<:pps) - where - prepend :: (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(y) - prepend pp (FlippedSeal NilRL) = flipSeal $ (pp:<:NilRL) :<: NilRL - prepend pp (FlippedSeal (p:<:ps')) = flipSeal $ (pp:<:p) :<: ps' + then flipSeal NilRL -- special case to avoid looking at redundant patches + else get_extra_old [t] (concatRL patchset) + else mapFlipped (hp:<:) $ get_patches_beyond_tag t (ps:<:pps) get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps get_patches_beyond_tag t NilRL = bug $ "tag\n" ++ renderString (human_friendly t) ++ @@ -367,9 +388,9 @@ -> FL (PatchInfoAnd p) C(w z) commute_by NilFL _ = unsafeCoerceP NilFL commute_by (hpa:>:xs') p = - case commutex (hopefully hpa :< p) of + case commute (p :> hopefully hpa) of Nothing -> bug "Failure commuting patches in commute_by called by gpit!" - Just (p': (info hpa `piap` a') :>: commute_by xs' p' + Just (a' :> p') -> (info hpa `piap` a') :>: commute_by xs' p' get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag" $$ human_friendly t @@ -481,13 +502,12 @@ f common a b = g_s $ gcau_simple a b where g_s :: Either MissingPatch - ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) -> SealedPatchSet p g_s (Left e) = missingPatchError e - g_s (Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL))) = + g_s (Right (_, a' :\/: b')) = case (merge_sets (a' :\/: b')) of Sealed a'b' -> seal $ (a'b' +<+ b) :<: common - g_s _ = impossible merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y)) merge_sets (l :\/: r) = 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 @@ -21,7 +21,7 @@ fp2fn, fn2fp, fn2ps, ps2fn, niceps2fn, fn2niceps, - break_on_dir, norm_path, own_name, super_name, + break_on_dir, norm_path, own_name, superName, movedirfilename, encode_white, decode_white, (///), @@ -30,9 +30,9 @@ import System.IO import Data.Char ( isSpace, chr, ord ) -import qualified UTF8 ( encode ) +import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) +import Codec.Binary.UTF8.Generic ( toString ) import Data.Word ( Word8( ) ) -import ByteStringUtils ( unpackPSfromUTF8 ) import qualified Data.ByteString.Char8 as BC (unpack, pack) import qualified Data.ByteString as B (ByteString, pack) @@ -66,7 +66,7 @@ {-# INLINE ps2fn #-} ps2fn :: B.ByteString -> FileName -ps2fn ps = FN $ decode_white $ unpackPSfromUTF8 ps +ps2fn ps = FN $ decode_white $ toString ps -- | 'encode_white' translates whitespace in filenames to a darcs-specific -- format (backslash followed by numerical representation according to 'ord'). @@ -98,8 +98,8 @@ own_name :: FileName -> FileName own_name (FN f) = case breakLast '/' f of Nothing -> FN f Just (_,f') -> FN f' -super_name :: FileName -> FileName -super_name fn = case norm_path fn of +superName :: FileName -> FileName +superName fn = case norm_path fn of FN f -> case breakLast '/' f of Nothing -> FN "." Just (d,_) -> FN d 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 @@ -32,10 +32,11 @@ import qualified Data.ByteString as B (length, splitAt, null, drop ,isPrefixOf, tail, concat, ByteString ) import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break) +import Data.List( isPrefixOf ) import Printer ( renderString, Doc, packedString, empty, ($$), (<>), (<+>), vcat, text, blueText, prefix ) -import OldDate ( readUTCDate, showIsoDateTime ) +import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO ) @@ -72,7 +73,8 @@ add_junk pinf = do x <- randomRIO (0,2^(128 ::Integer) :: Integer) when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $ - do yorn <- promptYorn "Lines beginning with 'Ignore-this: ' will be ignored.\nProceed? " + do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored." + yorn <- promptYorn "Proceed? " when (yorn == 'n') $ fail "User cancelled because of Ignore-this." return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""): _pi_log pinf } @@ -118,7 +120,7 @@ pi_author = BC.unpack . _pi_author is_tag :: PatchInfo -> Bool -is_tag pinfo = take 4 (just_name pinfo) == "TAG " +is_tag pinfo = "TAG " `isPrefixOf` just_name pinfo -- | Note: we ignore timezone information in the date string, diff --git a/src/Darcs/Patch/Match.lhs b/src/Darcs/Patch/Match.lhs --- a/src/Darcs/Patch/Match.lhs +++ b/src/Darcs/Patch/Match.lhs @@ -35,13 +35,14 @@ import System.IO.Unsafe ( unsafePerformIO ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) -import Darcs.Patch ( Patch, Patchy, list_touched_files, patchcontents ) +import Darcs.Patch ( Patch, Patchy, hunkMatches, listTouchedFiles, patchcontents ) import Darcs.Patch.Info ( just_name, just_author, make_filename, pi_date ) -import Darcs.Sealed ( Sealed2(..), seal2 ) +import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 ) import DateMatcher ( parseDateMatcher ) import Darcs.Patch.MatchData ( PatchMatch(..), patch_match ) +import qualified Data.ByteString.Char8 as BC -- | A type for predicates over patches which do not care about -- contexts @@ -78,7 +79,7 @@ trivial = const True \end{code} -\paragraph{Match} +\subsection{Match} Currently \verb!--match! accepts six primitive match types, although there are plans to expand it to match more patterns. Also, note that the @@ -304,6 +305,9 @@ , ("author", "check a regular expression against the author name" , ["\"David Roundy\"", "droundy", "droundy@darcs.net"] , authormatch ) + , ("hunk", "check a regular expression against the contents of a hunk patch" + , ["foo = 2", "^instance .* Foo where$"] + , hunkmatch ) , ("hash", "match the darcs hash for a patch" , ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"] , hashmatch ) @@ -327,7 +331,7 @@ <|> between spaces spaces (many $ noneOf " ()") "string" -mymatch, exactmatch, authormatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p +mymatch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ just_name (info hp) @@ -335,12 +339,17 @@ authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ just_author (info hp) + +hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp + regexMatcher = isJust . (matchRegex (mkRegex r) . BC.unpack) + in hunkMatches regexMatcher patch + hashmatch h (Sealed2 hp) = let rh = make_filename (info hp) in (rh == h) || (rh == h++".gz") datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d in dm $ pi_date (info hp) -touchmatch r (Sealed2 hp) = let files = list_touched_files $ patchcontents $ hopefully hp +touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp in or $ map (isJust . matchRegex (mkRegex r)) files \end{code} diff --git a/src/Darcs/Patch/Non.hs b/src/Darcs/Patch/Non.hs --- a/src/Darcs/Patch/Non.hs +++ b/src/Darcs/Patch/Non.hs @@ -34,15 +34,15 @@ import Data.List ( delete ) import Control.Monad ( liftM ) import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Effect(..), - showPrim, FileNameFormat(..), sort_coalesceFL ) + showPrim, FileNameFormat(..), sortCoalesceFL ) import Darcs.Patch.Patchy import Darcs.Patch.ReadMonads ( ParserM, lex_char ) -import Darcs.Ordered +import Darcs.Witnesses.Ordered import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Viewing () import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL ) -import Darcs.Show -import Darcs.Sealed ( Sealed(Sealed) ) +import Darcs.Witnesses.Show +import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, redText, ($$) ) --import Darcs.ColorPrinter ( traceDoc ) @@ -62,7 +62,7 @@ where rns = peekfor "}}" (return []) $ do Just (Sealed ps) <- readPatch' False lex_char ':' - Just (Sealed p) <- readPrim NewFormat False + Just (Sealed p) <- readPrim NewFormat (Non ps p :) `liftM` rns readNon :: (ReadPatch p, ParserM m) => m (Maybe (Non p C(x))) @@ -90,10 +90,28 @@ 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 +-- 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 +-- | '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 +-- +-- > x1 x2 x3 [c1 c2 y] +-- +-- and that in our example @c1@ fails to commute past @x1@, this +-- function would commute down to +-- +-- > 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 @@ -112,7 +130,7 @@ remNonHelper [] x = NilFL :> x remNonHelper ns (c:>:cs) | non c `elem` ns = case remNonHelper (map (addP $ invert c) $ delete (non c) ns) cs of - a :> z -> sort_coalesceFL (effect c+>+a) :> z + a :> z -> sortCoalesceFL (effect c+>+a) :> z | otherwise = case commuteWhatWeCanFL (c :> cs) of b :> c' :> d -> case remNonHelper ns b of diff --git a/src/Darcs/Patch/OldDate.hs b/src/Darcs/Patch/OldDate.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/OldDate.hs @@ -0,0 +1,350 @@ +-- Copyright (C) 2003 Peter Simons +-- Copyright (C) 2003,2008 David Roundy +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +-- This module is intended to provide backwards-compatibility in the parsing +-- of darcs patches. In other words: don't change it, new features don't get +-- added here. The only user should be Darcs.Patch.Info. + +module Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where + +import Text.ParserCombinators.Parsec +import System.Time +import Data.Char ( toUpper, isDigit ) +import Control.Monad ( liftM, liftM2 ) +import qualified Data.ByteString.Char8 as B +import Data.Maybe ( fromMaybe ) + +-- | Read/interpret a date string, assuming UTC if timezone +-- is not specified in the string +readUTCDate :: String -> CalendarTime +readUTCDate = readDate 0 + +readDate :: Int -> String -> CalendarTime +readDate tz d = + case parseDate tz d of + Left e -> error e + Right ct -> ct + +parseDate :: Int -> String -> Either String CalendarTime +parseDate tz d = + if length d >= 14 && B.all isDigit bd + then Right $ + CalendarTime (readI $ B.take 4 bd) + (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd) + (readI $ B.take 2 $ B.drop 6 bd) -- Day + (readI $ B.take 2 $ B.drop 8 bd) -- Hour + (readI $ B.take 2 $ B.drop 10 bd) -- Minute + (readI $ B.take 2 $ B.drop 12 bd) -- Second + 0 Sunday 0 -- Picosecond, weekday and day of year unknown + "GMT" 0 False + else let dt = do { x <- date_time tz; eof; return x } + in case parse dt "" d of + Left e -> Left $ "bad date: "++d++" - "++show e + Right ct -> Right ct + where bd = B.pack (take 14 d) + readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s) + +showIsoDateTime :: CalendarTime -> String +showIsoDateTime ct = concat [ show $ ctYear ct + , twoDigit . show . (+1) . fromEnum $ ctMonth ct + , twoDigit . show $ ctDay ct + , twoDigit . show $ ctHour ct + , twoDigit . show $ ctMin ct + , twoDigit . show $ ctSec ct + ] + where twoDigit [] = undefined + twoDigit x@(_:[]) = '0' : x + twoDigit x@(_:_:[]) = x + twoDigit _ = undefined + +----- Parser Combinators --------------------------------------------- + +-- |Case-insensitive variant of Parsec's 'char' function. + +caseChar :: Char -> GenParser Char a Char +caseChar c = satisfy (\x -> toUpper x == toUpper c) + +-- |Case-insensitive variant of Parsec's 'string' function. + +caseString :: String -> GenParser Char a () +caseString cs = mapM_ caseChar cs cs + +-- |Match a parser at least @n@ times. + +manyN :: Int -> GenParser a b c -> GenParser a b [c] +manyN n p + | n <= 0 = return [] + | otherwise = liftM2 (++) (count n p) (many p) + +-- |Match a parser at least @n@ times, but no more than @m@ times. + +manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c] +manyNtoM n m p + | n < 0 = return [] + | n > m = return [] + | n == m = count n p + | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) + | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) + + +----- Date/Time Parser ----------------------------------------------- + +date_time :: Int -> CharParser a CalendarTime +date_time tz = + choice [try $ cvs_date_time tz, + try $ iso8601_date_time tz, + old_date_time] + +cvs_date_time :: Int -> CharParser a CalendarTime +cvs_date_time tz = + do y <- year + char '/' + mon <- month_num + char '/' + d <- day + my_spaces + h <- hour + char ':' + m <- minute + char ':' + s <- second + z <- option tz $ my_spaces >> zone + return (CalendarTime y mon d h m s 0 Monday 0 "" z False) + +old_date_time :: CharParser a CalendarTime +old_date_time = do wd <- day_name + my_spaces + mon <- month_name + my_spaces + d <- day + my_spaces + h <- hour + char ':' + m <- minute + char ':' + s <- second + my_spaces + z <- zone + my_spaces + y <- year + return (CalendarTime y mon d h m s 0 wd 0 "" z False) + +{- FIXME: In case you ever want to use this outside of darcs, you should note + that this implementation of ISO 8601 is not complete. + + reluctant to implement (ambiguous!): + * years > 9999 + * truncated representations with implied century (89 for 1989) + unimplemented: + * repeated durations (not relevant) + * lowest order component fractions in intervals + * negative dates (BC) + unverified or too relaxed: + * the difference between 24h and 0h + * allows stuff like 2005-1212; either you use the hyphen all the way + (2005-12-12) or you don't use it at all (20051212), but you don't use + it halfway, likewise with time + * No bounds checking whatsoever on intervals! + (next action: read iso doc to see if bounds-checking required?) -} +iso8601_date_time :: Int -> CharParser a CalendarTime +iso8601_date_time localTz = try $ + do d <- iso8601_date + t <- option id $ try $ do optional $ oneOf " T" + iso8601_time + return $ t $ d { ctTZ = localTz } + +iso8601_date :: CharParser a CalendarTime +iso8601_date = + do d <- calendar_date <|> week_date <|> ordinal_date + return $ foldr ($) nullCalendar d + where + calendar_date = -- yyyy-mm-dd + try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] + -- allow other variants to be parsed correctly + notFollowedBy (digit <|> char 'W') + return d + week_date = --yyyy-Www-dd + try $ do yfn <- year_ + optional dash + char 'W' + -- offset human 'week 1' -> computer 'week 0' + w' <- (\x -> x-1) `liftM` two_digits + wd <- option 1 $ do { optional dash; n_digits 1 } + let y = yfn nullCalendar + firstDay = ctWDay y + -- things that make this complicated + -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday + -- 2. the first week is the one that contains at least Thursday + -- if the year starts after Thursday, then some days of the year + -- will have already passed before the first week + let afterThursday = firstDay == Sunday || firstDay > Thursday + w = if afterThursday then w'+1 else w' + diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) } + return [(toUTCTime.toClockTime.diff.yfn)] + ordinal_date = -- yyyy-ddd + try $ optchain year_ [ (dash, yearDay_) ] + -- + year_ = try $ do y <- four_digits "year (0000-9999)" + return $ \c -> c { ctYear = y } + month_ = try $ do m <- two_digits "month (1 to 12)" + -- we (artificially) use ctPicosec to indicate + -- whether the month has been specified. + return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 } + day_ = try $ do d <- two_digits "day in month (1 to 31)" + return $ \c -> c { ctDay = d } + yearDay_ = try $ do d <- n_digits 3 "day in year (1 to 366)" + return $ \c -> c { ctYDay = d } + dash = char '-' + +-- we return a function which sets the time on another calendar +iso8601_time :: CharParser a (CalendarTime -> CalendarTime) +iso8601_time = try $ + do ts <- optchain hour_ [ (colon , min_) + , (colon , sec_) + , (oneOf ",.", pico_) ] + z <- option id $ choice [ zulu , offset ] + return $ foldr (.) id (z:ts) + where + hour_ = do h <- two_digits + return $ \c -> c { ctHour = h } + min_ = do m <- two_digits + return $ \c -> c { ctMin = m } + sec_ = do s <- two_digits + return $ \c -> c { ctSec = s } + pico_ = do digs <- many digit + let picoExp = 12 + digsExp = length digs + let frac | null digs = 0 + | digsExp > picoExp = read $ take picoExp digs + | otherwise = 10 ^ (picoExp - digsExp) * (read digs) + return $ \c -> c { ctPicosec = frac } + zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) } + offset = do sign <- choice [ do { char '+' >> return 1 } + , do { char '-' >> return (-1) } ] + h <- two_digits + m <- option 0 $ do { optional colon; two_digits } + return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) } + colon = char ':' + +optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] +optchain p next = try $ + do r1 <- p + r2 <- case next of + [] -> return [] + ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } + return (r1:r2) + +n_digits :: Int -> CharParser a Int +n_digits n = read `liftM` count n digit + +two_digits, four_digits :: CharParser a Int +two_digits = n_digits 2 +four_digits = n_digits 4 + +my_spaces :: CharParser a String +my_spaces = manyN 1 $ char ' ' + +day_name :: CharParser a Day +day_name = choice + [ caseString "Mon" >> return Monday + , try (caseString "Tue") >> return Tuesday + , caseString "Wed" >> return Wednesday + , caseString "Thu" >> return Thursday + , caseString "Fri" >> return Friday + , try (caseString "Sat") >> return Saturday + , caseString "Sun" >> return Sunday + ] + +year :: CharParser a Int +year = four_digits + +month_num :: CharParser a Month +month_num = do mn <- manyNtoM 1 2 digit + return $ intToMonth $ (read mn :: Int) + +intToMonth :: Int -> Month +intToMonth 1 = January +intToMonth 2 = February +intToMonth 3 = March +intToMonth 4 = April +intToMonth 5 = May +intToMonth 6 = June +intToMonth 7 = July +intToMonth 8 = August +intToMonth 9 = September +intToMonth 10 = October +intToMonth 11 = November +intToMonth 12 = December +intToMonth _ = error "invalid month!" + +month_name :: CharParser a Month +month_name = choice + [ try (caseString "Jan") >> return January + , caseString "Feb" >> return February + , try (caseString "Mar") >> return March + , try (caseString "Apr") >> return April + , caseString "May" >> return May + , try (caseString "Jun") >> return June + , caseString "Jul" >> return July + , caseString "Aug" >> return August + , caseString "Sep" >> return September + , caseString "Oct" >> return October + , caseString "Nov" >> return November + , caseString "Dec" >> return December + ] + +day :: CharParser a Int +day = do d <- manyNtoM 1 2 digit + return (read d :: Int) + +hour :: CharParser a Int +hour = two_digits + +minute :: CharParser a Int +minute = two_digits + +second :: CharParser a Int +second = two_digits + +zone :: CharParser a Int +zone = choice + [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) } + , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) } + , mkZone "UTC" 0 + , mkZone "UT" 0 + , mkZone "GMT" 0 + , mkZone "EST" (-5) + , mkZone "EDT" (-4) + , mkZone "CST" (-6) + , mkZone "CDT" (-5) + , mkZone "MST" (-7) + , mkZone "MDT" (-6) + , mkZone "PST" (-8) + , mkZone "PDT" (-7) + , mkZone "CEST" 2 + , mkZone "EEST" 3 + -- if we don't understand it, just give a GMT answer... + , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' ']) + (lookAhead space_digit); + return 0 } + ] + where mkZone n o = try $ do { caseString n; return (o*60*60) } + space_digit = try $ do { char ' '; oneOf ['0'..'9'] } + +nullCalendar :: CalendarTime +nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False diff --git a/src/Darcs/Patch/Patchy.hs b/src/Darcs/Patch/Patchy.hs --- a/src/Darcs/Patch/Patchy.hs +++ b/src/Darcs/Patch/Patchy.hs @@ -25,7 +25,7 @@ Apply, apply, applyAndTryToFix, applyAndTryToFixFL, mapMaybeSnd, Commute(..), commuteFL, commuteRL, commuteRLFL, - mergeFL, + mergeFL, toFwdCommute, toRevCommute, ShowPatch(..), ReadPatch, readPatch', bracketedFL, peekfor, Invert(..), invertFL, invertRL ) where @@ -35,10 +35,10 @@ import Data.Word ( Word8 ) import Data.List ( nub ) -import Darcs.SlurpDirectory ( Slurpy ) -import Darcs.Sealed ( Sealed(..), Sealed2(..), seal2 ) +import Storage.Hashed.Monad( TreeIO ) +import Darcs.Witnesses.Sealed ( Sealed(..), Sealed2(..), seal2 ) import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input ) -import Darcs.Ordered +import Darcs.Witnesses.Ordered import Printer ( Doc, (<>), text ) import Darcs.Lock ( writeDocBinFile, gzWriteDocFile ) import Darcs.IO ( WriteableDirectory ) @@ -69,22 +69,35 @@ mapMaybeSnd f (Just (a,b)) = Just (a,f b) mapMaybeSnd _ Nothing = Nothing +-- | Things that can commute. class Commute p where commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y)) - commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y)) - commute (x :> y) = do x' :< y' <- commutex (y :< x) - return (y' :> x') - commutex (x :< y) = do x' :> y' <- commute (y :> x) - return (y' :< x') merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y) - list_touched_files :: p C(x y) -> [FilePath] + listTouchedFiles :: p C(x y) -> [FilePath] + hunkMatches :: (BC.ByteString -> Bool) -> p C(x y) -> Bool +-- | Swaps the ordered pair type so that commute can be +-- called directly. +toFwdCommute :: (Commute p, Commute q, Monad m) + => ((p :< q) C(x y) -> m ((q :< p) C(x y))) + -> (q :> p) C(x y) -> m ((p :> q) C(x y)) +toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x) + return (y' :> x') + +-- | Swaps the ordered pair type from the order expected +-- by commute to the reverse order. +toRevCommute :: (Commute p, Commute q, Monad m) + => ((p :> q) C(x y) -> m ((q :> p) C(x y))) + -> (q :< p) C(x y) -> m ((p :< q) C(x y)) +toRevCommute c (x :< y) = do x' :> y' <- c (y :> x) + return (y' :< x') + class Commute p => ShowPatch p where showPatch :: p C(x y) -> Doc showNicely :: p C(x y) -> Doc showNicely = showPatch - showContextPatch :: Slurpy -> p C(x y) -> Doc - showContextPatch _ p = showPatch p + showContextPatch :: p C(x y) -> TreeIO Doc + showContextPatch p = return $ showPatch p description :: p C(x y) -> Doc description = showPatch summary :: p C(x y) -> Doc @@ -131,7 +144,8 @@ merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys) xs' :/\: ys'' <- return $ merge (ys' :\/: xs) return (ys'' :/\: (x' :>: xs')) - list_touched_files xs = nub $ concat $ mapFL list_touched_files xs + listTouchedFiles xs = nub $ concat $ mapFL listTouchedFiles xs + hunkMatches f = or . mapFL (hunkMatches f) mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y) mergeFL (p :\/: NilFL) = NilFL :/\: p @@ -216,7 +230,8 @@ return (reverseFL fys' :> xs') merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx' - list_touched_files = list_touched_files . reverseRL + listTouchedFiles = listTouchedFiles . reverseRL + hunkMatches f = hunkMatches f . reverseRL instance ReadPatch p => ReadPatch (RL p) where readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof return $ Just $ Sealed $ reverseFL fl diff --git a/src/Darcs/Patch/Permutations.hs b/src/Darcs/Patch/Permutations.hs --- a/src/Darcs/Patch/Permutations.hs +++ b/src/Darcs/Patch/Permutations.hs @@ -1,4 +1,5 @@ -- Copyright (C) 2002-2003 David Roundy +-- Copyright (C) 2009 Ganesh Sittampalam -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -27,11 +28,14 @@ partitionFL, partitionRL, head_permutationsFL, head_permutationsRL, headPermutationsFL, - remove_subsequenceFL, remove_subsequenceRL ) where + remove_subsequenceFL, remove_subsequenceRL, + partitionConflictingFL, + CommuteFn, selfCommuter, commuterIdRL, + ) where import Data.Maybe ( catMaybes ) import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL ) -import Darcs.Ordered +import Darcs.Witnesses.Ordered #include "impossible.h" -- |split an 'FL' into "left" and "right" lists according to a predicate, using commutation as necessary. @@ -230,3 +234,37 @@ sloppyIdentity NilRL = IsEq sloppyIdentity (x:<:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs sloppyIdentity _ = NotEq + +-- |CommuteFn is the basis of a general framework for building up commutation +-- operations between different patch types in a generic manner. Unfortunately +-- type classes are not well suited to the problem because of the multiple possible +-- routes by which the commuter for (FL p1, FL p2) can be built out of the +-- commuter for (p1, p2) - and more complicated problems when we start building +-- multiple constructors on top of each other. The type class resolution machinery +-- really can't cope with selecting some route, because it doesn't know that all +-- possible routes should be equivalent. +type CommuteFn p1 p2 = FORALL(x y) (p1 :> p2) C(x y) -> Maybe ((p2 :> p1) C(x y)) + +-- |Build a commuter between a patch and itself using the operation from the type class. +selfCommuter :: Commute p => CommuteFn p p +selfCommuter = commute + +commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2) +commuterIdRL _ (x :> NilRL) = return (NilRL :> x) +commuterIdRL commuter (x :> (y :<: ys)) + = do ys' :> x' <- commuterIdRL commuter (x :> ys) + y' :> x'' <- commuter (x' :> y) + return ((y' :<: ys') :> x'') + +-- |Partition a list into the patches that commute with the given patch and those that don't (including dependencies) +partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 C(x y) -> p2 C(x z) -> (FL p1 :> FL p1) C(x y) +partitionConflictingFL _ NilFL _ = (NilFL :> NilFL) +partitionConflictingFL commuter (x :>: xs) y = + case commuter (invert x :> y) of + Nothing -> case commuteWhatWeCanFL (x :> xs) of + xs_ok :> x' :> xs_deps -> + case partitionConflictingFL commuter xs_ok y of + xs_clean :> xs_conflicts -> xs_clean :> (xs_conflicts +>+ (x' :>: xs_deps)) + Just (y' :> _) -> + case partitionConflictingFL commuter xs y' of + xs_clean :> xs_conflicts -> (x :>: xs_clean) :> xs_conflicts diff --git a/src/Darcs/Patch/Prim.lhs b/src/Darcs/Patch/Prim.lhs --- a/src/Darcs/Patch/Prim.lhs +++ b/src/Darcs/Patch/Prim.lhs @@ -26,15 +26,15 @@ ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim, DirPatchType(..), FilePatchType(..), CommuteFunction, Perhaps(..), - null_patch, nullP, is_null_patch, + null_patch, nullP, isNullPatch, is_identity, formatFileName, FileNameFormat(..), adddir, addfile, binary, changepref, hunk, move, rmdir, rmfile, tokreplace, - is_addfile, is_hunk, is_binary, is_setpref, - is_similar, is_adddir, is_filepatch, - canonize, try_to_shrink, modernizePrim, - subcommutes, sort_coalesceFL, join, + primIsAddfile, primIsHunk, primIsBinary, primIsSetpref, + isSimilar, primIsAdddir, is_filepatch, + canonize, tryToShrink, modernizePrim, + subcommutes, sortCoalesceFL, join, canonizeFL, try_tok_internal, try_shrinking_inverse, n_fn, @@ -56,14 +56,14 @@ import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path, movedirfilename, encode_white ) -import Darcs.Ordered -import Darcs.Sealed ( Sealed, unseal ) -import Darcs.Patch.Patchy ( Invert(..), Commute(..) ) +import Darcs.Witnesses.Ordered +import Darcs.Witnesses.Sealed ( Sealed, unseal ) +import Darcs.Patch.Patchy ( Invert(..), Commute(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Permutations () -- for Invert instance of FL -import Darcs.Show +import Darcs.Witnesses.Show import Darcs.Utils ( nubsort ) import Lcs ( getChanges ) -import RegChars ( regChars ) +import Darcs.Patch.RegChars ( regChars ) import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), lineColor, text, userchunk, invisibleText, invisiblePS, blueText, ($$), (<+>), (<>), prefix, userchunkPS, @@ -97,11 +97,11 @@ null_patch :: Prim C(x x) null_patch = Identity -is_null_patch :: Prim C(x y) -> Bool -is_null_patch (FP _ (Binary x y)) = B.null x && B.null y -is_null_patch (FP _ (Hunk _ [] [])) = True -is_null_patch Identity = True -is_null_patch _ = False +isNullPatch :: Prim C(x y) -> Bool +isNullPatch (FP _ (Binary x y)) = B.null x && B.null y +isNullPatch (FP _ (Hunk _ [] [])) = True +isNullPatch Identity = True +isNullPatch _ = False nullP :: Prim C(x y) -> EqCheck C(x y) nullP = sloppyIdentity @@ -119,30 +119,30 @@ -- | Tells you if two patches are in the same category, human-wise. -- Currently just returns true if they are filepatches on the same -- file. -is_similar :: Prim C(x y) -> Prim C(a b) -> Bool -is_similar (FP f _) (FP f' _) = f == f' -is_similar (DP f _) (DP f' _) = f == f' -is_similar _ _ = False +isSimilar :: Prim C(x y) -> Prim C(a b) -> Bool +isSimilar (FP f _) (FP f' _) = f == f' +isSimilar (DP f _) (DP f' _) = f == f' +isSimilar _ _ = False -is_addfile :: Prim C(x y) -> Bool -is_addfile (FP _ AddFile) = True -is_addfile _ = False +primIsAddfile :: Prim C(x y) -> Bool +primIsAddfile (FP _ AddFile) = True +primIsAddfile _ = False -is_adddir :: Prim C(x y) -> Bool -is_adddir (DP _ AddDir) = True -is_adddir _ = False +primIsAdddir :: Prim C(x y) -> Bool +primIsAdddir (DP _ AddDir) = True +primIsAdddir _ = False -is_hunk :: Prim C(x y) -> Bool -is_hunk (FP _ (Hunk _ _ _)) = True -is_hunk _ = False +primIsHunk :: Prim C(x y) -> Bool +primIsHunk (FP _ (Hunk _ _ _)) = True +primIsHunk _ = False -is_binary :: Prim C(x y) -> Bool -is_binary (FP _ (Binary _ _)) = True -is_binary _ = False +primIsBinary :: Prim C(x y) -> Bool +primIsBinary (FP _ (Binary _ _)) = True +primIsBinary _ = False -is_setpref :: Prim C(x y) -> Bool -is_setpref (ChangePref _ _ _) = True -is_setpref _ = False +primIsSetpref :: Prim C(x y) -> Bool +primIsSetpref (ChangePref _ _ _) = True +primIsSetpref _ = False addfile :: FilePath -> Prim C(x y) rmfile :: FilePath -> Prim C(x y) @@ -406,19 +406,19 @@ toPerhaps $ cs (patches :< patch) >>= sc where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y)) cs (NilFL :< p1) = return (p1 :< NilFL) - cs (p:>:ps :< p1) = do p1' :< p' <- commutex (p :< p1) + cs (p:>:ps :< p1) = do p' :> p1' <- commute (p1 :> p) p1'' :< ps' <- cs (ps :< p1') return (p1'' :< p':>:ps') sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y)) - sc (p1 :< ps) = scFL $ p1 :< (sort_coalesceFL ps) + sc (p1 :< ps) = scFL $ p1 :< (sortCoalesceFL ps) where scFL :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y)) scFL (p1' :< (p :>: NilFL)) = return (p1' :< p) scFL (p1' :< ps') = return (p1' :< Split ps') commute_split _ = Unknown -try_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) -try_to_shrink = mapPrimFL try_harder_to_shrink +tryToShrink :: FL Prim C(x y) -> FL Prim C(x y) +tryToShrink = mapPrimFL try_harder_to_shrink mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y)) -> FL Prim C(w z) -> FL Prim C(w z) @@ -462,7 +462,7 @@ try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y) try_to_shrink2 psold = - let ps = sort_coalesceFL psold + let ps = sortCoalesceFL psold ps_shrunk = shrink_a_bit ps in if lengthFL ps_shrunk < lengthFL ps @@ -492,17 +492,33 @@ try_one sofar p (p1:>:ps) = case coalesce (p1 :< p) of Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps) - Nothing -> case commutex (p1 :< p) of + Nothing -> case commute (p :> p1) of Nothing -> Nothing - Just (p' :< p1') -> try_one (p1':<:sofar) p' ps + Just (p1' :> p') -> try_one (p1':<:sofar) p' ps --- | 'sort_coalesceFL' @ps@ coalesces as many patches in @ps@ as +-- | 'canonizeFL' @ps@ puts a sequence of primitive patches into +-- canonical form. Even if the patches are just hunk patches, +-- this is not necessarily the same set of results as you would get +-- if you applied the sequence to a specific tree and recalculated +-- a diff. +-- +-- Note that this process does not preserve the commutation behaviour +-- of the patches and is therefore not appropriate for use when +-- working with already recorded patches (unless doing amend-record +-- or the like). +canonizeFL :: FL Prim C(x y) -> FL Prim C(x y) +-- Running canonize twice is apparently necessary to fix issue525; +-- would be nice to understand why. +canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL . + concatFL . mapFL_FL canonize + +-- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as -- possible, sorting the results according to the scheme defined -- in 'comparePrim' -sort_coalesceFL :: FL Prim C(x y) -> FL Prim C(x y) -sort_coalesceFL = mapPrimFL sort_coalesceFL2 +sortCoalesceFL :: FL Prim C(x y) -> FL Prim C(x y) +sortCoalesceFL = mapPrimFL sort_coalesceFL2 --- | The heart of "sort_coalesceFL" +-- | The heart of "sortCoalesceFL" sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y) sort_coalesceFL2 NilFL = NilFL sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs @@ -535,8 +551,8 @@ Just new' | IsEq <- nullP new' -> Right ps' | otherwise -> Right $ either id id $ push_coalesce_patch new' ps' Nothing -> if comparePrim new p == LT then Left (new:>:ps) - else case commutex (p :< new) of - Just (new' :< p') -> + else case commute (new :> p) of + Just (p' :> new') -> case push_coalesce_patch new' ps' of Right r -> Right $ either id id $ push_coalesce_patch p' r @@ -628,20 +644,29 @@ instance Commute Prim where merge (y :\/: z) = - case elegant_merge (y:\/:z) of + case elegantMerge (y:\/:z) of Just (z' :/\: y') -> z' :/\: y' Nothing -> error "Commute Prim merge" - commutex x = toMaybe $ msum [speedy_commute x, - everything_else_commute x - ] + commute x = toMaybe $ msum [toFwdCommute speedy_commute x, + toFwdCommute everything_else_commute x + ] -- Recurse on everything, these are potentially spoofed patches - list_touched_files (Move f1 f2) = map fn2fp [f1, f2] - list_touched_files (Split ps) = nubsort $ concat $ mapFL list_touched_files ps - list_touched_files (FP f _) = [fn2fp f] - list_touched_files (DP d _) = [fn2fp d] - list_touched_files (ChangePref _ _ _) = [] - list_touched_files Identity = [] + listTouchedFiles (Move f1 f2) = map fn2fp [f1, f2] + listTouchedFiles (Split ps) = nubsort $ concat $ mapFL listTouchedFiles ps + listTouchedFiles (FP f _) = [fn2fp f] + listTouchedFiles (DP d _) = [fn2fp d] + listTouchedFiles (ChangePref _ _ _) = [] + listTouchedFiles Identity = [] + hunkMatches f (FP _ (Hunk _ remove add)) = anyMatches remove || anyMatches add + where anyMatches = foldr ((||) . f) False + hunkMatches _ (FP _ _) = False + hunkMatches f (Split ps) = or $ mapFL (hunkMatches f) ps + hunkMatches _ (DP _ _) = False + hunkMatches _ (ChangePref _ _ _) = False + hunkMatches _ Identity = False + hunkMatches _ (Move _ _) = False + is_filepatch :: Prim C(x y) -> Maybe FileName is_filepatch (FP f _) = Just f is_filepatch _ = Nothing @@ -690,12 +715,12 @@ [("speedy_commute", speedy_commute), ("commute_filedir", clever_commute commute_filedir), ("commute_filepatches", clever_commute commute_filepatches), - ("commutex", toPerhaps . commutex) + ("commutex", toPerhaps . toRevCommute commute) ] -elegant_merge :: (Prim :\/: Prim) C(x y) +elegantMerge :: (Prim :\/: Prim) C(x y) -> Maybe ((Prim :/\: Prim) C(x y)) -elegant_merge (p1 :\/: p2) = +elegantMerge (p1 :\/: p2) = do p1':>ip2' <- commute (invert p2 :> p1) -- The following should be a redundant check p1o:>_ <- commute (p2 :> p1') @@ -711,7 +736,7 @@ old and new version of a file. \begin{code} canonize :: Prim C(x y) -> FL Prim C(x y) -canonize (Split ps) = sort_coalesceFL ps +canonize (Split ps) = sortCoalesceFL ps canonize p | IsEq <- is_identity p = NilFL canonize (FP f (Hunk line old new)) = canonizeHunk f line old new canonize p = p :>: NilFL @@ -998,11 +1023,11 @@ joinPatches = concatRL . reverseFL class (Invert p, Commute p, Effect p) => Conflict p where - list_conflicted_files :: p C(x y) -> [FilePath] - list_conflicted_files p = - nubsort $ concatMap (unseal list_touched_files) $ concat $ resolve_conflicts p - resolve_conflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]] - resolve_conflicts _ = [] + listConflictedFiles :: p C(x y) -> [FilePath] + listConflictedFiles p = + nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p + resolveConflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]] + resolveConflicts _ = [] -- | If 'commute_no_conflicts' @x :> y@ succeeds, we know that that @x@ commutes -- past @y@ without any conflicts. This function is useful for patch types -- for which 'commute' is defined to always succeed; so we need some way to @@ -1045,14 +1070,14 @@ IsEq <- return $ ix'' =\/= invert x' return (y':>x') conflictedEffect :: p C(x y) -> [IsConflictedPrim] - conflictedEffect x = case list_conflicted_files x of + conflictedEffect x = case listConflictedFiles x of [] -> mapFL (IsC Okay) $ effect x _ -> mapFL (IsC Conflicted) $ effect x instance Conflict p => Conflict (FL p) where - list_conflicted_files = nubsort . concat . mapFL list_conflicted_files - resolve_conflicts NilFL = [] - resolve_conflicts x = resolve_conflicts $ reverseFL x + listConflictedFiles = nubsort . concat . mapFL listConflictedFiles + resolveConflicts NilFL = [] + resolveConflicts x = resolveConflicts $ reverseFL x commute_no_conflicts (NilFL :> x) = Just (x :> NilFL) commute_no_conflicts (x :> NilFL) = Just (NilFL :> x) commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys) @@ -1060,13 +1085,13 @@ conflictedEffect = concat . mapFL conflictedEffect instance Conflict p => Conflict (RL p) where - list_conflicted_files = nubsort . concat . mapRL list_conflicted_files - resolve_conflicts x = rcs x NilFL + listConflictedFiles = nubsort . concat . mapRL listConflictedFiles + resolveConflicts x = rcs x NilFL where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]] rcs NilRL _ = [] - rcs (p:<:ps) passedby | (_:_) <- resolve_conflicts p = + rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p = case commute_no_conflictsFL (p:>passedby) of - Just (_:> p') -> resolve_conflicts p' ++ rcs ps (p:>:passedby) + Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby) Nothing -> rcs ps (p:>:passedby) rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby) commute_no_conflicts (NilRL :> x) = Just (x :> NilRL) @@ -1096,7 +1121,7 @@ | otherwise = p :>: NilFL effectRL p | IsEq <- sloppyIdentity p = NilRL | otherwise = p :<: NilRL - isHunk p = if is_hunk p then Just p else Nothing + isHunk p = if primIsHunk p then Just p else Nothing instance Conflict Prim diff --git a/src/Darcs/Patch/Properties.lhs b/src/Darcs/Patch/Properties.lhs --- a/src/Darcs/Patch/Properties.lhs +++ b/src/Darcs/Patch/Properties.lhs @@ -42,13 +42,13 @@ join_inverses, join_commute ) where import Control.Monad ( msum, mplus ) -import Darcs.Show ( Show2(..) ) +import Darcs.Witnesses.Show ( Show2(..) ) import Darcs.Patch.Patchy import Darcs.Patch.Prim import Darcs.Patch () import Darcs.Patch.Read ( readPatch ) -import Darcs.Ordered -import Darcs.Sealed ( Sealed(Sealed) ) +import Darcs.Witnesses.Ordered +import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) import Printer ( Doc, renderPS, redText, greenText, ($$) ) --import Darcs.ColorPrinter ( traceDoc ) \end{code} diff --git a/src/Darcs/Patch/Read.hs b/src/Darcs/Patch/Read.hs --- a/src/Darcs/Patch/Read.hs +++ b/src/Darcs/Patch/Read.hs @@ -44,8 +44,8 @@ parse_strictly, peek_input, lex_string, lex_eof, my_lex) #include "impossible.h" import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL ) -import Darcs.Ordered ( FL(..) ) -import Darcs.Sealed ( Sealed(..), seal, mapSeal ) +import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal ) readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString) readPatch ps = case parse_strictly (readPatch' False) ps of @@ -60,10 +60,10 @@ _ -> return Nothing instance ReadPatch Prim where - readPatch' w = readPrim OldFormat w + readPatch' _ = readPrim OldFormat -readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x )))) -readPrim x _ +readPrim :: ParserM m => FileNameFormat -> m (Maybe (Sealed (Prim C(x )))) +readPrim x = do s <- peek_input case liftM (BC.unpack . fst) $ my_lex s of Just "{}" -> do work my_lex @@ -95,7 +95,7 @@ read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x ))) read_patches x str want_eof - = do mp <- readPrim x False + = do mp <- readPrim x case mp of Nothing -> do unit <- lex_string str case unit of diff --git a/src/Darcs/Patch/Real.hs b/src/Darcs/Patch/Real.hs --- a/src/Darcs/Patch/Real.hs +++ b/src/Darcs/Patch/Real.hs @@ -33,7 +33,7 @@ IsConflictedPrim(..), ConflictState(..) ) import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Patchy -import Darcs.Ordered +import Darcs.Witnesses.Ordered --import Darcs.Patch.Read () --import Darcs.Patch.Viewing () --import Darcs.Patch.Apply () @@ -45,11 +45,11 @@ import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL, genCommuteWhatWeCanRL, removeRL, removeFL, remove_subsequenceFL ) -import qualified Data.ByteString.Char8 as BC ( unpack ) -import Darcs.Patch.ReadMonads (work, peek_input, my_lex ) +import qualified Data.ByteString.Char8 as BC ( ByteString, unpack ) +import Darcs.Patch.ReadMonads ( work, peek_input, my_lex ) import Darcs.Utils ( nubsort ) -import Darcs.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal ) -import Darcs.Show +import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal ) +import Darcs.Witnesses.Show import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) ) import Darcs.ColorPrinter ( errorDoc, assertDoc ) --import Printer ( greenText ) @@ -291,7 +291,7 @@ conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x] conflictedEffect (InvConflictor _ _ _) = impossible conflictedEffect (Normal x) = [IsC Okay x] - resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled] + resolveConflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled] where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx) nonxx = nonxx_ (nonxx_aux ix xx) nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y) @@ -303,7 +303,7 @@ isn :: Sealed (FL p C(x)) -> Bool isn (Sealed NilFL) = False isn _ = True - resolve_conflicts _ = [] + resolveConflicts _ = [] -- cA commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x) @@ -406,8 +406,11 @@ where nix = Normal $ invert x nonTouches :: Non RealPatch C(x) -> [FilePath] -nonTouches (Non c x) = list_touched_files (c +>+ fromPrim x :>: NilFL) +nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL) +nonHunkMatches :: (BC.ByteString -> Bool) -> Non RealPatch C(x) -> Bool +nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x + toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)] toNons xs = map lastNon $ initsFL xs where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x) @@ -592,14 +595,20 @@ Nothing -> impossible pullInContext fromNons -- merge _ = error "haven't finished fixing merge" - list_touched_files (Duplicate p) = nonTouches p - list_touched_files (Etacilpud p) = nonTouches p - list_touched_files (Normal p) = list_touched_files p - list_touched_files (Conflictor x c p) = - nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p - list_touched_files (InvConflictor x c p) = - nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p + 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] + {- all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)] -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) @@ -714,11 +723,11 @@ showPatch cs $$ blueText "]" $$ showNon p - showContextPatch s (Normal p) = showContextPatch s p - showContextPatch _ c = showPatch c + showContextPatch (Normal p) = showContextPatch p + showContextPatch c = return $ showPatch c instance ReadPatch RealPatch where - readPatch' want_eof = + readPatch' _ = do s <- peek_input case fmap (BC.unpack . fst) $ my_lex s of Just "duplicate" -> @@ -744,7 +753,7 @@ Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') Just p <- readNon return $ Just $ Sealed $ InvConflictor i ps p - _ -> do mp <- readPrim NewFormat want_eof + _ -> do mp <- readPrim NewFormat case mp of Just p -> return $ Just $ Normal `mapSeal` p Nothing -> return Nothing diff --git a/src/Darcs/Patch/RegChars.hs b/src/Darcs/Patch/RegChars.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/RegChars.hs @@ -0,0 +1,75 @@ +-- Copyright (C) 2003 David Roundy +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + + +module Darcs.Patch.RegChars ( regChars, + ) where + +(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(&&&) a b c = a c && b c + +(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(|||) a b c = a c || b c + +{-# INLINE regChars #-} + +-- | 'regChars' returns a filter function that tells if a char is a member +-- of the regChar expression or not. The regChar expression is basically a +-- set of chars, but it can contain ranges with use of the '-' (dash), and +-- it can also be specified as a complement set by prefixing with '^' +-- (caret). The dash and caret, as well as the backslash, can all be +-- escaped with a backslash to suppress their special meaning. +-- +-- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning +-- if it is not escaped, but the default 'filename_toks' in +-- Darcs.Commands.Replace uses an escaped dot (WHY?). + +regChars :: String -> (Char -> Bool) +regChars ('^':cs) = not . normalRegChars (unescapeChars cs) +regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs +regChars cs = normalRegChars $ unescapeChars cs + +{-# INLINE unescapeChars #-} + +-- | 'unescapeChars' unescapes whitespace, which is escaped in the replace +-- patch file format. It will also unescape escaped carets, which is useful +-- for escaping a leading caret that should not invert the regChars. All +-- other escapes are left for the unescaping in 'normalRegChars'. + +unescapeChars :: String -> String +unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs +unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs +unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs +unescapeChars (c:cs) = c : unescapeChars cs +unescapeChars [] = [] + +{-# INLINE normalRegChars #-} + +-- | 'normalRegChars' assembles the filter function. It handles special +-- chars, and also unescaping of escaped special chars. If a non-special +-- char is still escaped by now we get a failure. + +normalRegChars :: String -> (Char -> Bool) +normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs +normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs +normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs +normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported." +normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs +normalRegChars (c:cs) = (== c) ||| normalRegChars cs +normalRegChars [] = \_ -> False + + 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 @@ -23,8 +23,8 @@ module Darcs.Patch.Set ( PatchSet, SealedPatchSet ) where import Darcs.Hopefully ( PatchInfoAnd ) -import Darcs.Ordered ( RL ) -import Darcs.Sealed ( Sealed ) +import Darcs.Witnesses.Ordered ( RL ) +import Darcs.Witnesses.Sealed ( Sealed ) -- | A PatchSet is in reverse order, plus has information about which -- tags are clean, meaning all patches applied prior to them are in diff --git a/src/Darcs/Patch/Show.lhs b/src/Darcs/Patch/Show.lhs --- a/src/Darcs/Patch/Show.lhs +++ b/src/Darcs/Patch/Show.lhs @@ -31,7 +31,7 @@ import Darcs.Patch.Core ( Patch(..) ) import Darcs.Patch.Prim ( showPrim, FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo ) -import Darcs.Ordered ( FL(NilFL), mapFL ) +import Darcs.Witnesses.Ordered ( FL(NilFL), mapFL ) #include "gadts.h" \end{code} diff --git a/src/Darcs/Patch/Split.hs b/src/Darcs/Patch/Split.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Split.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE CPP, RankNTypes, GADTs #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- Copyright (C) 2009 Ganesh Sittampalam +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, copy, +-- modify, merge, publish, distribute, sublicense, and/or sell copies +-- of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +-- SOFTWARE. + +module Darcs.Patch.Split ( Splitter(..), rawSplitter, noSplitter, primSplitter ) where + +import Data.List ( intersperse ) + +import Darcs.Witnesses.Ordered +import Darcs.Witnesses.Sealed + +import Darcs.Patch.Patchy ( ReadPatch(..), ShowPatch(..), Invert(..) ) +import Darcs.Patch.Prim ( Prim(..), FilePatchType(..), canonize, canonizeFL ) +import Darcs.Patch.ReadMonads ( parse_strictly ) +import Darcs.Patch.Read () +import Darcs.Patch.Viewing () + +import Printer ( renderPS ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +#include "gadts.h" + +-- |A splitter is something that can take a patch and (possibly) render it +-- as text in some format of its own choosing. +-- This text can then be presented to the user for editing, and the result +-- given to the splitter for parsing. +-- If the parse succeeds, the result is a list of patches that could replace +-- the original patch in any context. +-- Typically this list will contain the changed version of the patch, along +-- with fixup pieces to ensure that the overall effect of the list is the same +-- as the original patch. +-- The individual elements of the list can then be offered separately to the +-- user, allowing them to accept some and reject others. +-- +-- There's no immediate application for a splitter for anything other than +-- Prim (you shouldn't go editing named patches, you'll break them!) +-- However you might want to compose splitters for FilePatchType to make +-- splitters for Prim etc, and the generality doesn't cost anything. +data Splitter p + = Splitter { + applySplitter :: FORALL(x y) p C(x y) + -> Maybe (B.ByteString, + B.ByteString -> Maybe (FL p C(x y))) + -- canonization is needed to undo the effects of splitting + -- Typically, the list returned by applySplitter will not + -- be in the simplest possible form (since the user will have + -- deliberately added extra stuff). Once the user has selected + -- the pieces they want, we need to make sure that we eliminate + -- any remaining redundancy in the selected pieces, otherwise + -- we might record (or whatever) a rather strange looking patch. + -- This hook allows the splitter to provide an appropriate + -- function for doing this. + ,canonizeSplit :: FORALL(x y) FL p C(x y) -> FL p C(x y) + } + +{- Some facts that probably ought to be true about splitters: should make some QC +properties + +applySplitter p = Just (bs, f) ==> f bs == Just (p :>: NilFL) + +applySplitter p = Just (bs, f) ; f bs' = Just ps ==> canonizeSplit ps = p :>: NilFL + +-} + +-- Does not canonize as there is no generic operation to do this. +withEditedHead :: Invert p => p C(x y) -> p C(x z) -> FL p C(x y) +withEditedHead p res = res :>: invert res :>: p :>: NilFL + +-- |This generic splitter just lets the user edit the printed representation of the patch +-- Should not be used expect for testing and experimentation. +rawSplitter :: (ShowPatch p, ReadPatch p, Invert p) => Splitter p +rawSplitter = Splitter { + applySplitter = + \p -> Just (renderPS . showPatch $ p, + \str -> case parse_strictly (readPatch' False) str of + Just (Just (Sealed res), _) -> Just (withEditedHead p res) + _ -> Nothing + ) + ,canonizeSplit = id + } + +-- |Never splits. In other code we normally pass around Maybe Splitter instead of using this +-- as the default, because it saves clients that don't care about splitting from having to +-- import this module just to get noSplitter. +noSplitter :: Splitter p +noSplitter = Splitter { applySplitter = const Nothing, canonizeSplit = id } + + +doPrimSplit :: Prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL Prim C(x y))) +doPrimSplit (FP fn (Hunk n before after)) + = Just (B.concat $ intersperse (BC.pack "\n") $ concat + [ helptext + , [mkSep " BEFORE (reference) =========================="] + , before + , [mkSep "=== AFTER (edit) ============================="] + , after + , [mkSep "=== (edit above) ============================="] + ], + \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)) + where sep = BC.pack "==========================" + helptext = map BC.pack [ "Interactive hunk edit:" + , " - Edit the section marked 'AFTER'" + , " - Arbitrary editing is supported" + , " - This will only affect the patch, not your working copy" + , " - Hints:" + , " - To split added text, delete the part you want to postpone" + , " - To split removed text, copy back the part you want to retain" + , "" + ] + hunk b a = canonize (FP fn (Hunk n b a)) + mkSep s = BC.append sep (BC.pack s) + breakSep xs = case break (sep `BC.isPrefixOf`) xs of + (_, []) -> Nothing + (ys, _:zs) -> Just (ys, zs) +doPrimSplit _ = Nothing + +-- |Split a primitive hunk patch up +-- by allowing the user to edit both the before and after lines, then insert fixup patches +-- to clean up the mess. +primSplitter :: Splitter Prim +primSplitter = Splitter { applySplitter = doPrimSplit, canonizeSplit = canonizeFL } 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,67 +24,69 @@ select_touching, deselect_not_touching, select_not_touching, ) where -import Data.List ( sort ) +import Data.List ( sort, isSuffixOf ) import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch, - patch_choices, tag, get_choices, - force_firsts, force_lasts, tp_patch, + patchChoices, tag, getChoices, + forceFirsts, forceLasts, tpPatch, ) -import Darcs.Patch ( Patchy, apply_to_filepaths, list_touched_files ) -import Darcs.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) -import Darcs.Sealed ( Sealed, seal ) +import Darcs.Patch ( Patchy, applyToFilepaths, listTouchedFiles ) +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) +import Darcs.Witnesses.Sealed ( Sealed, seal ) select_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) select_touching [] pc = pc -select_touching files pc = force_firsts xs pc +select_touching files pc = forceFirsts xs pc where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] ct _ NilFL = [] - ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of + ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of (True, fs') -> tag tp:ct fs' tps (False, fs') -> ct fs' tps - xs = case get_choices pc of + xs = case getChoices pc of _ :> mc :> lc -> ct (map fix files) (mc +>+ lc) deselect_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) deselect_not_touching [] pc = pc -deselect_not_touching files pc = force_lasts xs pc +deselect_not_touching files pc = forceLasts xs pc where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] ct _ NilFL = [] - ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of + ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of (True, fs') -> ct fs' tps (False, fs') -> tag tp:ct fs' tps - xs = case get_choices pc of + xs = case getChoices pc of fc :> mc :> _ -> ct (map fix files) (fc +>+ mc) select_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) select_not_touching [] pc = pc -select_not_touching files pc = force_firsts xs pc +select_not_touching files pc = forceFirsts xs pc where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] ct _ NilFL = [] - ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of + ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of (True, fs') -> ct fs' tps (False, fs') -> tag tp:ct fs' tps - xs = case get_choices pc of + xs = case getChoices pc of fc :> mc :> _ -> ct (map fix files) (fc +>+ mc) fix :: FilePath -> FilePath -fix f | take 1 (reverse f) == "/" = fix $ reverse $ drop 1 $ reverse f +fix f | "/" `isSuffixOf` f = fix $ init f fix "" = "." fix "." = "." fix f = "./" ++ f choose_touching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x)) choose_touching [] p = seal p -choose_touching files p = case get_choices $ select_touching files $ patch_choices p of - fc :> _ :> _ -> seal $ mapFL_FL tp_patch fc +choose_touching files p = case getChoices $ select_touching files $ patchChoices p of + fc :> _ :> _ -> seal $ mapFL_FL tpPatch fc look_touch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath]) -look_touch fs p = (any (\tf -> any (affects tf) fs) (list_touched_files p) +look_touch fs p = (any (\tf -> any (affects tf) fs) (listTouchedFiles p) || fs' /= fs, fs') - where affects touched f | touched == f = True - affects t f = case splitAt (length f) t of - (t', '/':_) -> t' == f - _ -> case splitAt (length t) f of - (f', '/':_) -> f' == t - _ -> False - fs' = sort $ apply_to_filepaths p fs + where affects :: FilePath -> FilePath -> Bool + affects touched 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 + _ -> False + fs' = sort $ applyToFilepaths p fs diff --git a/src/Darcs/Patch/Viewing.hs b/src/Darcs/Patch/Viewing.hs --- a/src/Darcs/Patch/Viewing.hs +++ b/src/Darcs/Patch/Viewing.hs @@ -18,17 +18,19 @@ {-# OPTIONS_GHC -cpp -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -module Darcs.Patch.Viewing ( xml_summary, summarize ) +module Darcs.Patch.Viewing ( xmlSummary, plainSummary ) where -import Prelude hiding ( pi ) -import Control.Monad ( liftM ) -import Data.List ( sort ) +import Prelude hiding ( pi, readFile ) +import Control.Monad.State.Strict ( gets ) +import Control.Monad.Trans ( liftIO ) -import Darcs.SlurpDirectory ( Slurpy, get_slurp, get_filecontents ) +import Storage.Hashed.Monad( TreeIO, fileExists, readFile, tree, virtualTreeIO ) +import Storage.Hashed.AnchoredPath( floatPath ) import ByteStringUtils (linesPS ) -import qualified Data.ByteString as B (null) -import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp ) +import qualified Data.ByteString as BS (null, concat) +import qualified Data.ByteString.Lazy as BL (toChunks) +import Darcs.Patch.FileName ( FileName, fn2fp ) import Printer ( Doc, empty, vcat, text, blueText, Color(Cyan,Magenta), lineColor, minus, plus, ($$), (<+>), (<>), @@ -37,69 +39,76 @@ ) import Darcs.Patch.Core ( Patch(..), Named(..), patchcontents ) -import Darcs.Patch.Prim ( Prim(..), is_hunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..), +import Darcs.Patch.Prim ( Prim(..), primIsHunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..), Effect, IsConflictedPrim(IsC), ConflictState(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity ) import Darcs.Patch.Show ( showPatch_, showNamedPrefix ) import Darcs.Patch.Info ( showPatchInfo, human_friendly ) -import Darcs.Patch.Apply ( apply_to_slurpy ) +import Darcs.Patch.Apply ( applyToTree ) #include "impossible.h" #include "gadts.h" -import Darcs.Ordered ( RL(..), FL(..), +import Darcs.Witnesses.Ordered ( RL(..), FL(..), mapFL, mapFL_FL, reverseRL ) instance ShowPatch Prim where showPatch = showPrim OldFormat - showContextPatch s p@(FP _ (Hunk _ _ _)) = showContextHunk s (PP p) - showContextPatch s (Split ps) = - blueText "(" $$ showContextSeries s (mapFL_FL PP ps) - <> blueText ")" - showContextPatch _ p = showPatch p - summary = gen_summary False . (:[]) . IsC Okay + showContextPatch p@(FP _ (Hunk _ _ _)) = showContextHunk (PP p) + showContextPatch (Split ps) = + do x <- showContextSeries (mapFL_FL PP ps) + return $ blueText "(" $$ x <> blueText ")" + showContextPatch p = return $ showPatch p + summary = vcat . map summChunkToLine . genSummary . (:[]) . IsC Okay thing _ = "change" -summarize :: (Conflict e, Effect e) => e C(x y) -> Doc -summarize = gen_summary False . conflictedEffect +plainSummary :: (Conflict e, Effect e) => e C(x y) -> Doc +plainSummary = vcat . map summChunkToLine . genSummary . conflictedEffect instance ShowPatch Patch where showPatch = showPatch_ - showContextPatch s (PP x) | is_hunk x = showContextHunk s (PP x) - showContextPatch _ (ComP NilFL) = blueText "{" $$ blueText "}" - showContextPatch s (ComP ps) = blueText "{" $$ showContextSeries s ps - $$ blueText "}" - showContextPatch _ p = showPatch p - summary = summarize + showContextPatch (PP x) | primIsHunk x = showContextHunk (PP x) + showContextPatch (ComP NilFL) = return $ blueText "{" $$ blueText "}" + showContextPatch (ComP ps) = + do x <- showContextSeries ps + return $ blueText "{" $$ x $$ blueText "}" + showContextPatch p = return $ showPatch p + summary = plainSummary thing _ = "change" -showContextSeries :: (Apply p, ShowPatch p, Effect p) => Slurpy -> FL p C(x y) -> Doc -showContextSeries slur patches = scs slur identity patches - where scs :: (Apply p, ShowPatch p, Effect p) => Slurpy -> Prim C(w x) -> FL p C(x y) -> Doc - scs s pold (p:>:ps) = - case isHunk p of - Nothing -> showContextPatch s p $$ scs s' identity ps +showContextSeries :: (Apply p, ShowPatch p, Effect p) => FL p C(x y) -> TreeIO Doc +showContextSeries patches = scs identity patches + where scs :: (Apply p, ShowPatch p, Effect p) => Prim C(w x) -> FL p C(x y) -> TreeIO Doc + scs pold (p:>:ps) = do + s' <- gets tree >>= liftIO . applyToTree p + case isHunk p of + Nothing -> do a <- showContextPatch p + b <- liftIO $ virtualTreeIO (scs identity ps) s' + return $ a $$ fst b Just hp -> case ps of - NilFL -> coolContextHunk s pold hp identity + NilFL -> coolContextHunk pold hp identity (p2:>:_) -> case isHunk p2 of - Nothing -> coolContextHunk s pold hp identity $$ scs s' hp ps - Just hp2 -> coolContextHunk s pold hp hp2 $$ - scs s' hp ps - where s' = - fromJust $ apply_to_slurpy p s - scs _ _ NilFL = empty + Nothing -> do a <- coolContextHunk pold hp identity + b <- liftIO $ virtualTreeIO (scs hp ps) s' + return $ a $$ fst b + Just hp2 -> do a <- coolContextHunk pold hp hp2 + b <- liftIO $ virtualTreeIO (scs hp ps) s' + return $ a $$ fst b + scs _ NilFL = return empty -showContextHunk :: (Apply p, ShowPatch p, Effect p) => Slurpy -> p C(x y) -> Doc -showContextHunk s p = case isHunk p of - Just h -> coolContextHunk s identity h identity - Nothing -> showPatch p +showContextHunk :: (Apply p, ShowPatch p, Effect p) => p C(x y) -> TreeIO Doc +showContextHunk p = case isHunk p of + Just h -> coolContextHunk identity h identity + Nothing -> return $ showPatch p -coolContextHunk :: Slurpy -> Prim C(a b) -> Prim C(b c) - -> Prim C(c d) -> Doc -coolContextHunk s prev p@(FP f (Hunk l o n)) next = - case (linesPS . get_filecontents) `liftM` get_slurp f s of - Nothing -> showPatch p -- This is a weird error... +coolContextHunk :: Prim C(a b) -> Prim C(b c) -> Prim C(c d) -> TreeIO Doc +coolContextHunk prev p@(FP f (Hunk l o n)) next = do + let path = floatPath $ fn2fp f + have <- fileExists path + content <- if have then Just `fmap` readFile path else return Nothing + case (linesPS . BS.concat . BL.toChunks) `fmap` content of -- sigh + Nothing -> return $ showPatch p -- This is a weird error... Just ls -> let numpre = case prev of (FP f' (Hunk lprev _ nprev)) @@ -116,19 +125,19 @@ lnext - (l+length n) _ -> 3 cleanedls = case reverse ls of - (x:xs) | B.null x -> reverse xs + (x:xs) | BS.null x -> reverse xs _ -> ls post = take numpost $ drop (max 0 $ l+length o-1) cleanedls - in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l) + in return $ blueText "hunk" <+> formatFileName OldFormat f <+> text (show l) $$ prefix " " (vcat $ map userchunkPS pre) $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o)) $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS n)) $$ prefix " " (vcat $ map userchunkPS post) -coolContextHunk _ _ _ _ = impossible +coolContextHunk _ _ _ = impossible -xml_summary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc -xml_summary p = text "" - $$ gen_summary True (conflictedEffect $ patchcontents p) +xmlSummary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc +xmlSummary p = text "" + $$ (vcat . map summChunkToXML . genSummary . conflictedEffect . patchcontents $ p) $$ text "" -- Yuck duplicated code below... @@ -143,165 +152,124 @@ | otherwise = z : (strReplace x y zs) -- end yuck duplicated code. -gen_summary :: Bool -> [IsConflictedPrim] -> Doc -gen_summary use_xml p - = vcat themoves - $$ vcat themods - where themods = map summ $ combine $ sort $ concatMap s2 p - s2 :: IsConflictedPrim -> [(FileName, Int, Int, Int, Bool, ConflictState)] - s2 (IsC c x) = map (append56 c) $ s x - s :: Prim C(x y) -> [(FileName, Int, Int, Int, Bool)] - s (FP f (Hunk _ o n)) = [(f, length o, length n, 0, False)] - s (FP f (Binary _ _)) = [(f, 0, 0, 0, False)] - s (FP f AddFile) = [(f, -1, 0, 0, False)] - s (FP f RmFile) = [(f, 0, -1, 0, False)] - s (FP f (TokReplace _ _ _)) = [(f, 0, 0, 1, False)] - s (DP d AddDir) = [(d, -1, 0, 0, True)] - s (DP d RmDir) = [(d, 0, -1, 0, True)] +-- | High-level representation of a piece of patch summary +data SummChunk = SummChunk SummDetail ConflictState + deriving (Ord, Eq) + +data SummDetail = SummAddDir FileName + | SummRmDir FileName + | SummFile SummOp FileName Int Int Int + | SummMv FileName FileName + | SummNone + deriving (Ord, Eq) + +data SummOp = SummAdd | SummRm | SummMod deriving (Ord, Eq) + +genSummary :: [IsConflictedPrim] -> [SummChunk] +genSummary p + = combine $ concatMap s2 p + where s2 :: IsConflictedPrim -> [SummChunk] + s2 (IsC c x) = map (\d -> SummChunk d c) $ s x + s :: Prim C(x y) -> [SummDetail] + s (FP f (Hunk _ o n)) = [SummFile SummMod f (length o) (length n) 0] + s (FP f (Binary _ _)) = [SummFile SummMod f 0 0 0] + s (FP f AddFile) = [SummFile SummAdd f 0 0 0] + s (FP f RmFile) = [SummFile SummRm f 0 0 0] + s (FP f (TokReplace _ _ _)) = [SummFile SummMod f 0 0 1] + s (DP d AddDir) = [SummAddDir d] + s (DP d RmDir) = [SummRmDir d] s (Split xs) = concat $ mapFL s xs - s (Move _ _) = [(fp2fn "", 0, 0, 0, False)] - s (ChangePref _ _ _) = [(fp2fn "", 0, 0, 0, False)] - s Identity = [(fp2fn "", 0, 0, 0, False)] - append56 f (a,b,c,d,e) = (a,b,c,d,e,f) - (-1) .+ _ = -1 - _ .+ (-1) = -1 - a .+ b = a + b - combine ((f,a,b,r,isd,c):(f',a',b',r',_,c'):ss) - -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs - -- allows a single patch to add and remove the same file, see issue 185 - | f == f' && (a /= -1 || b' /= -1) && (a' /= -1 || b /= -1) = - combine ((f,a.+a',b.+b',r+r',isd,combineConflitStates c c'):ss) - combine ((f,a,b,r,isd,c):ss) = (f,a,b,r,isd,c) : combine ss + s (Move f1 f2) = [SummMv f1 f2] + s (ChangePref _ _ _) = [SummNone] + s Identity = [SummNone] + combine (x1@(SummChunk d1 c1) : x2@(SummChunk d2 c2) : ss) + = case combineDetail d1 d2 of + Nothing -> x1 : combine (x2:ss) + Just d3 -> combine $ SummChunk d3 (combineConflitStates c1 c2) : ss + combine (x:ss) = x : combine ss combine [] = [] + -- + combineDetail (SummFile o1 f1 r1 a1 x1) (SummFile o2 f2 r2 a2 x2) | f1 == f2 = + do o3 <- combineOp o1 o2 + return $ SummFile o3 f1 (r1 + r2) (a1 + a2) (x1 + x2) + combineDetail _ _ = Nothing + -- combineConflitStates Conflicted _ = Conflicted combineConflitStates _ Conflicted = Conflicted combineConflitStates Duplicated _ = Duplicated combineConflitStates _ Duplicated = Duplicated combineConflitStates Okay Okay = Okay + -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs + -- allows a single patch to add and remove the same file, see issue 185 + combineOp SummAdd SummRm = Nothing + combineOp SummRm SummAdd = Nothing + combineOp SummAdd _ = Just SummAdd + combineOp _ SummAdd = Just SummAdd + combineOp SummRm _ = Just SummRm + combineOp _ SummRm = Just SummRm + combineOp SummMod SummMod = Just SummMod - summ (f,_,-1,_,False,Okay) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "R" <+> text (fn2fp f) - summ (f,_,-1,_,False,Conflicted) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "R!" <+> text (fn2fp f) - summ (f,_,-1,_,False,Duplicated) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "R" <+> text (fn2fp f) <+> text "(duplicate)" - summ (f,-1,_,_,False,Okay) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "A" <+> text (fn2fp f) - summ (f,-1,_,_,False,Conflicted) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "A!" <+> text (fn2fp f) - summ (f,-1,_,_,False,Duplicated) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "A" <+> text (fn2fp f) <+> text "(duplicate)" - summ (f,0,0,0,False,Okay) | f == fp2fn "" = empty - summ (f,0,0,0,False,Conflicted) | f == fp2fn "" - = if use_xml then empty -- don't know what to do here... - else text "!" <+> text (fn2fp f) - summ (f,0,0,0,False,Duplicated) | f == fp2fn "" - = if use_xml then empty -- don't know what to do here... - else text (fn2fp f) <+> text "(duplicate)" - summ (f,a,b,r,False,Okay) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - <> xrm a <> xad b <> xrp r - $$ text "" - else text "M" <+> text (fn2fp f) - <+> rm a <+> ad b <+> rp r - summ (f,a,b,r,False,Conflicted) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - <> xrm a <> xad b <> xrp r - $$ text "" - else text "M!" <+> text (fn2fp f) - <+> rm a <+> ad b <+> rp r - summ (f,a,b,r,False,Duplicated) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - <> xrm a <> xad b <> xrp r - $$ text "" - else text "M" <+> text (fn2fp f) - <+> rm a <+> ad b <+> rp r <+> text "(duplicate)" - summ (f,_,-1,_,True,Okay) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "R" <+> text (fn2fp f) <> text "/" - summ (f,_,-1,_,True,Conflicted) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "R!" <+> text (fn2fp f) <> text "/" - summ (f,_,-1,_,True,Duplicated) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "R" <+> text (fn2fp f) <> text "/ (duplicate)" - summ (f,-1,_,_,True,Okay) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "A" <+> text (fn2fp f) <> text "/" - summ (f,-1,_,_,True,Conflicted) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "A!" <+> text (fn2fp f) <> text "/" - summ (f,-1,_,_,True,Duplicated) - = if use_xml then text "" - $$ escapeXML (drop_dotslash $ fn2fp f) - $$ text "" - else text "A!" <+> text (fn2fp f) <> text "/ (duplicate)" - summ _ = empty - ad 0 = empty - ad a = plus <> text (show a) - xad 0 = empty - xad a = text "" - rm 0 = empty - rm a = minus <> text (show a) - xrm 0 = empty - xrm a = text "" - rp 0 = empty - rp a = text "r" <> text (show a) - xrp 0 = empty - xrp a = text "" - drop_dotslash ('.':'/':str) = drop_dotslash str - drop_dotslash str = str - themoves :: [Doc] - themoves = map showmoves p - showmoves :: IsConflictedPrim -> Doc - showmoves (IsC _ (Move a b)) - = if use_xml - then text " escapeXML (drop_dotslash $ fn2fp a) <> text "\" to=\"" - <> escapeXML (drop_dotslash $ fn2fp b) <> text"\"/>" - else text " " <> text (fn2fp a) - <> text " -> " <> text (fn2fp b) - showmoves _ = empty +summChunkToXML :: SummChunk -> Doc +summChunkToXML (SummChunk detail c) = + case detail of + SummRmDir f -> xconf c "remove_directory" (xfn f) + SummAddDir f -> xconf c "add_directory" (xfn f) + SummFile SummRm f _ _ _ -> xconf c "remove_file" (xfn f) + SummFile SummAdd f _ _ _ -> xconf c "add_file" (xfn f) + SummFile SummMod f r a x -> xconf c "modify_file" $ xfn f <> xrm r <> xad a <> xrp x + SummMv f1 f2 -> text " xfn f1 + <> text "\" to=\"" <> xfn f2 <> text"\"/>" + SummNone -> empty + where + xconf Okay t x = text ('<':t++">") $$ x $$ text ("") + xconf Conflicted t x = text ('<':t++" conflict='true'>") $$ x $$ text ("") + xconf Duplicated t x = text ('<':t++" duplicate='true'>") $$ x $$ text ("") + xfn = escapeXML . dropDotSlash .fn2fp + -- + xad 0 = empty + xad a = text "" + xrm 0 = empty + xrm a = text "" + xrp 0 = empty + xrp a = text "" +summChunkToLine :: SummChunk -> Doc +summChunkToLine (SummChunk detail c) = + case detail of + SummRmDir f -> lconf c "R" $ text (fn2fp f) <> text "/" + SummAddDir f -> lconf c "A" $ text (fn2fp f) <> text "/" + SummFile SummRm f _ _ _ -> lconf c "R" $ text (fn2fp f) + SummFile SummAdd f _ _ _ -> lconf c "A" $ text (fn2fp f) + SummFile SummMod f r a x -> lconf c "M" $ text (fn2fp f) <+> rm r <+> ad a <+> rp x + SummMv f1 f2 -> text " " <> text (fn2fp f1) + <> text " -> " <> text (fn2fp f2) + SummNone -> case c of + Okay -> empty + _ -> lconf c "" empty + where + lconf Okay t x = text t <+> x + lconf Conflicted t x = text (t ++ "!") <+> x + lconf Duplicated t x = text t <+> x <+> text "duplicate" + -- + ad 0 = empty + ad a = plus <> text (show a) + rm 0 = empty + rm a = minus <> text (show a) + rp 0 = empty + rp a = text "r" <> text (show a) + +dropDotSlash :: FilePath -> FilePath +dropDotSlash ('.':'/':str) = dropDotSlash str +dropDotSlash str = str + instance (Conflict p, ShowPatch p) => ShowPatch (Named p) where showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p - showContextPatch s (NamedP n [] p) = showPatchInfo n <> showContextPatch s p - showContextPatch s (NamedP n d p) = showNamedPrefix n d <+> showContextPatch s p + showContextPatch (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>) + showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>) description (NamedP n _ _) = human_friendly n summary p = description p $$ text "" $$ - prefix " " (summarize p) -- this isn't summary because summary does the + prefix " " (plainSummary p) -- this isn't summary because summary does the -- wrong thing with (Named (FL p)) so that it can -- get the summary of a sequence of named patches -- right. @@ -323,7 +291,7 @@ instance (Conflict p, Apply p, ShowPatch p) => ShowPatch (RL p) where showPatch = showPatch . reverseRL - showContextPatch s = showContextPatch s . reverseRL + showContextPatch = showContextPatch . reverseRL description = description . reverseRL summary = summary . reverseRL thing = thing . reverseRL diff --git a/src/Darcs/Population.hs b/src/Darcs/Population.hs --- a/src/Darcs/Population.hs +++ b/src/Darcs/Population.hs @@ -37,10 +37,10 @@ import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path ) import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges, Effect, effect ) -import Darcs.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL ) import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml ) import Darcs.Patch.Set ( PatchSet ) -import Darcs.Sealed ( Sealed(..), seal, unseal ) +import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal ) import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo ) import Darcs.Repository.Pristine ( identifyPristine, getPristinePop ) import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..), diff --git a/src/Darcs/PopulationData.hs b/src/Darcs/PopulationData.hs --- a/src/Darcs/PopulationData.hs +++ b/src/Darcs/PopulationData.hs @@ -103,7 +103,7 @@ then do fnames <- getDirectoryContents dirname sl <- withCurrentDirectory dirname - (sequence $ map getPopFrom_helper $ filter not_hidden fnames) + (mapM getPopFrom_helper $ filter not_hidden fnames) let i = Info {nameI = n, modifiedByI = pinfo, modifiedHowI = DullDir, diff --git a/src/Darcs/PrintPatch.hs b/src/Darcs/PrintPatch.hs --- a/src/Darcs/PrintPatch.hs +++ b/src/Darcs/PrintPatch.hs @@ -24,7 +24,8 @@ printPatchPager, printFriendly ) where import Darcs.Patch ( Patchy, showContextPatch, showPatch ) -import Darcs.SlurpDirectory ( Slurpy ) +import Storage.Hashed.Tree( Tree ) +import Storage.Hashed.Monad( virtualTreeIO ) import Darcs.Arguments ( DarcsFlag, showFriendly ) import Printer ( putDocLnWith ) import Darcs.ColorPrinter ( fancyPrinters ) @@ -46,5 +47,5 @@ -- | 'contextualPrintPatch' prints a patch, together with its context, -- on standard output. -contextualPrintPatch :: Patchy p => Slurpy -> p C(x y) -> IO () -contextualPrintPatch s p = putDocLnWith fancyPrinters $ showContextPatch s p +contextualPrintPatch :: Patchy p => Tree IO -> p C(x y) -> IO () +contextualPrintPatch s p = virtualTreeIO (showContextPatch p) s >>= putDocLnWith fancyPrinters . fst diff --git a/src/Darcs/ProgressPatches.hs b/src/Darcs/ProgressPatches.hs --- a/src/Darcs/ProgressPatches.hs +++ b/src/Darcs/ProgressPatches.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, GADTs #-} #include "gadts.h" module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags) where -import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthRL, lengthFL ) import Darcs.Hopefully (PatchInfoAnd,info) import System.IO.Unsafe ( unsafePerformIO ) import Progress (minlist, beginTedious, diff --git a/src/Darcs/RemoteApply.hs b/src/Darcs/RemoteApply.hs --- a/src/Darcs/RemoteApply.hs +++ b/src/Darcs/RemoteApply.hs @@ -20,7 +20,7 @@ then apply_via_url opts repodir bundle else apply_via_local opts repodir bundle Just un -> if is_ssh repodir - then apply_via_ssh_and_sudo repodir un bundle + then apply_via_ssh_and_sudo opts repodir un bundle else apply_via_sudo un repodir bundle apply_as :: [DarcsFlag] -> Maybe String @@ -29,10 +29,12 @@ apply_as [] = Nothing apply_via_sudo :: String -> String -> Doc -> IO ExitCode apply_via_sudo user repo bundle = - pipeDoc "sudo" ["-u",user,"darcs","apply","--all","--repodir",repo] bundle + darcs_program >>= \darcs -> + pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle apply_via_local :: [DarcsFlag] -> String -> Doc -> IO ExitCode apply_via_local opts repo bundle = - pipeDoc "darcs" ("apply":"--all":"--repodir":repo:applyopts opts) bundle + darcs_program >>= \darcs -> + pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle apply_via_url :: [DarcsFlag] -> String -> Doc -> IO ExitCode apply_via_url opts repo bundle = @@ -45,13 +47,14 @@ apply_via_ssh :: [DarcsFlag] -> String -> Doc -> IO ExitCode apply_via_ssh opts repo bundle = - pipeDocSSH addr ["darcs apply --all "++unwords (applyopts opts)++" --repodir '"++path++"'"] bundle + pipeDocSSH addr [remoteDarcsCmd opts++" apply --all "++unwords (applyopts opts)++ + " --repodir '"++path++"'"] bundle where (addr,':':path) = break (==':') repo -apply_via_ssh_and_sudo :: String -> String -> Doc -> IO ExitCode -apply_via_ssh_and_sudo repo username bundle = - pipeDocSSH addr ["sudo -u "++username++ - " darcs apply --all --repodir '"++path++"'"] bundle +apply_via_ssh_and_sudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode +apply_via_ssh_and_sudo opts repo username bundle = + pipeDocSSH addr ["sudo -u "++username++" "++remoteDarcsCmd opts++ + " apply --all --repodir '"++path++"'"] bundle where (addr,':':path) = break (==':') repo applyopts :: [DarcsFlag] -> [String] diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -21,56 +21,47 @@ #include "gadts.h" -module Darcs.Repository ( Repository, ($-), maybeIdentifyRepository, - identifyRepositoryFor, - withRepoLock, withRepoReadLock, - withRepository, withRepositoryDirectory, withGutsOf, - makePatchLazy, writePatchSet, - findRepository, amInRepository, amNotInRepository, - slurp_pending, replacePristineFromSlurpy, - slurp_recorded, slurp_recorded_and_unrecorded, - withRecorded, - get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, - get_unrecorded_in_files, get_unrecorded_in_files_unsorted, - read_repo, sync_repo, - prefsUrl, - add_to_pending, - tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, - tentativelyReplacePatches, - tentativelyMergePatches, considerMergeToWorking, - revertRepositoryChanges, finalizeRepositoryChanges, - createRepository, copyRepository, copy_oldrepo_patches, - patchSetToRepository, - unrevertUrl, - applyToWorking, patchSetToPatches, - createPristineDirectoryTree, createPartialsPristineDirectoryTree, - optimizeInventory, cleanRepository, - checkPristineAgainstSlurpy, getMarkedupFile, - PatchSet, SealedPatchSet, PatchInfoAnd, - setScriptsExecutable, - checkUnrelatedRepos, - testTentative, testRecorded - ) where +module Darcs.Repository + ( Repository, ($-), maybeIdentifyRepository, identifyRepositoryFor + , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory + , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository + , amNotInRepository, slurp_pending, replacePristine, slurp_recorded + , slurp_recorded_and_unrecorded, withRecorded, read_repo, prefsUrl + , add_to_pending, tentativelyAddPatch, tentativelyRemovePatches + , tentativelyAddToPending, tentativelyReplacePatches + , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges + , finalizeRepositoryChanges, createRepository, copyRepository + , copy_oldrepo_patches, patchSetToRepository, unrevertUrl, applyToWorking + , patchSetToPatches, createPristineDirectoryTree + , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository + , getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd + , setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded + -- * Recorded and unrecorded and pending. + , readRecorded, readUnrecorded, unrecordedChanges, readPending, pendingChanges + , readRecordedAndPending + -- * Index. + , readIndex, invalidateIndex + ) where import System.Exit ( ExitCode(..), exitWith ) +import Darcs.Repository.State( readRecorded, readUnrecorded, unrecordedChanges + , readPending, pendingChanges, readIndex, invalidateIndex + , readRecordedAndPending ) + import Darcs.Repository.Internal - (Repository(..), RepoType(..), ($-), pristineFromWorking, + (Repository(..), RepoType(..), ($-), maybeIdentifyRepository, identifyRepositoryFor, findRepository, amInRepository, amNotInRepository, makePatchLazy, - slurp_pending, replacePristineFromSlurpy, + slurp_pending, slurp_recorded, slurp_recorded_and_unrecorded, withRecorded, - get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, - get_unrecorded_in_files, get_unrecorded_in_files_unsorted, - read_repo, sync_repo, - prefsUrl, checkPristineAgainstSlurpy, - add_to_pending, + read_repo, + prefsUrl, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, tentativelyReplacePatches, - tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges, finalizeRepositoryChanges, unrevertUrl, applyToWorking, patchSetToPatches, @@ -78,14 +69,16 @@ optimizeInventory, cleanRepository, getMarkedupFile, setScriptsExecutable, - testTentative, testRecorded + testTentative, testRecorded, + make_new_pending ) +import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking ) import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) import Control.Monad ( unless, when ) import Data.Either(Either(..)) -import System.Directory ( createDirectory ) +import System.Directory ( createDirectory, renameDirectory ) import System.IO.Error ( isAlreadyExistsError ) import qualified Darcs.Repository.DarcsRepo as DarcsRepo @@ -94,30 +87,40 @@ import Darcs.Hopefully ( PatchInfoAnd, info, extractHash ) import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint ) import Darcs.Repository.ApplyPatches ( apply_patches ) -import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine ) -import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply ) -import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL, - concatRL, lengthRL, isShorterThanRL ) +import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine, pris2inv ) +import Darcs.Repository.InternalTypes ( Pristine(..) ) +import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL + , reverseRL ,concatRL, lengthRL, isShorterThanRL, (+>+) ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), - create_repo_format, format_has, writeRepoFormat ) -import Darcs.Repository.Prefs ( write_default_prefs ) -import Darcs.Repository.Pristine ( createPristine, flagsToPristine ) + createRepoFormat, formatHas, writeRepoFormat ) +import Darcs.Repository.Prefs ( writeDefaultPrefs ) +import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking ) import Darcs.Patch.Depends ( get_patches_beyond_tag ) -import Darcs.SlurpDirectory ( empty_slurpy ) import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError ) import Darcs.External ( copyFileOrUrl, Cachable(..) ) import Progress ( debugMessage, tediousSize, beginTedious, endTedious, progress ) import Darcs.ProgressPatches (progressRLShowTags, progressFL) -import Darcs.Lock ( writeBinFile ) -import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped ) +import Darcs.Lock ( writeBinFile, writeDocBinFile, rm_recursive ) +import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped ) -import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, - AllowUnrelatedRepos - ), - compression ) +import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, Complete, + AllowUnrelatedRepos, NoUpdateWorking ) + , compression ) import Darcs.Global ( darcsdir ) + +import Storage.Hashed.Tree( Tree, emptyTree ) +import Storage.Hashed.Hash( encodeBase16 ) +import Storage.Hashed.Darcs( writeDarcsHashed ) +import Storage.Hashed( writePlainTree ) +import ByteStringUtils( gzReadFilePS ) + +import System.FilePath( () ) + +import qualified Data.ByteString.Char8 as BS + #include "impossible.h" createRepository :: [DarcsFlag] -> IO () @@ -126,19 +129,19 @@ (\e-> if isAlreadyExistsError e then fail "Tree has already been initialized!" else fail $ "Error creating directory `"++darcsdir++"'.") - let rf = create_repo_format opts + let rf = createRepoFormat opts createPristine $ flagsToPristine opts rf createDirectory $ darcsdir ++ "/patches" createDirectory $ darcsdir ++ "/prefs" - write_default_prefs + writeDefaultPrefs writeRepoFormat rf (darcsdir++"/format") - if format_has HashedInventory rf + if formatHas HashedInventory rf then writeBinFile (darcsdir++"/hashed_inventory") "" else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK! copyRepository :: RepoPatch p => Repository p C(r u t) -> IO () copyRepository fromrepository@(Repo _ opts rf _) - | Partial `elem` opts && not (format_has HashedInventory rf) = + | Partial `elem` opts && not (formatHas HashedInventory rf) = do isPartial <- copyPartialRepository fromrepository unless (isPartial == IsPartial) $ copyFullRepository fromrepository | otherwise = copyFullRepository fromrepository @@ -156,11 +159,11 @@ copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>= DarcsRepo.write_inventory_and_patches opts - repoSort rfx | format_has HashedInventory rfx = Hashed + repoSort rfx | formatHas HashedInventory rfx = Hashed | otherwise = Old case repoSort rf2 of Hashed -> - if format_has HashedInventory rf + if formatHas HashedInventory rf then copyHashedHashed else withCurrentDirectory todir $ do HashedRepo.revert_tentative_changes @@ -207,7 +210,7 @@ local_patches <- read_repo torepository let pi_ch = patch2patchinfo ch FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches - let needed_patches = reverseRL $ concatRL ps + let needed_patches = reverseRL ps apply opts ch `catch` \e -> fail ("Bad checkpoint!\n" ++ prettyError e) apply_patches opts needed_patches @@ -223,15 +226,15 @@ `catchall` return () debugMessage "Grabbing lock in new repository..." withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) -> - if format_has HashedInventory rffrom && format_has HashedInventory rfto + if formatHas HashedInventory rffrom && formatHas HashedInventory rfto then do debugMessage "Writing working directory contents..." createPristineDirectoryTree torepository "." fetch_patches_if_necessary opts torepository when (Partial `elem` opts) $ putStrLn $ "--partial: hashed or darcs-2 repository detected, using --lazy instead" - else if format_has HashedInventory rfto + else if formatHas HashedInventory rfto then do local_patches <- read_repo torepository - replacePristineFromSlurpy torepository empty_slurpy + replacePristine torepository emptyTree let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $ mapRL_RL reverseRL local_patches sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply @@ -252,7 +255,7 @@ Right r -> r Left e -> bug ("Current directory not repository in writePatchSet: " ++ e) debugMessage "Writing inventory" - if format_has HashedInventory rf2 + if formatHas HashedInventory rf2 then do HashedRepo.write_tentative_inventory c (compression opts) patchset HashedRepo.finalize_tentative_changes repo (compression opts) else DarcsRepo.write_inventory_and_patches opts patchset @@ -266,7 +269,7 @@ patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t)) patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do - when (format_has HashedInventory rf) $ -- set up sources and all that + when (formatHas HashedInventory rf) $ -- set up sources and all that do writeFile "_darcs/tentative_pristine" "" -- this is hokey repox <- writePatchSet patchset opts HashedRepo.copy_repo repox opts fromrepo @@ -276,7 +279,7 @@ pristineFromWorking repo return repo -checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(x) -> IO () +checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(y) -> IO () checkUnrelatedRepos opts common us them | AllowUnrelatedRepos `elem` opts || not (null common) || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5 @@ -292,7 +295,8 @@ fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO () fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) = unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $ - do putInfo "Copying patches, to get lazy repository hit ctrl-C..." + do unless (Complete `elem` opts) $ + putInfo "Copying patches, to get lazy repository hit ctrl-C..." r <- read_repo torepository let peekaboo :: PatchInfoAnd p C(x y) -> IO () peekaboo x = case extractHash x of @@ -300,3 +304,37 @@ Right h -> fetchFileUsingCache c HashedPatchesDir h >> return () sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r where putInfo = when (not $ Quiet `elem` opts) . putStrLn + +add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO () +add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +add_to_pending repo@(Repo _ opts _ _) p = + do pend <- unrecordedChanges opts repo [] + invalidateIndex repo + make_new_pending repo (pend +>+ p) + +-- | Replace the existing pristine with a new one (loaded up in a Tree object). +replacePristine :: Repository p C(r u t) -> Tree IO -> IO () +replacePristine (Repo r _opts _rf (DarcsRepository pris _c)) tree = + withCurrentDirectory r $ replace pris + where replace HashedPristine = + do let t = "_darcs" "hashed_inventory" + i <- gzReadFilePS t + root <- writeDarcsHashed tree $ "_darcs" "pristine.hashed" + writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i + replace (PlainPristine n) = + do rm_recursive nold `catchall` return () + writePlainTree tree ntmp + renameDirectory n nold + renameDirectory ntmp n + return () + replace (NoPristine _) = return () + nold = darcsdir "pristine-old" + ntmp = darcsdir "pristine-tmp" + +pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO () +pristineFromWorking repo@(Repo dir _ rf _) + | formatHas HashedInventory rf = + withCurrentDirectory dir $ readUnrecorded repo >>= replacePristine repo +pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) = + withCurrentDirectory dir $ createPristineFromWorking p + diff --git a/src/Darcs/Repository/ApplyPatches.hs b/src/Darcs/Repository/ApplyPatches.hs --- a/src/Darcs/Repository/ApplyPatches.hs +++ b/src/Darcs/Repository/ApplyPatches.hs @@ -25,7 +25,7 @@ import Darcs.Patch ( Patchy, apply ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) import Darcs.Patch.Info ( human_friendly ) -import Darcs.Ordered ( FL(..), lengthFL, mapFL ) +import Darcs.Witnesses.Ordered ( FL(..), lengthFL, mapFL ) import Darcs.Flags ( DarcsFlag ) import Darcs.Utils ( putDocLnError ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) 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 @@ -9,7 +9,7 @@ HashedDir(..), hashedDir, unionCaches, cleanCaches, cleanCachesWithHint, fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache, - findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache, + peekInCache, repo2cache, writable, isthisrepo, hashedFilePath, allHashedDirs ) where @@ -18,9 +18,7 @@ import Data.List ( nub ) import Data.Maybe ( listToMaybe ) import System.Directory ( removeFile, doesFileExist, getDirectoryContents ) -import System.Posix ( setFileTimes ) -import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus ) -import System.Posix.Types ( EpochTime ) +import System.Posix.Files ( linkCount, getSymbolicLinkStatus ) import System.IO ( hPutStrLn, stderr ) import Crypt.SHA256 ( sha256sum ) @@ -39,7 +37,6 @@ import Darcs.Global ( darcsdir ) import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS ) import Progress ( progressList, debugMessage, debugFail ) -import Darcs.SlurpDirectory ( undefined_time ) import Darcs.URL ( is_file ) import Darcs.Utils ( withCurrentDirectory, catchall ) @@ -97,21 +94,6 @@ | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h | otherwise = False - -findFileMtimeUsingCache :: Cache -> HashedDir -> String -> IO EpochTime -findFileMtimeUsingCache (Ca cache) subdir f = mt cache - where mt [] = return undefined_time - mt (Cache Repo Writable r:_) = (modificationTime `fmap` - getSymbolicLinkStatus (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f)) - `catchall` return undefined_time - mt (_:cs) = mt cs - -setFileMtimeUsingCache :: Cache -> HashedDir -> String -> EpochTime -> IO () -setFileMtimeUsingCache (Ca cache) subdir f t = st cache - where st [] = return () - st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f) t t - `catchall` return () - st (_:cs) = st cs fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString) fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere diff --git a/src/Darcs/Repository/Checkpoint.hs b/src/Darcs/Repository/Checkpoint.hs --- a/src/Darcs/Repository/Checkpoint.hs +++ b/src/Darcs/Repository/Checkpoint.hs @@ -22,45 +22,31 @@ module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default, identify_checkpoint, - write_checkpoint, write_recorded_checkpoint, write_checkpoint_patch, ) where -import System.Directory ( setCurrentDirectory, createDirectoryIfMissing ) -import Workaround ( getCurrentDirectory ) +import System.Directory ( createDirectoryIfMissing ) import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.Maybe ( listToMaybe, catMaybes ) -import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import Darcs.Hopefully ( PatchInfoAnd, info ) import qualified Data.ByteString as B ( null, empty, ByteString ) -import Darcs.Lock ( withTempDir, writeDocBinFile ) -import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, ) -import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo, - apply_to_slurpy, patchcontents, - effect, fromPrims, - is_setpref, infopatch, - readPatch, - gzWritePatch - ) -import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq), - (+>+), filterFL, unsafeCoerceP, - mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL ) -import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded ) -import Darcs.Repository.ApplyPatches ( apply_patches ) +import Darcs.Lock ( writeDocBinFile ) +import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) +import Darcs.Patch ( RepoPatch, Patch, Named, patch2patchinfo, + applyToSlurpy, readPatch, gzWritePatch ) +import Darcs.Witnesses.Ordered ( RL(..), FL(..), mapRL, reverseRL ) +import Darcs.Repository.Internal ( Repository(..), read_repo ) import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, showPatchInfo ) -import Darcs.Diff ( unsafeDiff ) import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) ) -import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) ) -import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag ) -import Darcs.Repository.Prefs ( filetype_function ) +import Darcs.Flags ( DarcsFlag( Partial, Complete ) ) import Darcs.Utils ( catchall ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.Global ( darcsdir ) import Printer ( Doc, ($$), empty ) -#include "impossible.h" -import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(Sealed2), seal, seal2 ) import Control.Monad ( liftM ) read_patch_ids :: B.ByteString -> [PatchInfo] @@ -83,7 +69,7 @@ (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of Nothing -> return Nothing - Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy + Just (Sealed p) -> return $ applyToSlurpy p empty_slurpy get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts @@ -126,36 +112,6 @@ format_inv (pinfo:ps) = showPatchInfo pinfo $$ format_inv ps -write_recorded_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO () -write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do - Sealed ps <- (seal . mapFL_FL hopefully.reverseRL.concatRL) `liftM` read_repo r - ftf <- filetype_function - s <- slurp_recorded r - write_checkpoint_patch $ infopatch pinfo - (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y)) - where changeps = filterFL is_setprefFL . - effect . patchcontents - changepps = concatFL . mapFL_FL changeps - -is_setprefFL :: Prim C(x y) -> EqCheck C(x y) -is_setprefFL p | is_setpref p = NotEq - | otherwise = unsafeCoerceP IsEq - -write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO () -write_checkpoint repo@(Repo _ _ _ _) pinfo = do - repodir <- getCurrentDirectory - Sealed pit <- get_patches_in_tag pinfo `liftM` read_repo repo - let ps = (reverseRL.mapRL_RL hopefully.concatRL) pit - ftf <- filetype_function - with_tag repo pinfo $ do - s <- mmap_slurp "." - setCurrentDirectory repodir - write_checkpoint_patch $ infopatch pinfo $ - (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y)) - where changeps = filterFL is_setprefFL . - effect . patchcontents - changepps = concatFL . mapFL_FL changeps - write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO () write_checkpoint_patch p = do createDirectoryIfMissing False (darcsdir++"/checkpoints") @@ -163,12 +119,3 @@ cpi <- (map fst) `fmap` read_checkpoints "." writeDocBinFile (darcsdir++"/checkpoints/inventory") $ format_inv $ reverse $ patch2patchinfo p:cpi - -with_tag :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> (IO ()) -> IO () -with_tag r pinfo job = do - ps <- read_repo r - case get_patches_beyond_tag pinfo ps of - FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do - apply_patches [] $ invertRL extras - job - _ -> bug "with_tag" diff --git a/src/Darcs/Repository/DarcsRepo.lhs b/src/Darcs/Repository/DarcsRepo.lhs --- a/src/Darcs/Repository/DarcsRepo.lhs +++ b/src/Darcs/Repository/DarcsRepo.lhs @@ -61,7 +61,7 @@ import System.Directory ( doesDirectoryExist, createDirectoryIfMissing ) import Workaround ( renameFile ) -import Darcs.Utils ( clarify_errors ) +import Darcs.Utils ( clarifyErrors ) import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr ) @@ -80,10 +80,10 @@ import Darcs.Patch ( RepoPatch, Effect, Prim, Named, Patch, invert, effect, patch2patchinfo, - apply_to_slurpy, + applyToSlurpy, readPatch, writePatch, gzWritePatch, showPatch ) -import Darcs.Ordered ( FL(..), RL(..), (:<)(..), +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:<)(..), reverseFL, mapFL, unsafeCoerceP, reverseRL, concatRL, mapRL, mapRL_RL ) import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, @@ -100,7 +100,7 @@ import Darcs.Utils ( catchall ) import Darcs.ProgressPatches ( progressFL ) import Printer ( text, (<>), Doc, ($$), empty ) -import Darcs.Sealed ( Sealed(Sealed), seal, unseal ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal ) \end{code} There is a very special patch which may be stored in \verb!patches! which @@ -221,7 +221,7 @@ Nothing -> seal $ NilFL repairable :: IO a -> IO a -repairable x = x `clarify_errors` unlines +repairable x = x `clarifyErrors` unlines ["Your repository is now in an inconsistent state.", "This must be fixed by running darcs repair."] @@ -315,7 +315,7 @@ (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable case fst `liftM` readPatch_ pstr of Nothing -> return Nothing - Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy + Just (Sealed p) -> return $ applyToSlurpy p empty_slurpy readPatch_ :: B.ByteString -> Maybe (Sealed (Named Patch C(x)), B.ByteString) readPatch_ = readPatch diff --git a/src/Darcs/Repository/Format.hs b/src/Darcs/Repository/Format.hs --- a/src/Darcs/Repository/Format.hs +++ b/src/Darcs/Repository/Format.hs @@ -6,9 +6,9 @@ {-# LANGUAGE CPP #-} module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat, - create_repo_format, writeRepoFormat, - write_problem, read_problem, readfrom_and_writeto_problem, - format_has, format_has_together, + createRepoFormat, writeRepoFormat, + writeProblem, readProblem, readfromAndWritetoProblem, + formatHas, formatHasTogether, ) where import Data.List ( sort ) @@ -56,9 +56,9 @@ then do finishedOneIO k "inventory" have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory") case have_inventory of - Right _ -> return $ Right default_repo_format + Right _ -> return $ Right defaultRepoFormat Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")" - else return $ Right $ parse_repo_format dff + else return $ Right $ parseRepoFormat dff endTedious k return rf where drfe x = fetchFilePS x Cachable >> return True @@ -70,16 +70,16 @@ writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $ map (BC.unpack . BU.intercalate (BC.singleton '|')) rf -parse_repo_format :: B.ByteString -> RepoFormat -parse_repo_format ps = +parseRepoFormat :: B.ByteString -> RepoFormat +parseRepoFormat ps = RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps -- | The repo format we assume if we do not find a format file. -default_repo_format :: RepoFormat -default_repo_format = RF [[rp2ps Darcs1_0]] +defaultRepoFormat :: RepoFormat +defaultRepoFormat = RF [[rp2ps Darcs1_0]] -create_repo_format :: [DarcsFlag] -> RepoFormat -create_repo_format fs = RF ([map rp2ps flags2inv] ++ maybe2) +createRepoFormat :: [DarcsFlag] -> RepoFormat +createRepoFormat fs = RF ([map rp2ps flags2inv] ++ maybe2) where flags2inv | UseFormat2 `elem` fs = [HashedInventory] | UseHashedInventory `elem` fs = [HashedInventory] | UseOldFashionedInventory `elem` fs = [Darcs1_0] @@ -90,47 +90,47 @@ then [] else [[rp2ps Darcs2]] --- | @write_problem from@ tells if we can write to a repo in format @form@. +-- | @writeProblem from@ tells if we can write to a repo in format @form@. -- it returns @Nothing@ if there's no problem writing to such a repository. -write_problem :: RepoFormat -> Maybe String -write_problem rf | isJust $ read_problem rf = read_problem rf -write_problem (RF ks) = unlines `fmap` justsOrNothing (map wp ks) - where wp x | all is_known x = Nothing +writeProblem :: RepoFormat -> Maybe String +writeProblem rf | isJust $ readProblem rf = readProblem rf +writeProblem (RF ks) = unlines `fmap` justsOrNothing (map wp ks) + where wp x | all isKnown x = Nothing wp [] = impossible wp x = Just $ unwords $ "Can't write repository format: " : - map BC.unpack (filter (not . is_known) x) + map BC.unpack (filter (not . isKnown) x) --- | @write_problem from@ tells if we can read and write to a repo in +-- | @writeProblem from@ tells if we can read and write to a repo in -- format @form@. it returns @Nothing@ if there's no problem reading -- and writing to such a repository. -readfrom_and_writeto_problem :: RepoFormat -> RepoFormat -> Maybe String -readfrom_and_writeto_problem inrf outrf - | format_has Darcs2 inrf /= format_has Darcs2 outrf +readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String +readfromAndWritetoProblem inrf outrf + | formatHas Darcs2 inrf /= formatHas Darcs2 outrf = Just "Cannot mix darcs-2 repositories with older formats" - | otherwise = msum [read_problem inrf, write_problem outrf] + | otherwise = msum [readProblem inrf, writeProblem outrf] --- | @read_problem from@ tells if we can write to a repo in format @form@. +-- | @readProblem from@ tells if we can write to a repo in format @form@. -- it returns @Nothing@ if there's no problem reading from such a repository. -read_problem :: RepoFormat -> Maybe String -read_problem rf | format_has Darcs1_0 rf && format_has Darcs2 rf +readProblem :: RepoFormat -> Maybe String +readProblem rf | formatHas Darcs1_0 rf && formatHas Darcs2 rf = Just "Invalid repositoryformat: format 2 is incompatible with format 1" -read_problem (RF ks) = unlines `fmap` justsOrNothing (map rp ks) - where rp x | any is_known x = Nothing +readProblem (RF ks) = unlines `fmap` justsOrNothing (map rp ks) + where rp x | any isKnown x = Nothing rp [] = impossible rp x = Just $ unwords $ "Can't understand repository format:" : map BC.unpack x -- | Does this version of darcs know how to handle this property? -is_known :: B.ByteString -> Bool -is_known p = p `elem` map rp2ps known_properties +isKnown :: B.ByteString -> Bool +isKnown p = p `elem` map rp2ps knownProperties -- | This is the list of properties which this version of darcs knows -- how to handle. -known_properties :: [RepoProperty] -known_properties = [Darcs1_0, Darcs2, HashedInventory] +knownProperties :: [RepoProperty] +knownProperties = [Darcs1_0, Darcs2, HashedInventory] justsOrNothing :: [Maybe x] -> Maybe [x] justsOrNothing mxs = @@ -138,11 +138,11 @@ [] -> Nothing xs -> Just xs -format_has :: RepoProperty -> RepoFormat -> Bool -format_has f (RF ks) = rp2ps f `elem` concat ks +formatHas :: RepoProperty -> RepoFormat -> Bool +formatHas f (RF ks) = rp2ps f `elem` concat ks -format_has_together :: [RepoProperty] -> RepoFormat -> Bool -format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks +formatHasTogether :: [RepoProperty] -> RepoFormat -> Bool +formatHasTogether fs (RF ks) = fht (sort $ map rp2ps fs) ks where fht _ [] = False fht x (y:ys) | x == sort y = True | otherwise = fht x ys diff --git a/src/Darcs/Repository/HashedIO.hs b/src/Darcs/Repository/HashedIO.hs --- a/src/Darcs/Repository/HashedIO.hs +++ b/src/Darcs/Repository/HashedIO.hs @@ -20,25 +20,24 @@ #include "gadts.h" module Darcs.Repository.HashedIO ( HashedIO, applyHashed, - copyHashed, syncHashedPristine, copyPartialsHashed, listHashedContents, + copyHashed, copyPartialsHashed, listHashedContents, slurpHashedPristine, writeHashedPristine, clean_hashdir ) where import Darcs.Global ( darcsdir ) -import Data.List ( (\\) ) +import qualified Data.Set as Set import qualified Data.Map as Map import System.Directory ( getDirectoryContents, createDirectoryIfMissing ) -import System.Posix.Types ( EpochTime ) import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift ) import Control.Monad ( when ) +import Control.Applicative ( (<$>) ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO ) import Darcs.SlurpDirectory.Internal ( Slurpy(..), SlurpyContents(..), map_to_slurpies, slurpies_to_map ) -import Darcs.SlurpDirectory ( withSlurpy, undefined_time, undefined_size ) +import Darcs.SlurpDirectory ( withSlurpy, undefined_size ) import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache, peekInCache, speculateFileUsingCache, - findFileMtimeUsingCache, setFileMtimeUsingCache, okayHash, cleanCachesWithHint, HashedDir(..), hashedDir ) import Darcs.Patch ( Patchy, apply ) import Darcs.RepoPath ( FilePathLike, toFilePath ) @@ -48,7 +47,7 @@ import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress ) import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn, - break_on_dir, own_name, super_name ) + break_on_dir, own_name, superName ) import ByteStringUtils ( linesPS, unlinesPS ) import qualified Data.ByteString as B (ByteString, length, empty) @@ -111,7 +110,7 @@ Just h -> inh h $ mInCurrentDirectory fn'' j where fn' = norm_path fn mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot - mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do + mReadFilePS fn = mInCurrentDirectory (superName fn) $ do c <- readroot case geta F (own_name fn) c of Nothing -> fail $ " file don't exist... "++ fn2fp fn @@ -170,11 +169,11 @@ where fn' = norm_path fn makeThing :: FileName -> (ObjType,String) -> HashedIO RW p () -makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $ +makeThing fn (o,h) = mWithCurrentDirectory (superName $ norm_path fn) $ seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot rmThing :: FileName -> HashedIO RW p () -rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $ +rmThing fn = mWithCurrentDirectory (superName $ norm_path fn) $ do c <- readroot let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c if length c' == length c - 1 @@ -191,10 +190,6 @@ readTediousHash k h = do lift $ finishedOneIO k h readhash h -gethashmtime :: String -> HashedIO r p EpochTime -gethashmtime h = do HashDir _ c _ _ <- get - lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c HashedPristineDir h - withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a) withh h j = do hd <- get put $ hd { rootHash = h } @@ -286,10 +281,9 @@ lift $ beginTedious k safeInterleave $ (Slurpy rootdir . SlurpDir (Just hroot) . slurpies_to_map) `fmap` mapM sl c where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h - t <- gethashmtime h let len = if length h == 75 then read (take 10 h) else undefined_size - return $ Slurpy n $ SlurpFile (Just h, t, len) ps + return $ Slurpy n $ SlurpFile (Just h, 0, len) ps sl (D,n,h) = inh h $ do c <- readroot lift $ tediousSize k (length c) lift $ finishedOneIO k h @@ -327,33 +321,6 @@ return (F, f, h) k = "Writing pristine" -grab :: FileName -> Slurpy -> Maybe Slurpy -grab _ (Slurpy _ (SlurpFile _ _)) = Nothing -grab fn (Slurpy _ (SlurpDir _ ss)) = fmap (Slurpy fn) $ Map.lookup fn ss - --- | Update timestamps on pristine files to match those in the working directory --- (which is passed to this function in form of a Slurpy). It needed for the --- mtime-based unsafeDiff optimisation to work efficiently. -syncHashedPristine :: Cache -> Slurpy -> String -> IO () -syncHashedPristine c s r = do runStateT sh $ HashDir { permissions=RW, cache=c, - compress=compression [], rootHash=r } - return () - where sh = do cc <- readroot - lift $ tediousSize k (length cc) - mapM_ sh' cc - sh' (D,n,h) = case progress k $ grab n s of - Just s' -> lift $ syncHashedPristine c s' h - Nothing -> return () - sh' (F,n,h) = case progress k $ grab n s of - Just (Slurpy _ (SlurpFile (_,t',l) x)) -> - do t <- lift $ findFileMtimeUsingCache c HashedPristineDir h - when (t' /= undefined_time && t' /= t) $ - do ps <- readhash h - when (B.length ps == fromIntegral l && ps == x) $ - lift $ setFileMtimeUsingCache c HashedPristineDir h t' - _ -> return () - k = "Synchronizing pristine" - copyHashed :: String -> Cache -> Compression -> String -> IO () copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c, compress = compr, rootHash = z } @@ -409,9 +376,11 @@ do -- we'll remove obsolete bits of "dir" debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..." let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/" - hs <- concat `fmap` (mapM (listHashedContents "cleaning up..." c) hashroots) - fs <- filter okayHash `fmap` getDirectoryContents hashdir - mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs) + hs <- set . concat <$> mapM (listHashedContents "cleaning up..." c) hashroots + fs <- set . filter okayHash <$> getDirectoryContents hashdir + mapM_ (removeFileMayNotExist . (hashdir++)) (unset $ fs `Set.difference` hs) -- and also clean out any global caches. debugMessage "Cleaning out any global caches..." - cleanCachesWithHint c dir_ (fs \\ hs) + cleanCachesWithHint c dir_ (unset $ fs `Set.difference` hs) + where set = Set.fromList . map BC.pack + unset = map BC.unpack . Set.toList 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 @@ -20,14 +20,13 @@ #include "gadts.h" module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes, - slurp_pristine, sync_repo, clean_pristine, - copy_pristine, copy_partials_pristine, pristine_from_working, + slurp_pristine, clean_pristine, + copy_pristine, copy_partials_pristine, apply_to_tentative_pristine, - replacePristineFromSlurpy, add_to_tentative_inventory, remove_from_tentative_inventory, read_repo, read_tentative_repo, write_and_read_patch, write_tentative_inventory, copy_repo, slurp_all_but_darcs, - readHashedPristineRoot + readHashedPristineRoot, pris2inv ) where import System.Directory ( doesFileExist, createDirectoryIfMissing ) @@ -45,8 +44,8 @@ unionCaches, repo2cache, okayHash, takeHash, HashedDir(..), hashedDir ) import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine, - copyHashed, syncHashedPristine, copyPartialsHashed, - writeHashedPristine, clean_hashdir ) + copyHashed, copyPartialsHashed, + clean_hashdir ) import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info, extractHash, createHashed ) @@ -54,11 +53,11 @@ import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch ) import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo ) -import Darcs.Ordered ( unsafeCoerceP, (:<)(..) ) +import Darcs.Witnesses.Ordered ( unsafeCoerceP, (:<)(..) ) import Darcs.Patch.FileName ( fp2fn ) import ByteStringUtils ( gzReadFilePS, dropSpace ) -import qualified Data.ByteString as B (null, length, readFile, empty +import qualified Data.ByteString as B (null, length, empty ,tail, take, drop, ByteString) import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack) @@ -69,9 +68,9 @@ import Darcs.Utils ( withCurrentDirectory ) import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) #include "impossible.h" -import Darcs.Ordered ( FL(..), RL(..), +import Darcs.Witnesses.Ordered ( FL(..), RL(..), mapRL, mapFL, lengthRL ) -import Darcs.Sealed ( Sealed(..), seal, unseal ) +import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal ) import Darcs.Global ( darcsdir ) revert_tentative_changes :: IO () @@ -338,18 +337,6 @@ h | h == sha1PS B.empty -> return empty_slurpy | otherwise -> slurpHashedPristine c compr h -pristine_from_working :: Cache -> Compression -> IO () -pristine_from_working c compr = do - s <- slurp_all_but_darcs "." - replacePristineFromSlurpy c compr s - -replacePristineFromSlurpy :: Cache -> Compression -> Slurpy -> IO () -replacePristineFromSlurpy c compr s = do - h <- writeHashedPristine c compr s - let t = darcsdir++"/hashed_inventory" - i <- gzReadFilePS t - writeDocBinFile t $ pris2inv h i - copy_pristine :: Cache -> Compression -> String -> String -> IO () copy_pristine c compr d iname = do i <- fetchFilePS (d++"/"++iname) Uncachable @@ -358,13 +345,6 @@ beginTedious k copyHashed k c compr $ inv2pris i endTedious k - -sync_repo :: Cache -> IO () -sync_repo c = do i <- B.readFile $ darcsdir++"/hashed_inventory" - s <- slurp_all_but_darcs "." - beginTedious "Synchronizing pristine" - syncHashedPristine c s $ inv2pris i - copy_partials_pristine :: FilePathLike fp => Cache -> Compression -> String -> String -> [fp] -> IO () 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 @@ -24,131 +24,122 @@ module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-), maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, findRepository, amInRepository, amNotInRepository, - slurp_pending, pristineFromWorking, revertRepositoryChanges, + slurp_pending, revertRepositoryChanges, slurp_recorded, slurp_recorded_and_unrecorded, - read_pending, announce_merge_conflicts, setTentativePending, + announce_merge_conflicts, setTentativePending, check_unrecorded_conflicts, withRecorded, - checkPristineAgainstSlurpy, - get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, - get_unrecorded_in_files, get_unrecorded_in_files_unsorted, - read_repo, sync_repo, + read_repo, prefsUrl, makePatchLazy, - add_to_pending, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, + tentativelyAddPatch_, tentativelyReplacePatches, - tentativelyMergePatches, considerMergeToWorking, finalizeRepositoryChanges, unrevertUrl, applyToWorking, patchSetToPatches, createPristineDirectoryTree, createPartialsPristineDirectoryTree, - replacePristineFromSlurpy, optimizeInventory, cleanRepository, getMarkedupFile, PatchSet, SealedPatchSet, setScriptsExecutable, getRepository, rIO, - testTentative, testRecorded + testTentative, testRecorded, + UpdatePristine(..), MakeChanges(..), applyToTentativePristine, + make_new_pending ) where import Printer ( putDocLn, (<+>), text, ($$) ) import Data.Maybe ( isJust, isNothing ) -import Darcs.Repository.Prefs ( get_prefval ) -import Darcs.Resolution ( standard_resolution, external_resolution ) +import Darcs.Repository.Prefs ( getPrefval ) +import Darcs.Repository.State ( readRecorded ) +import Darcs.Repository.LowLevel ( read_pending, pendingName, readPrims, read_pendingfile ) import System.Exit ( ExitCode(..), exitWith ) import System.Cmd ( system ) -import Darcs.External ( backupByCopying, clonePartialsTree ) +import Darcs.External ( clonePartialsTree ) import Darcs.IO ( runTolerantly, runSilently ) import Darcs.Repository.Pristine ( identifyPristine, nopristine, - easyCreatePristineDirectoryTree, slurpPristine, syncPristine, - easyCreatePartialsPristineDirectoryTree, - createPristineFromWorking ) -import qualified Darcs.Repository.Pristine as Pristine ( replacePristineFromSlurpy ) - + easyCreatePristineDirectoryTree, slurpPristine, + easyCreatePartialsPristineDirectoryTree ) + import Data.List ( (\\) ) import Darcs.SignalHandler ( withSignalsBlocked ) import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ), - identifyRepoFormat, format_has, - write_problem, read_problem, readfrom_and_writeto_problem ) + identifyRepoFormat, formatHas, + writeProblem, readProblem, readfromAndWritetoProblem ) import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile, createDirectoryIfMissing ) import Control.Monad ( liftM, when, unless ) import Workaround ( getCurrentDirectory, renameFile, setExecutable ) import ByteStringUtils ( gzReadFilePS ) -import qualified Data.ByteString as B (ByteString, empty, readFile, isPrefixOf) +import qualified Data.ByteString as B ( empty, readFile, isPrefixOf ) import qualified Data.ByteString.Char8 as BC (pack) -import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description, +import Darcs.Patch ( Patch, RealPatch, Effect, primIsHunk, primIsBinary, description, - try_to_shrink, commuteFL, commute, apply_to_filepaths ) + tryToShrink, commuteFL, commute ) import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict ) import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) -import Darcs.Patch.FileName ( FileName, fn2fp ) -import Darcs.Patch.TouchesFiles ( choose_touching ) -import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp, - slurp_has, list_slurpy_files ) +import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, list_slurpy_files ) import Darcs.Hopefully ( PatchInfoAnd, info, n2pia, hopefully, hopefullyM ) import Darcs.Repository.ApplyPatches ( apply_patches ) import qualified Darcs.Repository.HashedRepo as HashedRepo ( revert_tentative_changes, finalize_tentative_changes, - remove_from_tentative_inventory, sync_repo, + remove_from_tentative_inventory, copy_pristine, copy_partials_pristine, slurp_pristine, - apply_to_tentative_pristine, pristine_from_working, + apply_to_tentative_pristine, write_tentative_inventory, write_and_read_patch, add_to_tentative_inventory, read_repo, read_tentative_repo, clean_pristine, - replacePristineFromSlurpy, slurp_all_but_darcs ) import qualified Darcs.Repository.DarcsRepo as DarcsRepo -import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet, +import Darcs.Flags ( DarcsFlag(Verbose, Quiet, MarkConflicts, AllowConflicts, NoUpdateWorking, WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir, - SetScriptsExecutable, DryRun, IgnoreTimes, - Summary, NoSummary), + SetScriptsExecutable, DryRun ), want_external_merge, compression ) -import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, +import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, (:\/:)(..), (:/\:)(..), (:>)(..), - (+>+), lengthFL, nullFL, + (+>+), lengthFL, allFL, filterFL, reverseRL, reverseFL, concatRL, mapFL, mapFL_FL, concatFL ) import Darcs.Patch ( RepoPatch, Patchy, Prim, merge, - joinPatches, sort_coalesceFL, - list_conflicted_files, list_touched_files, - Named, patchcontents, anonymous, + joinPatches, + listConflictedFiles, listTouchedFiles, + Named, patchcontents, commuteRL, fromPrims, patch2patchinfo, readPatch, writePatch, effect, invert, - is_addfile, is_adddir, - is_setpref, - apply, apply_to_slurpy, - empty_markedup_file, MarkedUpFile + primIsAddfile, primIsAdddir, + primIsSetpref, + apply, applyToSlurpy, + emptyMarkedupFile, MarkedUpFile ) import Darcs.Patch.Patchy ( Invert(..) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) -import Darcs.Patch.Apply ( markup_file, LineMark(None) ) +import Darcs.Patch.Apply ( markupFile, LineMark(None) ) import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset ) -import Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff ) import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath, ioAbsoluteOrRemote, toPath ) import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) import Progress ( debugMessage ) import Darcs.ProgressPatches (progressFL) import Darcs.URL ( is_file ) -import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function, - getCaches ) +import Darcs.Repository.Prefs ( getCaches ) import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist, withTempDir, withPermDir ) -import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) import Darcs.Global ( darcsdir ) +import System.Mem( performGC ) + #include "impossible.h" -- | Repository IO monad. This monad-like datatype is responsible for @@ -206,7 +197,7 @@ case rf_or_e of Left err -> return $ Left err Right rf -> - case read_problem rf of + case readProblem rf of Just err -> return $ Left err Nothing -> if darcs then do pris <- identifyPristine cs <- getCaches opts here @@ -217,7 +208,7 @@ rf_or_e <- identifyRepoFormat url case rf_or_e of Left e -> return $ Left e - Right rf -> case read_problem rf of + Right rf -> case readProblem rf of Just err -> return $ Left err Nothing -> do cs <- getCaches opts url return $ Right $ Repo url opts rf (DarcsRepository nopristine cs) @@ -233,7 +224,7 @@ identifyRepositoryFor (Repo _ opts rf _) url = do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url let t' = case t of DarcsRepository x c -> DarcsRepository x c - case readfrom_and_writeto_problem rf_ rf of + case readfromAndWritetoProblem rf_ rf of Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e Nothing -> return $ Repo absurl opts rf_ t' @@ -275,8 +266,12 @@ else do setCurrentDirectory startpwd return onFail +-- The performGC in this function is a workaround for a library/GHC bug, +-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a +-- problem on fast machines, but virtual ones trip this from time to time) amNotInRepository :: [DarcsFlag] -> IO (Either String ()) amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d + `catchall` (performGC >> createDirectoryIfMissing False d) -- note that the above could always fail setCurrentDirectory d amNotInRepository [] @@ -300,7 +295,7 @@ slurp_pending repo@(Repo _ _ _ rt) = do cur <- slurp_recorded repo Sealed pend <- read_pending repo - case apply_to_slurpy pend cur of + case applyToSlurpy pend cur of Just pendcur -> return pendcur Nothing -> do putStrLn "Yikes, pending has conflicts. Renaming file as_darcs/patches/pending_buggy" renameFile (pendingName rt) (pendingName rt++"_buggy") @@ -308,7 +303,7 @@ slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy slurp_recorded (Repo dir opts rf (DarcsRepository _ c)) - | format_has HashedInventory rf = + | formatHas HashedInventory rf = HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory" slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do mc <- withCurrentDirectory dir $ slurpPristine p @@ -323,34 +318,11 @@ cur <- slurp_recorded repo Sealed pend <- read_pending repo withCurrentDirectory r $ - case apply_to_slurpy pend cur of + case applyToSlurpy pend cur of Nothing -> fail "Yikes, pending has conflicts!" Just pendslurp -> do unrec <- co_slurp pendslurp "." return (cur, unrec) -pendingName :: RepoType p -> String -pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending" - -read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r))) -read_pending (Repo r _ _ tp) = - withCurrentDirectory r (read_pendingfile (pendingName tp)) - -add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO () -add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () -add_to_pending repo p = - do pend <- get_unrecorded repo - make_new_pending repo (pend +>+ p) - -readPrims :: B.ByteString -> Sealed (FL Prim C(x)) -readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), B.ByteString) of - Nothing -> Sealed NilFL - Just (Sealed p,_) -> Sealed (effect p) - -read_pendingfile :: String -> IO (Sealed (FL Prim C(x))) -read_pendingfile name = do - pend <- gzReadFilePS name `catchall` return B.empty - return $ readPrims pend - make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO () make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () make_new_pending repo@(Repo r _ _ tp) origp = @@ -361,7 +333,7 @@ writeSealedPatch newname $ seal $ fromPrims $ sfp cur <- slurp_recorded repo Sealed p <- read_pendingfile newname - when (isNothing $ apply_to_slurpy p cur) $ do + when (isNothing $ applyToSlurpy p cur) $ do let buggyname = pendingName tp ++ "_buggy" renameFile newname buggyname bugDoc $ text "There was an attempt to write an invalid pending!" @@ -376,113 +348,45 @@ sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) sift_for_pending simple_ps = let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps - in if allFL (\p -> is_addfile p || is_adddir p) $ oldps + in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps then seal oldps else fromJust $ do Sealed x <- return $ sfp NilFL $ reverseFL oldps - return (case try_to_shrink x of + return (case tryToShrink x of ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps | otherwise -> seal ps) where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c)) sfp sofar NilRL = seal sofar sfp sofar (p:<:ps) - | is_hunk p || is_binary p + | primIsHunk p || primIsBinary p = case commuteFL (p :> sofar) of Right (sofar' :> _) -> sfp sofar' ps Left _ -> sfp (p:>:sofar) ps sfp sofar (p:<:ps) = sfp (p:>:sofar) ps -get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y)) -get_unrecorded_no_look_for_adds r paths = get_unrecorded_private (filter (/= LookForAdds)) r paths - -get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u)) -get_unrecorded_unsorted r = get_unrecorded_in_files_unsorted r [] - -get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u)) -get_unrecorded r = get_unrecorded_private id r [] - --- | Gets the unrecorded changes in the given paths in the current repository, --- without sorting them for presentation to the user -get_unrecorded_in_files_unsorted :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u)) -get_unrecorded_in_files_unsorted = get_unrecorded_private (AnyOrder:) - --- | Gets the unrecorded changes in the given paths in the current repository. -get_unrecorded_in_files :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u)) -get_unrecorded_in_files = get_unrecorded_private id - --- | The /unrecorded/ includes the pending and the working directory changes. --- The third argument is a list of paths: if this list is [], it will diff --- the whole repo, but if there are elements in it, the function will return --- only changes to files under those paths. The paths must be fixed paths --- starting with ".", but need not yet be unique. -get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y)) -get_unrecorded_private _ (Repo _ opts _ _) _ - | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL -get_unrecorded_private modopts repository@(Repo r oldopts _ _) files = - withCurrentDirectory r (do - debugMessage "Looking for unrecorded changes..." - cur <- slurp_pending repository - work <- if LookForAdds `elem` opts - then do nboring <- if Boring `elem` opts - then return $ darcsdir_filter - else boring_file_filter - slurp_unboring (myfilt cur nboring) "." - else co_slurp cur "." - ftf <- filetype_function - Sealed pend <- read_pending repository - let changed_files = apply_to_filepaths pend filesFP - pre_changed_files = apply_to_filepaths (invert pend) filesFP - Sealed relevantPend <- return $ if null files - then seal pend - else choose_touching pre_changed_files pend - debugMessage "diffing dir..." - let diffs = if null files - then unsafeDiff opts ftf cur work - else unsafeDiffAtPaths (ignoreTimes, lookForAdds, summary) ftf cur work changed_files - dif = if AnyOrder `elem` opts - then relevantPend +>+ diffs - else sort_coalesceFL $ relevantPend +>+ diffs - seq dif $ debugMessage "Found unrecorded changes." - return dif) - where myfilt s nboring f = slurp_has f s || nboring [f] /= [] - opts = modopts oldopts - -- NoSummary/Summary both present gives False - -- Just Summary gives True - -- Just NoSummary gives False - -- Neither gives False - summary = Summary `elem` opts && NoSummary `notElem` opts - lookForAdds = LookForAdds `elem` opts - ignoreTimes = IgnoreTimes `elem` opts - filesFP = map fn2fp files - -- @todo: we should not have to open the result of HashedRepo and -- seal it. Instead, update this function to work with type witnesses -- by fixing DarcsRepo to match HashedRepo in the handling of -- Repository state. read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r)) read_repo repo@(Repo r opts rf _) - | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo r + | formatHas HashedInventory rf = do ps <- HashedRepo.read_repo repo r return ps | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r return $ unsafeCoerceP ps readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t)) readTentativeRepo repo@(Repo r opts rf _) - | format_has HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r + | formatHas HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r return ps | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r return $ unsafeCoerceP ps makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p - | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p + | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p -sync_repo :: Repository p C(r u t) -> IO () -sync_repo (Repo r _ rf (DarcsRepository _ c)) - | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c -sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine p - prefsUrl :: Repository p C(r u t) -> String prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" @@ -524,91 +428,26 @@ fromPrims_ = fromPrims is_simple :: Prim C(x y) -> Bool -is_simple x = is_hunk x || is_binary x || is_setpref x +is_simple x = primIsHunk x || primIsBinary x || primIsSetpref x crude_sift :: FL Prim C(x y) -> FL Prim C(x y) crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs where ishunkbinary :: Prim C(x y) -> EqCheck C(x y) - ishunkbinary x | is_hunk x || is_binary x = unsafeCoerceP IsEq + ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq | otherwise = NotEq data HashedVsOld a = HvsO { old, hashed :: a } decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a decideHashedOrNormal rf (HvsO { hashed = h, old = o }) - | format_has HashedInventory rf = h + | formatHas HashedInventory rf = h | otherwise = o - -tentativelyMergePatches :: RepoPatch p - => Repository p C(r u t) -> String -> [DarcsFlag] - -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) - -> IO (Sealed (FL Prim C(u))) -tentativelyMergePatches = tentativelyMergePatches_ MakeChanges - -considerMergeToWorking :: RepoPatch p - => Repository p C(r u t) -> String -> [DarcsFlag] - -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) - -> IO (Sealed (FL Prim C(u))) -considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges - data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) -tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p - => MakeChanges - -> Repository p C(r u t) -> String -> [DarcsFlag] - -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) - -> IO (Sealed (FL Prim C(u))) -tentativelyMergePatches_ mc r cmd opts usi themi = - do let us = mapFL_FL hopefully usi - them = mapFL_FL hopefully themi - _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us) - pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty... - anonpend <- anonymous (fromPrims pend) - pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) - let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw - Sealed standard_resolved_pw <- return $ standard_resolution pwprim - debugMessage "Checking for conflicts..." - mapM_ backupByCopying $ list_touched_files standard_resolved_pw - debugMessage "Announcing conflicts..." - have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw - debugMessage "Checking for unrecorded conflicts..." - have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc - debugMessage "Reading working directory..." - (_, working) <- slurp_recorded_and_unrecorded r - debugMessage "Working out conflicts in actual working directory..." - Sealed pw_resolution <- - case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of - (Nothing,_) -> return $ if AllowConflicts `elem` opts - then seal NilFL - else seal standard_resolved_pw - (_,False) -> return $ seal standard_resolved_pw - (Just c, True) -> external_resolution working c - (effect us +>+ pend) - (effect them) pwprim - debugMessage "Applying patches to the local directories..." - when (mc == MakeChanges) $ - do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO () - doChanges NilFL = applyps r themi - doChanges _ = applyps r (mapFL_FL n2pia pc) - doChanges usi - setTentativePending r (effect pend' +>+ pw_resolution) - return $ seal (effect pwprim +>+ pw_resolution) - where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()] - mapAdd _ NilFL = [] - mapAdd r'@(Repo dir df rf dr) (a:>:as) = - -- we construct a new Repository object on the recursive case so that the - -- recordedstate of the repository can match the fact that we just wrote a patch - tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as - applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO () - applyps repo ps = do debugMessage "Adding patches to inventory..." - sequence_ $ mapAdd repo ps - debugMessage "Applying patches to pristine..." - applyToTentativePristine repo ps - announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool announce_merge_conflicts cmd opts resolved_pw = - case nubsort $ list_touched_files $ resolved_pw of + case nubsort $ listTouchedFiles $ resolved_pw of [] -> return False cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts || want_external_merge opts /= Nothing @@ -636,11 +475,11 @@ pend -> case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of _ :/\: pend' -> - case list_conflicted_files pend' of + case listConflictedFiles pend' of [] -> return False - fs -> do yorn <- promptYorn - ("You have conflicting local changes to:\n" - ++ unwords fs++"\nProceed?") + fs -> do putStrLn ("You have conflicting local changes to:\n" + ++ unwords fs) + yorn <- promptYorn "Proceed?" when (yorn /= 'y') $ do putStrLn "Cancelled." exitWith ExitSuccess @@ -736,7 +575,7 @@ prepend repository $ effect ps remove_from_unrevert_context repository ps debugMessage "Removing changes from tentative inventory..." - if format_has HashedInventory rf + if formatHas HashedInventory rf then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps when (up == UpdatePristine) $ HashedRepo.apply_to_tentative_pristine c opts $ @@ -773,7 +612,7 @@ finalizeRepositoryChanges (Repo _ opts _ _) | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified" finalizeRepositoryChanges repository@(Repo dir opts rf _) - | format_has HashedInventory rf = + | formatHas HashedInventory rf = withCurrentDirectory dir $ do debugMessage "Considering whether to test..." testTentative repository debugMessage "Finalizing changes..." @@ -802,7 +641,7 @@ when (Test `elem` opts) $ withCurrentDirectory dir $ do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ()) debugMessage "About to run test if it exists." - testline <- get_prefval "test" + testline <- getPrefval "test" case testline of Nothing -> return () Just testcode -> @@ -837,7 +676,7 @@ getUMask (_:l) = getUMask l withGutsOf :: Repository p C(r u t) -> IO () -> IO () -withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id +withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id | otherwise = withSignalsBlocked withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a @@ -848,7 +687,7 @@ withRepositoryDirectory opts1 url job = do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url let rt' = case rt of DarcsRepository t c -> DarcsRepository t c - if format_has Darcs2 rf + if formatHas Darcs2 rf then do debugMessage $ "Identified darcs-2 repo: " ++ dir job1_ (Repo dir opts rf rt') else do debugMessage $ "Identified darcs-1 repo: " ++ dir @@ -868,7 +707,7 @@ withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepoLock opts job = withRepository opts $- \repository@(Repo _ _ rf _) -> - do case write_problem rf of + do case writeProblem rf of Nothing -> return () Just err -> fail err let name = "./"++darcsdir++"/lock" @@ -882,13 +721,13 @@ withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepoReadLock opts job = withRepository opts $- \repository@(Repo _ _ rf _) -> - do case write_problem rf of + do case writeProblem rf of Nothing -> return () Just err -> fail err let name = "./"++darcsdir++"/lock" wu = case (getUMask opts) of Nothing -> id Just u -> withUMask u - wu $ if format_has HashedInventory rf || DryRun `elem` opts + wu $ if formatHas HashedInventory rf || DryRun `elem` opts then job repository else withLock name (revertRepositoryChanges repository >> job repository) @@ -898,7 +737,8 @@ Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL)) remove_from_unrevert_context_ bundle where unrevert_impossible unrevert_loc = - do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?" + do putStrLn "This operation will make unrevert impossible!" + yorn <- promptYorn "Proceed?" case yorn of 'n' -> fail "Cancelled." 'y' -> removeFile unrevert_loc `catchall` return () @@ -916,15 +756,14 @@ debugMessage "Adjusting the context of the unrevert changes..." ref <- readTentativeRepo repository case get_common_and_uncommon (bundle, ref) of - (common,(h_us:<:NilRL):<:NilRL :\/: NilRL:<:NilRL) -> + (common,(h_us:<:NilRL) :\/: NilRL) -> case commuteRL (reverseFL ps :> hopefully h_us) of Nothing -> unrevert_impossible unrevert_loc Just (us' :> _) -> do - s <- slurp_recorded repository - writeDocBinFile unrevert_loc $ - make_bundle [] s - (common \\ pis) (us':>:NilFL) - (common,(x:<:NilRL):<:NilRL:\/:_) + s <- readRecorded repository + bundle' <- make_bundle [] s (common \\ pis) (us' :>: NilFL) + writeDocBinFile unrevert_loc bundle' + (common,(x:<:NilRL):\/:_) | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc | isr -> return () where isr = isJust $ hopefullyM x @@ -957,14 +796,9 @@ HvsO { hashed = HashedRepo.clean_pristine repository, old = return () } -replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO () -replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s - | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s - | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris - createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO () createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir - | format_has HashedInventory rf = + | formatHas HashedInventory rf = do createDirectoryIfMissing True reldir withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory") | otherwise = @@ -977,7 +811,7 @@ -- fp below really should be FileName createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO () createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir - | format_has HashedInventory rf = + | formatHas HashedInventory rf = do createDirectoryIfMissing True dir withCurrentDirectory dir $ HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs @@ -987,34 +821,17 @@ unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do clonePartialsTree "." dir (map toFilePath prefs) -pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO () -pristineFromWorking (Repo dir opts rf (DarcsRepository _ c)) - | format_has HashedInventory rf = - withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts) -pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) = - withCurrentDirectory dir $ createPristineFromWorking p - withRecorded :: RepoPatch p => Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withRecorded repository mk_dir f = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) f d -checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool -checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 = - do s1 <- slurp_recorded repository - ftf <- filetype_function - -- The @$!@ is necessary because some code called from this function uses - -- unsafeInterleaveIO around functions that throw exceptions. If one used - -- @$@ instead of @$!@ here, those exceptions might not be caught by code - -- that runs this function inside a @catch@. - return $! nullFL $ unsafeDiff (LookForAdds:IgnoreTimes:opts) ftf s1 s2 - withTentative :: forall p a C(r u t). RepoPatch p => Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f - | format_has HashedInventory rf = + | formatHas HashedInventory rf = mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine") f d withTentative repository@(Repo dir opts _ _) mk_dir f = @@ -1032,7 +849,7 @@ getMarkedupFile repository pinfo f = do Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info) . reverseRL . concatRL) `liftM` read_repo repository - return $ snd $ do_mark_all patches (f, empty_markedup_file) + return $ snd $ do_mark_all patches (f, emptyMarkedupFile) where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v) dropWhileFL _ NilFL = flipSeal NilFL dropWhileFL p xs@(x:>:xs') @@ -1042,7 +859,7 @@ -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) do_mark_all (hp:>:pps) (f, mk) = case hopefullyM hp of - Just p -> do_mark_all pps $ markup_file (info hp) (patchcontents p) (f, mk) + Just p -> do_mark_all pps $ markupFile (info hp) (patchcontents p) (f, mk) Nothing -> (f, [(BC.pack "Error reading a patch!",None)]) do_mark_all NilFL (f, mk) = (f, mk) diff --git a/src/Darcs/Repository/LowLevel.hs b/src/Darcs/Repository/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/LowLevel.hs @@ -0,0 +1,51 @@ +-- Copyright (C) 2002-2004,2007-2008 David Roundy +-- Copyright (C) 2005 Juliusz Chroboczek +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Repository.LowLevel ( read_pending, read_pendingfile, pendingName, readPrims ) where + +import Darcs.Repository.InternalTypes ( RepoType(..), Repository(..) ) +import Darcs.Patch ( readPatch, Prim, Patch, RepoPatch, effect ) +import Darcs.Global ( darcsdir ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) +import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Utils ( catchall, withCurrentDirectory ) +import ByteStringUtils ( gzReadFilePS ) +import qualified Data.ByteString as BS ( ByteString, empty ) + +pendingName :: RepoType p -> String +pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending" + +read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r))) +read_pending (Repo r _ _ tp) = + withCurrentDirectory r (read_pendingfile (pendingName tp)) + +read_pendingfile :: String -> IO (Sealed (FL Prim C(x))) +read_pendingfile name = do + pend <- gzReadFilePS name `catchall` return BS.empty + return $ readPrims pend + +readPrims :: BS.ByteString -> Sealed (FL Prim C(x)) +readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), BS.ByteString) of + Nothing -> Sealed NilFL + Just (Sealed p,_) -> Sealed (effect p) + diff --git a/src/Darcs/Repository/Merge.hs b/src/Darcs/Repository/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Merge.hs @@ -0,0 +1,113 @@ +-- Copyright (C) 2002-2004,2007-2008 David Roundy +-- Copyright (C) 2005 Juliusz Chroboczek +-- Copyright (C) 2009 Petr Rockai +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +#include "gadts.h" + +module Darcs.Repository.Merge where + +import Darcs.Resolution ( standard_resolution, external_resolution ) +import Darcs.External ( backupByCopying ) +import Control.Monad ( when ) + +import Darcs.Patch ( Effect ) +import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully ) +import Darcs.Flags + ( DarcsFlag( AllowConflicts ), want_external_merge ) +import Darcs.Witnesses.Ordered + ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL ) +import Darcs.Patch + ( RepoPatch, Prim, merge, joinPatches, listTouchedFiles + , patchcontents, anonymous, fromPrims, effect ) +import Progress( debugMessage ) +import Darcs.ProgressPatches( progressFL ) +import Darcs.Witnesses.Sealed( Sealed(Sealed), seal ) +import Darcs.Repository.InternalTypes( Repository(..) ) + +import Darcs.Repository.State( unrecordedChanges, readUnrecorded ) + +import Darcs.Repository.Internal + ( announce_merge_conflicts, check_unrecorded_conflicts + , MakeChanges(..), setTentativePending + , tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) ) + +tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p + => MakeChanges + -> Repository p C(r u t) -> String -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> IO (Sealed (FL Prim C(u))) +tentativelyMergePatches_ mc r cmd opts usi themi = + do let us = mapFL_FL hopefully usi + them = mapFL_FL hopefully themi + _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us) + pend <- unrecordedChanges opts r [] + anonpend <- anonymous (fromPrims pend) + pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) + let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw + Sealed standard_resolved_pw <- return $ standard_resolution pwprim + debugMessage "Checking for conflicts..." + mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw + debugMessage "Announcing conflicts..." + have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw + debugMessage "Checking for unrecorded conflicts..." + have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc + debugMessage "Reading working directory..." + working <- readUnrecorded r + debugMessage "Working out conflicts in actual working directory..." + Sealed pw_resolution <- + case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of + (Nothing,_) -> return $ if AllowConflicts `elem` opts + then seal NilFL + else seal standard_resolved_pw + (_,False) -> return $ seal standard_resolved_pw + (Just c, True) -> external_resolution working c + (effect us +>+ pend) + (effect them) pwprim + debugMessage "Applying patches to the local directories..." + when (mc == MakeChanges) $ + do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO () + doChanges NilFL = applyps r themi + doChanges _ = applyps r (mapFL_FL n2pia pc) + doChanges usi + setTentativePending r (effect pend' +>+ pw_resolution) + return $ seal (effect pwprim +>+ pw_resolution) + where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()] + mapAdd _ NilFL = [] + mapAdd r'@(Repo dir df rf dr) (a:>:as) = + -- we construct a new Repository object on the recursive case so that the + -- recordedstate of the repository can match the fact that we just wrote a patch + tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as + applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO () + applyps repo ps = do debugMessage "Adding patches to inventory..." + sequence_ $ mapAdd repo ps + debugMessage "Applying patches to pristine..." + applyToTentativePristine repo ps + +tentativelyMergePatches :: RepoPatch p + => Repository p C(r u t) -> String -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> IO (Sealed (FL Prim C(u))) +tentativelyMergePatches = tentativelyMergePatches_ MakeChanges + + +considerMergeToWorking :: RepoPatch p + => Repository p C(r u t) -> String -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> IO (Sealed (FL Prim C(u))) +considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges + diff --git a/src/Darcs/Repository/Prefs.lhs b/src/Darcs/Repository/Prefs.lhs --- a/src/Darcs/Repository/Prefs.lhs +++ b/src/Darcs/Repository/Prefs.lhs @@ -22,16 +22,16 @@ #include "gadts.h" -module Darcs.Repository.Prefs ( add_to_preflist, get_preflist, set_preflist, - get_global, environmentHelpHome, - defaultrepo, set_defaultrepo, - get_prefval, set_prefval, change_prefval, - def_prefval, - write_default_prefs, - boring_regexps, boring_file_filter, darcsdir_filter, - FileType(..), filetype_function, +module Darcs.Repository.Prefs ( addToPreflist, getPreflist, setPreflist, + getGlobal, environmentHelpHome, + defaultrepo, setDefaultrepo, + getPrefval, setPrefval, changePrefval, + defPrefval, + writeDefaultPrefs, + boringRegexps, boringFileFilter, darcsdirFilter, + FileType(..), filetypeFunction, getCaches, - binaries_file_help + binariesFileHelp ) where import System.IO.Error ( isDoesNotExistError ) @@ -71,10 +71,10 @@ \input{Darcs/ArgumentDefaults.lhs} \begin{code} -write_default_prefs :: IO () -write_default_prefs = do set_preflist "boring" default_boring - set_preflist "binaries" default_binaries - set_preflist "motd" [] +writeDefaultPrefs :: IO () +writeDefaultPrefs = do setPreflist "boring" defaultBoring + setPreflist "binaries" defaultBinaries + setPreflist "motd" [] \end{code} \paragraph{repos} @@ -124,7 +124,7 @@ as \verb!manual/index.html!) matches any of the boring regular expressions is considered boring. The boring file is used to filter the files provided to darcs add, to allow you to use a -simple \verb-darcs add newdir newdir/*- +simple \verb-darcs add newdir newdir/-\verb-*- % cabal haddock barfs on adjacent / * without accidentally adding a bunch of object files. It is also used when the \verb!--look-for-adds! flag is given to whatsnew or record. @@ -132,9 +132,9 @@ boring, even if it matches the boring file filter. \begin{code} -{-# NOINLINE default_boring #-} -default_boring :: [String] -default_boring = ["# Boring file regexps:", +{-# NOINLINE defaultBoring #-} +defaultBoring :: [String] +defaultBoring = ["# Boring file regexps:", "", "### compiler and interpreter intermediate files", "# haskell (ghc) interfaces", @@ -229,20 +229,20 @@ "# mac os finder", "(^|/)\\.DS_Store$" ] -darcsdir_filter :: [FilePath] -> [FilePath] -darcsdir_filter = filter (not.is_darcsdir) -is_darcsdir :: FilePath -> Bool -is_darcsdir ('.':'/':f) = is_darcsdir f -is_darcsdir "." = True -is_darcsdir "" = True -is_darcsdir ".." = True -is_darcsdir "../" = True -is_darcsdir fp = darcsdir `isPrefixOf` fp +darcsdirFilter :: [FilePath] -> [FilePath] +darcsdirFilter = filter (not.isDarcsdir) +isDarcsdir :: FilePath -> Bool +isDarcsdir ('.':'/':f) = isDarcsdir f +isDarcsdir "." = True +isDarcsdir "" = True +isDarcsdir ".." = True +isDarcsdir "../" = True +isDarcsdir fp = darcsdir `isPrefixOf` fp -- | The path of the global preference directory; @~/.darcs@ on Unix, -- and @%APPDATA%/darcs@ on Windows. -global_prefs_dir :: IO (Maybe FilePath) -global_prefs_dir = do +globalPrefsDir :: IO (Maybe FilePath) +globalPrefsDir = do env <- getEnvironment case lookup "DARCS_TESTING_PREFS_DIR" env of Just d -> return (Just d) @@ -255,26 +255,26 @@ "%APPDATA%/darcs (on Windows). This is also the default location of", "the cache."]) -get_global :: String -> IO [String] -get_global f = do - dir <- global_prefs_dir +getGlobal :: String -> IO [String] +getGlobal f = do + dir <- globalPrefsDir case dir of - (Just d) -> get_preffile $ d f + (Just d) -> getPreffile $ d f Nothing -> return [] -global_cache_dir :: IO (Maybe FilePath) -global_cache_dir = slash_cache `fmap` global_prefs_dir +globalCacheDir :: IO (Maybe FilePath) +globalCacheDir = slash_cache `fmap` globalPrefsDir where slash_cache = fmap ( "cache") -boring_regexps :: IO [Regex] -boring_regexps = do - borefile <- def_prefval "boringfile" (darcsdir ++ "/prefs/boring") - bores <- get_lines borefile `catchall` return [] - gbs <- get_global "boring" +boringRegexps :: IO [Regex] +boringRegexps = do + borefile <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring") + bores <- getPrefLines borefile `catchall` return [] + gbs <- getGlobal "boring" return $ map mkRegex $ bores ++ gbs -boring_file_filter :: IO ([FilePath] -> [FilePath]) -boring_file_filter = boring_regexps >>= return . actual_boring_file_filter +boringFileFilter :: IO ([FilePath] -> [FilePath]) +boringFileFilter = boringRegexps >>= return . actualBoringFileFilter noncomments :: [String] -> [String] noncomments ss = filter is_ok ss @@ -282,8 +282,8 @@ is_ok ('#':_) = False is_ok _ = True -get_lines :: ReadableDirectory m => FilePath -> m [String] -get_lines f = (notconflicts . noncomments . map stripCr . lines) +getPrefLines :: ReadableDirectory m => FilePath -> m [String] +getPrefLines f = (notconflicts . noncomments . map stripCr . lines) `fmap` mReadBinFile (fp2fn f) where notconflicts = filter nc startswith [] _ = True @@ -296,9 +296,9 @@ -- | From a list of paths, filter out any that are within @_darcs@ or -- match a boring regexp. -actual_boring_file_filter :: [Regex] -> [FilePath] -> [FilePath] -actual_boring_file_filter regexps files = filter (not . boring . normalize) files - where boring file = is_darcsdir file || +actualBoringFileFilter :: [Regex] -> [FilePath] -> [FilePath] +actualBoringFileFilter regexps files = filter (not . boring . normalize) files + where boring file = isDarcsdir file || any (\regexp -> isJust $ matchRegex regexp file) regexps normalize :: FilePath -> FilePath @@ -326,23 +326,23 @@ data FileType = BinaryFile | TextFile deriving (Eq) -{-# NOINLINE default_binaries #-} +{-# NOINLINE defaultBinaries #-} -- | The lines that will be inserted into @_darcs/prefs/binaries@ when -- @darcs init@ is run. Hence, a list of comments, blank lines and -- regular expressions (ERE dialect). -- -- Note that while this matches .gz and .GZ, it will not match .gZ, -- i.e. it is not truly case insensitive. -default_binaries :: [String] -default_binaries = help ++ +defaultBinaries :: [String] +defaultBinaries = help ++ ["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ] where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso", "jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png", "pyc","so","tar","tgz","tiff?","z","zip"] - help = map ("# "++) binaries_file_help + help = map ("# "++) binariesFileHelp -binaries_file_help :: [String] -binaries_file_help = +binariesFileHelp :: [String] +binariesFileHelp = ["This file contains a list of extended regular expressions, one per", "line. A file path matching any of these expressions is assumed to", "contain binary data (not text). The entries in ~/.darcs/binaries (if", @@ -351,12 +351,12 @@ "Blank lines, and lines beginning with an octothorpe (#) are ignored.", "See regex(7) for a description of extended regular expressions."] -filetype_function :: IO (FilePath -> FileType) -filetype_function = do - binsfile <- def_prefval "binariesfile" (darcsdir ++ "/prefs/binaries") - bins <- get_lines binsfile `catch` +filetypeFunction :: IO (FilePath -> FileType) +filetypeFunction = do + binsfile <- defPrefval "binariesfile" (darcsdir ++ "/prefs/binaries") + bins <- getPrefLines binsfile `catch` (\e-> if isDoesNotExistError e then return [] else ioError e) - gbs <- get_global "binaries" + gbs <- getGlobal "binaries" regexes <- return (map (\r -> mkRegex r) (bins ++ gbs)) let isbin f = or $ map (\r -> isJust $ matchRegex r f) regexes ftf f = if isbin $ normalize f then BinaryFile else TextFile @@ -375,60 +375,60 @@ withPrefsDirectory j = do prefs <- prefsDirectory `mplus` return "x" when (prefs /= "x") $ j prefs -add_to_preflist :: WriteableDirectory m => String -> String -> m () -add_to_preflist p s = withPrefsDirectory $ \prefs -> do +addToPreflist :: WriteableDirectory m => String -> String -> m () +addToPreflist p s = withPrefsDirectory $ \prefs -> do hasprefs <- mDoesDirectoryExist $ fp2fn prefs unless hasprefs $ mCreateDirectory $ fp2fn prefs - pl <- get_preflist p + pl <- getPreflist p mWriteBinFile (fp2fn $ prefs ++ p) $ unlines $ union [s] pl -get_preflist :: ReadableDirectory m => String -> m [String] -get_preflist p = do prefs <- prefsDirectory `mplus` return "x" - if (prefs /= "x") then get_preffile $ prefs ++ p +getPreflist :: ReadableDirectory m => String -> m [String] +getPreflist p = do prefs <- prefsDirectory `mplus` return "x" + if (prefs /= "x") then getPreffile $ prefs ++ p else return [] -get_preffile :: ReadableDirectory m => FilePath -> m [String] -get_preffile f = do +getPreffile :: ReadableDirectory m => FilePath -> m [String] +getPreffile f = do hasprefs <- mDoesFileExist (fp2fn f) if hasprefs - then get_lines f + then getPrefLines f else return [] -set_preflist :: WriteableDirectory m => String -> [String] -> m () -set_preflist p ls = withPrefsDirectory $ \prefs -> do +setPreflist :: WriteableDirectory m => String -> [String] -> m () +setPreflist p ls = withPrefsDirectory $ \prefs -> do haspref <- mDoesDirectoryExist $ fp2fn prefs if haspref then mWriteBinFile (fp2fn $ prefs ++ p) (unlines ls) else return () -def_prefval :: String -> String -> IO String -def_prefval p d = do - pv <- get_prefval p +defPrefval :: String -> String -> IO String +defPrefval p d = do + pv <- getPrefval p case pv of Nothing -> return d Just v -> return v -get_prefval :: ReadableDirectory m => String -> m (Maybe String) -get_prefval p = - do pl <- get_preflist "prefs" +getPrefval :: ReadableDirectory m => String -> m (Maybe String) +getPrefval p = + do pl <- getPreflist "prefs" case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of [val] -> case words val of [] -> return Nothing _ -> return $ Just $ tail val _ -> return Nothing -set_prefval :: WriteableDirectory m => String -> String -> m () -set_prefval p v = do pl <- get_preflist "prefs" - set_preflist "prefs" $ +setPrefval :: WriteableDirectory m => String -> String -> m () +setPrefval p v = do pl <- getPreflist "prefs" + setPreflist "prefs" $ filter ((/=p).fst.(break (==' '))) pl ++ [p++" "++v] -change_prefval :: WriteableDirectory m => String -> String -> String -> m () -change_prefval p f t = - do pl <- get_preflist "prefs" - ov <- get_prefval p +changePrefval :: WriteableDirectory m => String -> String -> String -> m () +changePrefval p f t = + do pl <- getPreflist "prefs" + ov <- getPrefval p newval <- case ov of Nothing -> return t Just old -> if old == f then return t else return old - set_preflist "prefs" $ + setPreflist "prefs" $ filter ((/=p).fst.(break(==' '))) pl ++ [p++" "++newval] defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] @@ -437,22 +437,22 @@ | otherwise = do absr <- ioAbsolute r return $ toFilePath absr case [r | RemoteRepo r <- opts] of - [] -> do defrepo <- get_preflist "defaultrepo" + [] -> do defrepo <- getPreflist "defaultrepo" case defrepo of [r] -> (:[]) `fmap` fixR r _ -> return [] rs -> mapM fixR rs defaultrepo _ _ r = return r -set_defaultrepo :: String -> [DarcsFlag] -> IO () -set_defaultrepo r opts = do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp) +setDefaultrepo :: String -> [DarcsFlag] -> IO () +setDefaultrepo r opts = do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp) then return True else do olddef <- - get_preflist "defaultrepo" + getPreflist "defaultrepo" return (olddef == []) when doit - (set_preflist "defaultrepo" [r]) - add_to_preflist "repos" r + (setPreflist "defaultrepo" [r]) + addToPreflist "repos" r `catchall` return () -- we don't care if this fails! where r_is_not_tmp = not $ r `elem` [x | RemoteRepo x <- opts] @@ -503,16 +503,16 @@ \begin{code} getCaches :: [DarcsFlag] -> String -> IO Cache getCaches opts repodir = - do here <- parsehs `fmap` get_preffile (darcsdir ++ "/prefs/sources") + do here <- parsehs `fmap` getPreffile (darcsdir ++ "/prefs/sources") there <- (parsehs . lines . BC.unpack) `fmap` (gzFetchFilePS (repodir ++ "/" ++ darcsdir ++ "/prefs/sources") Cachable `catchall` return B.empty) - globalcachedir <- global_cache_dir + globalcachedir <- globalCacheDir let globalcache = case (nocache,globalcachedir) of (True,_) -> [] (_,Just d) -> [Cache Directory Writable d] _ -> [] - globalsources <- parsehs `fmap` get_global "sources" + globalsources <- parsehs `fmap` getGlobal "sources" thisdir <- getCurrentDirectory let thisrepo = if Ephemeral `elem` opts then [Cache Repo NotWritable $ toFilePath thisdir] diff --git a/src/Darcs/Repository/Pristine.hs b/src/Darcs/Repository/Pristine.hs --- a/src/Darcs/Repository/Pristine.hs +++ b/src/Darcs/Repository/Pristine.hs @@ -25,7 +25,6 @@ createPristine, removePristine, identifyPristine, slurpPristine, applyPristine, createPristineFromWorking, - syncPristine, replacePristineFromSlurpy, getPristinePop, pristineDirectory, pristineToFlagString, easyCreatePristineDirectoryTree, @@ -34,17 +33,14 @@ import Data.Maybe ( isJust ) import Control.Monad ( when, liftM ) -import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, - renameDirectory, removeFile ) +import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, removeFile ) import Darcs.Lock ( rm_recursive, writeBinFile ) -import Darcs.Diff ( sync ) import Workaround ( getCurrentDirectory ) -import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, writeSlurpy ) -import Darcs.Utils ( catchall ) +import Darcs.SlurpDirectory ( Slurpy, mmap_slurp ) import Darcs.PopulationData ( Population, getPopFrom ) import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) ) -import Darcs.Repository.Format ( RepoFormat, format_has, +import Darcs.Repository.Format ( RepoFormat, formatHas, RepoProperty(HashedInventory) ) import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) ) import Darcs.Patch ( Patchy, apply ) @@ -97,7 +93,7 @@ n2 = darcsdir++"/current" ++ ext flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine -flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine +flagsToPristine _ rf | formatHas HashedInventory rf = HashedPristine flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none") flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName) flagsToPristine (_ : t) rf = flagsToPristine t rf @@ -143,28 +139,6 @@ createPristineFromWorking (NoPristine _) = return () createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n createPristineFromWorking HashedPristine = - bug "HashedPristine is not implemented yet." - -syncPristine :: Pristine -> IO () -syncPristine (NoPristine _) = return () -syncPristine (PlainPristine n) = - do ocur <- mmap_slurp n - owork <- co_slurp ocur "." - sync n ocur owork -syncPristine HashedPristine = return () -- FIXME this should be implemented! - -replacePristineFromSlurpy :: Slurpy -> Pristine -> IO () -replacePristineFromSlurpy _ (NoPristine _) = return () -replacePristineFromSlurpy s (PlainPristine n) = - do rm_recursive nold - `catchall` return () - writeSlurpy s ntmp - renameDirectory n nold - renameDirectory ntmp n - return () - where nold = darcsdir ++ "/" ++ pristineName ++ "-old" - ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp" -replacePristineFromSlurpy _ HashedPristine = bug "HashedPristine is not implemented yet." getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population) diff --git a/src/Darcs/Repository/Repair.hs b/src/Darcs/Repository/Repair.hs --- a/src/Darcs/Repository/Repair.hs +++ b/src/Darcs/Repository/Repair.hs @@ -1,63 +1,59 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Repository.Repair ( replayRepository, - RepositoryConsistency(..) ) +module Darcs.Repository.Repair ( replayRepository, checkIndex + , RepositoryConsistency(..) ) where import Control.Monad ( when, unless ) +import Control.Monad.Trans ( liftIO ) +import Control.Applicative( (<$>) ) import Control.Exception ( finally ) import Data.Maybe ( catMaybes ) -import Data.List ( sort ) +import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing ) -import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad, syncSlurpy ) import Darcs.Lock( rm_recursive ) import Darcs.Hopefully ( PatchInfoAnd, info ) -import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL, +import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL, mapRL ) -import Darcs.Patch.Depends ( get_patches_beyond_tag ) import Darcs.Patch.Patchy ( applyAndTryToFix ) import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly ) import Darcs.Patch.Set ( PatchSet ) -import Darcs.Patch ( RepoPatch, patch2patchinfo ) +import Darcs.Patch ( RepoPatch ) import Darcs.Repository.Format ( identifyRepoFormat, - RepoProperty ( HashedInventory ), format_has ) -import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) ) -import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine, - clean_hashdir ) + RepoProperty ( HashedInventory ), formatHas ) +import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) +import Darcs.Repository.HashedIO ( clean_hashdir ) import Darcs.Repository.HashedRepo ( readHashedPristineRoot ) -import Darcs.Repository.Checkpoint ( get_checkpoint_by_default ) import Darcs.Repository.InternalTypes ( extractCache ) -import Darcs.Repository ( Repository, read_repo, - checkPristineAgainstSlurpy, - makePatchLazy ) +import Darcs.Repository.Prefs ( filetypeFunction ) +import Darcs.Repository ( Repository, read_repo, makePatchLazy + , readRecorded, readIndex, readRecordedAndPending ) -import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) import Darcs.Utils ( catchall ) import Darcs.Global ( darcsdir ) -import Darcs.Flags ( compression ) import Printer ( Doc, putDocLn, text ) import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) ) -#include "impossible.h" -run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a) -run_slurpy s f = - case withSlurpy s f of - Left err -> fail err - Right x -> return x +import Darcs.Diff( treeDiff ) +import Storage.Hashed.Monad( TreeIO ) +import Storage.Hashed.Darcs( hashedTreeIO ) +import Storage.Hashed.Tree( Tree, emptyTree ) +import Storage.Hashed.AnchoredPath( anchorPath ) +import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 ) +import Storage.Hashed.Tree( list, restrict, expand, itemHash, zipTrees ) +import Storage.Hashed.Darcs( darcsUpdateHashes ) +import Storage.Hashed.Index( updateIndex ) +import Storage.Hashed( readPlainTree ) -update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy -update_slurpy r c opts s = do - current <- readHashedPristineRoot r - h <- writeHashedPristine c (compression opts) s - s' <- slurpHashedPristine c (compression opts) h - clean_hashdir c HashedPristineDir $ catMaybes [Just h, current] - return s' +import qualified Data.ByteString.Char8 as BS +#include "impossible.h" + replaceInFL :: FL (PatchInfoAnd a) -> [(PatchInfo, PatchInfoAnd a)] -> FL (PatchInfoAnd a) @@ -67,33 +63,33 @@ | info o == o' = c:>:replaceInFL orig ch_rest | otherwise = o:>:replaceInFL orig ch -applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy, Bool) -applyAndFix _ _ s _ NilFL = return (NilFL, s, True) -applyAndFix c opts s_ r psin = - do beginTedious k - tediousSize k $ lengthFL psin - (repaired, slurpy, ok) <- aaf s_ psin - endTedious k - orig <- (reverseRL . concatRL) `fmap` read_repo r - return (replaceInFL orig repaired, slurpy, ok) +applyAndFix :: forall p. RepoPatch p => Repository p -> FL (PatchInfoAnd p) -> TreeIO (FL (PatchInfoAnd p), Bool) +applyAndFix _ NilFL = return (NilFL, True) +applyAndFix r psin = + do liftIO $ beginTedious k + liftIO $ tediousSize k $ lengthFL psin + (repaired, ok) <- aaf psin + liftIO $ endTedious k + orig <- liftIO $ (reverseRL . concatRL) `fmap` read_repo r + return (replaceInFL orig repaired, ok) where k = "Replaying patch" - aaf s NilFL = return ([], s, True) - aaf s (p:>:ps) = do - (s', mp') <- run_slurpy s $ applyAndTryToFix p + aaf :: FL (PatchInfoAnd p) -> TreeIO ([(PatchInfo, PatchInfoAnd p)], Bool) + aaf NilFL = return ([], True) + aaf (p:>:ps) = do + mp' <- applyAndTryToFix p let !infp = info p -- assure that 'p' can be garbage collected. - finishedOneIO k $ show $ human_friendly $ infp - s'' <- syncSlurpy (update_slurpy r c opts) s' - (ps', s''', restok) <- aaf s'' ps + liftIO $ finishedOneIO k $ show $ human_friendly $ infp + (ps', restok) <- aaf ps case mp' of - Nothing -> return (ps', s''', restok) - Just (e,pp) -> do putStrLn e - p' <- makePatchLazy r pp - return ((infp, p'):ps', s''', False) + Nothing -> return (ps', restok) + Just (e,pp) -> do liftIO $ putStrLn e + p' <- liftIO $ makePatchLazy r pp + return ((infp, p'):ps', False) data RepositoryConsistency p = RepositoryConsistent - | BrokenPristine Slurpy - | BrokenPatches Slurpy (PatchSet p) + | BrokenPristine (Tree IO) + | BrokenPatches (Tree IO) (PatchSet p) check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO () check_uniqueness putVerbose putInfo repository = @@ -116,35 +112,32 @@ let putVerbose s = when (Verbose `elem` opts) $ putDocLn s putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s check_uniqueness putVerbose putInfo repo - maybe_chk <- get_checkpoint_by_default repo - let c = extractCache repo createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed" - rooth <- writeHashedPristine c (compression opts) empty_slurpy - s <- slurpHashedPristine c (compression opts) rooth + putVerbose $ text "Reading recorded state..." + pris <- readRecorded repo `catch` \_ -> return emptyTree putVerbose $ text "Applying patches..." patches <- read_repo repo - (s', newpatches, patches_ok) <- case maybe_chk of - Just (Sealed chk) -> - do let chtg = patch2patchinfo chk - putVerbose $ text "I am repairing from a checkpoint." - (s'', _) <- run_slurpy s $ applyAndTryToFix chk - (_, s_, ok) <- applyAndFix c opts s'' repo - (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches) - return (s_, patches, ok) - Nothing -> do debugMessage "Fixing any broken patches..." - let psin = reverseRL $ concatRL patches - (ps, s_, ok) <- applyAndFix c opts s repo psin - debugMessage "Done fixing broken patches..." - return (s_, (reverseFL ps :<: NilRL), ok) + debugMessage "Fixing any broken patches..." + let psin = reverseRL $ concatRL patches + repair = applyAndFix repo psin + ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree "_darcs/pristine.hashed" + debugMessage "Done fixing broken patches..." + let newpatches = reverseFL ps :<: NilRL + debugMessage "Checking pristine against slurpy" - is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False + ftf <- filetypeFunction + is_same <- do diff <- treeDiff ftf pris newpris + return $ case diff of + NilFL -> True + _ -> False + `catchall` return False -- TODO is the latter condition needed? Does a broken patch imply pristine -- difference? Why, or why not? return (if is_same && patches_ok then RepositoryConsistent else if patches_ok - then BrokenPristine s' - else BrokenPatches s' newpatches) + then BrokenPristine newpris + else BrokenPatches newpris newpatches) cleanupRepositoryReplay :: Repository p -> IO () cleanupRepositoryReplay r = do @@ -152,9 +145,9 @@ rf_or_e <- identifyRepoFormat "." rf <- case rf_or_e of Left e -> fail e Right x -> return x - unless (format_has HashedInventory rf) $ + unless (formatHas HashedInventory rf) $ rm_recursive $ darcsdir ++ "/pristine.hashed" - when (format_has HashedInventory rf) $ do + when (formatHas HashedInventory rf) $ do current <- readHashedPristineRoot r clean_hashdir c HashedPristineDir $ catMaybes [current] @@ -163,3 +156,33 @@ where run = do st <- replayRepository' r opt f st + +checkIndex :: (RepoPatch p) => Repository p -> Bool -> IO Bool +checkIndex repo quiet = do + index <- updateIndex =<< readIndex repo + pristine <- expand =<< readRecordedAndPending repo + working <- expand =<< restrict pristine <$> readPlainTree "." + working_hashed <- darcsUpdateHashes working + let index_paths = [ p | (p, _) <- list index ] + working_paths = [ p | (p, _) <- list working ] + index_extra = index_paths \\ working_paths + working_extra = working_paths \\ index_paths + gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2) + gethashes p (Just i1) Nothing = (p, itemHash i1, NoHash) + gethashes p Nothing (Just i2) = (p, NoHash, itemHash i2) + gethashes p Nothing Nothing = error $ "Bad case at " ++ show p + mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ] + + format paths = unlines $ (map $ ((" " ++) . anchorPath "")) paths + mismatches_disp = unlines [ anchorPath "" p ++ + "\n index: " ++ BS.unpack (encodeBase16 h1) ++ + "\n working: " ++ BS.unpack (encodeBase16 h2) + | (p, h1, h2) <- mismatches ] + unless (quiet || null index_extra) $ + putStrLn $ "Extra items in index!\n" ++ format index_extra + unless (quiet || null working_extra) $ + putStrLn $ "Missing items in index!\n" ++ format working_extra + unless (quiet || null mismatches) $ + putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp + return $ null index_extra && null working_extra && null mismatches + diff --git a/src/Darcs/Repository/State.hs b/src/Darcs/Repository/State.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/State.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} + +-- Copyright (C) 2009 Petr Rockai +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, copy, +-- modify, merge, publish, distribute, sublicense, and/or sell copies +-- of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +-- SOFTWARE. + +module Darcs.Repository.State + ( restrictSubpaths, restrictBoring + -- * Diffs. + , unrecordedChanges, readPending, pendingChanges + -- * Trees. + , readRecorded, readUnrecorded, readRecordedAndPending + -- * Index. + , readIndex, invalidateIndex ) where + +import Prelude hiding ( filter ) +import Control.Monad( when ) +import Control.Applicative( (<$>) ) +import Data.Maybe( isJust ) +import Data.List( union ) +import Text.Regex( matchRegex ) + +import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile ) +import System.FilePath ( () ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + +import Darcs.Patch ( RepoPatch, Prim, invert, applyToTree, applyToFilepaths + , sortCoalesceFL ) +import Darcs.Patch.TouchesFiles ( choose_touching ) +import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal ) +import Darcs.Diff ( treeDiff ) +import Darcs.Flags ( DarcsFlag( LookForAdds ), willIgnoreTimes ) +import Darcs.Utils ( filterPaths ) + +import Darcs.Repository.InternalTypes ( Repository ) +import Darcs.Repository.LowLevel( read_pending ) +import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) + +import Darcs.Patch.FileName ( fn2fp ) +import Darcs.RepoPath ( SubPath, sp2fn ) + +import Storage.Hashed.AnchoredPath( AnchoredPath(..), anchorPath, floatPath, Name(..) ) +import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find ) +import Storage.Hashed.Plain( readPlainTree ) +import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize ) +import Storage.Hashed.Hash( Hash( NoHash ) ) +import qualified Storage.Hashed.Index as I + +#include "gadts.h" + +-- | From a repository and a list of SubPath's, construct a filter that can be +-- used on a Tree (recorded or unrecorded state) of this repository. This +-- constructed filter will take pending into account, so the subpaths will be +-- translated correctly relative to pending move patches. As an exception for +-- convenience, if the subpath list is empty, the filter constructed is an +-- identity. +restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] + -> IO (forall t m. FilterTree t m => t m -> t m) +restrictSubpaths repo subpaths = do + Sealed pending <- read_pending repo + let paths = map (fn2fp . sp2fn) subpaths + paths' = paths `union` applyToFilepaths pending paths + anchored = map floatPath paths' + restrictPaths :: FilterTree t m => t m -> t m + restrictPaths = if null subpaths then id else filter (filterPaths anchored) + return restrictPaths + +-- | Construct a Tree filter that removes any boring files the Tree might have +-- contained. Additionally, you should (in most cases) pass an (expanded) Tree +-- that corresponds to the recorded content of the repository. This is +-- important in the cases when the repository contains files that would be +-- boring otherwise. (If you pass emptyTree instead, such files will simply be +-- discarded by the filter, which is usually not what you want.) +-- +-- This function is most useful when you have a plain Tree corresponding to the +-- full working copy of the repository, including untracked +-- files. Cf. whatsnew, record --look-for-adds. NB. Assumes that our CWD is +-- the repository root. +restrictBoring :: forall t m. Tree m -> IO (FilterTree t m => t m -> t m) +restrictBoring guide = do + boring <- boringRegexps + let boring' (AnchoredPath (Name x:_)) | x == BSC.pack "_darcs" = False + boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring + where p' = anchorPath "" p + restrictTree :: FilterTree t m => t m -> t m + restrictTree = filter $ \p _ -> case find guide p of + Nothing -> boring' p + _ -> True + return restrictTree + +-- | For a repository and a list of paths (when empty, take everything) compute +-- a (forward) list of prims (i.e. a patch) going from the recorded state of +-- the repository (pristine) to the unrecorded state of the repository (the +-- working copy + pending). When a non-empty list of paths is given, exactly +-- the files that live under any of these paths in either recorded or +-- unrecorded will be included in the resulting patch. +-- +-- This also depends on the options given: with LookForAdds, we will include +-- any non-boring files (i.e. also those that do not exist in the "recorded" +-- state) in the working in the "unrecorded" state, and therefore they will +-- show up in the patches as addfiles. +-- +-- The IgnoreTimes option disables index usage completely -- for each file, we +-- read both the unrecorded and the recorded copy and run a diff on them. This +-- is very inefficient, although in extremely rare cases, the index could go +-- out of sync (file is modified, index is updated and file is modified again +-- within a single second). +unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) + -> [SubPath] -> IO (FL Prim C(r y)) +unrecordedChanges opts repo paths = do + (all_current, _) <- readPending repo + Sealed pending <- pendingChanges repo paths + + relevant <- restrictSubpaths repo paths + let getIndex = I.updateIndex =<< (relevant <$> readIndex repo) + current = relevant all_current + + working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of + (False, False) -> getIndex + (False, True) -> do + guide <- expand current + relevant <$> restrict guide <$> readPlainTree "." + (True, ignoretimes) -> do + index <- getIndex + nonboring <- restrictBoring index + plain <- relevant <$> nonboring <$> readPlainTree "." + return $ if ignoretimes then plain else plain `overlay` index + + ft <- filetypeFunction + diff <- treeDiff ft current working + return $ sortCoalesceFL (pending +>+ diff) + +-- | Obtains a Tree corresponding to the "recorded" state of the repository: +-- this is the same as the pristine cache, which is the same as the result of +-- applying all the repository's patches to an empty directory. +-- +-- Handles the plain and hashed pristine cases. Currently does not handle the +-- no-pristine case, as that requires replaying patches. Cf. 'readDarcsHashed' +-- and 'readPlainTree' in hashed-storage that are used to do the actual 'Tree' +-- construction. +readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO) +readRecorded _repo = do + let darcs = "_darcs" + h_inventory = darcs "hashed_inventory" + hashed <- doesFileExist h_inventory + if hashed + then do inv <- BS.readFile h_inventory + let linesInv = BSC.split '\n' inv + case linesInv of + [] -> return emptyTree + (pris_line:_) -> do + let hash = decodeDarcsHash $ BS.drop 9 pris_line + size = decodeDarcsSize $ BS.drop 9 pris_line + when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line + readDarcsHashed (darcs "pristine.hashed") (size, hash) + else do have_pristine <- doesDirectoryExist $ darcs "pristine" + have_current <- doesDirectoryExist $ darcs "current" + case (have_pristine, have_current) of + (True, _) -> readPlainTree $ darcs "pristine" + (False, True) -> readPlainTree $ darcs "current" + (_, _) -> fail "No pristine tree is available!" + +-- | Obtains a Tree corresponding to the "unrecorded" state of the repository: +-- the working tree plus the "pending" patch. +readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO) +readUnrecorded repo = readIndex repo >>= I.updateIndex + +readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO) +readRecordedAndPending repo = do + pristine <- readRecorded repo + Sealed pending <- pendingChanges repo [] + applyToTree pending pristine + +readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(r))) +readPending repo = + do Sealed pending <- read_pending repo + pristine <- readRecorded repo + catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do + putStrLn $ "Yikes, pending has conflicts! " ++ show err + putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy" + renameFile "_darcs/patches/pending" + "_darcs/patches/pending_buggy" + return (pristine, seal NilFL) + +pendingChanges :: (RepoPatch p) => Repository p C(r u t) + -> [SubPath] -> IO (Sealed (FL Prim C(r))) +pendingChanges repo paths = do + Sealed pending <- snd `fmap` readPending repo + let files = map (fn2fp . sp2fn) paths + pre_files = applyToFilepaths (invert pending) files + relevant = case paths of + [] -> seal pending + _ -> choose_touching pre_files pending + return relevant + +-- | Mark the existing index as invalid. This has to be called whenever the +-- listing of pristine changes and will cause darcs to update the index next +-- time it tries to read it. (NB. This is about files added and removed from +-- pristine: changes to file content in either pristine or working are handled +-- transparently by the index reading code.) +invalidateIndex :: t -> IO () +invalidateIndex _ = do + BS.writeFile "_darcs/index_invalid" BS.empty + +readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO I.Index +readIndex repo = do + invalid <- doesFileExist "_darcs/index_invalid" + exist <- doesFileExist "_darcs/index" + format_valid <- if exist + then I.indexFormatValid "_darcs/index" + else return True + when (exist && not format_valid) $ +#if mingw32_HOST_OS + renameFile "_darcs/index" "_darcs/index.old" +#else + removeFile "_darcs/index" +#endif + if (not exist || invalid || not format_valid) + then do pris <- readRecordedAndPending repo + idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris + when invalid $ removeFile "_darcs/index_invalid" + return idx + else I.readIndex "_darcs/index" darcsTreeHash diff --git a/src/Darcs/Resolution.lhs b/src/Darcs/Resolution.lhs --- a/src/Darcs/Resolution.lhs +++ b/src/Darcs/Resolution.lhs @@ -32,33 +32,35 @@ import Data.List ( zip4 ) import Control.Monad ( when ) -import Darcs.Patch ( RepoPatch, Prim, joinPatches, resolve_conflicts, +import Darcs.Diff( treeDiff ) +import Darcs.Patch ( RepoPatch, Prim, joinPatches, resolveConflicts, effect, - apply_to_filepaths, patchcontents, - invert, list_conflicted_files, commute ) + applyToFilepaths, patchcontents, + invert, listConflictedFiles, commute, applyToTree ) import Darcs.RepoPath ( toFilePath ) -import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+), - mapFL_FL, reverseRL, lengthFL ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), + mapFL_FL, reverseRL ) import CommandLine ( parseCmd ) import Darcs.Hopefully ( hopefully ) -import Darcs.Utils ( askUser ) -import Darcs.SlurpDirectory ( Slurpy, slurp, write_files ) +import Darcs.Utils ( askUser, filterFilePaths ) import Darcs.Patch.Set ( PatchSet ) -import Darcs.Diff ( unsafeDiff ) -import Darcs.Sealed ( Sealed(..) ) -import Darcs.Repository.Prefs ( filetype_function ) +import Darcs.Witnesses.Sealed ( seal ) +import Darcs.Witnesses.Sealed ( Sealed(..) ) +import Darcs.Repository.Prefs ( filetypeFunction ) import Exec ( exec, Redirect(..) ) import Darcs.Lock ( withTempDir ) import Darcs.External ( cloneTree ) -import Darcs.Patch.Apply ( apply_to_slurpy ) +import qualified Storage.Hashed.Tree as Tree +import Storage.Hashed ( writePlainTree, readPlainTree ) + --import Darcs.ColorPrinter ( traceDoc ) --import Printer ( greenText, ($$), Doc ) --import Darcs.Patch ( showPatch ) standard_resolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y)) -standard_resolution p = merge_list $ map head $ resolve_conflicts p +standard_resolution p = merge_list $ map head $ resolveConflicts p merge_list :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) merge_list patches = doml NilFL patches @@ -156,18 +158,19 @@ Note that the defaults file does not want quotes around the command. \begin{code} -external_resolution :: RepoPatch p => Slurpy -> String -> FL Prim C(x y) -> FL Prim C(x z) +external_resolution :: RepoPatch p => Tree.Tree IO -> String -> FL Prim C(x y) -> FL Prim C(x z) -> p C(y a) -> IO (Sealed (FL Prim C(a))) external_resolution s1 c p1 p2 pmerged = do - sa <- apply_to_slurpy (invert p1) s1 - sm <- apply_to_slurpy pmerged s1 - s2 <- apply_to_slurpy p2 sa - let nms = list_conflicted_files pmerged - nas = apply_to_filepaths (invert pmerged) nms - n1s = apply_to_filepaths p1 nas - n2s = apply_to_filepaths p2 nas + 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 ns = zip4 nas n1s n2s nms + write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "." in do former_dir <- getCurrentDirectory withTempDir "version1" $ \absd1 -> do @@ -190,13 +193,10 @@ let d2 = toFilePath absd2 write_files s2 n2s mapM_ (externally_resolve_file c da d1 d2 dm) ns - sc <- slurp dc - sfixed <- slurp dm - ftf <- filetype_function - case unsafeDiff [] ftf sc sfixed of - di -> lengthFL di `seq` return (Sealed di) - -- The `seq` above forces the two slurpies to be read before - -- we delete their directories. + sc <- readPlainTree dc + sfixed <- readPlainTree dm + ftf <- filetypeFunction + seal `fmap` treeDiff ftf sc sfixed externally_resolve_file :: String -> String -> String -> String -> String -> (FilePath, FilePath, FilePath, FilePath) @@ -226,9 +226,9 @@ Sealed NilFL patchset_conflict_resolutions (xs:<:_) = --traceDoc (greenText "looking at resolutions" $$ - -- (sh $ resolve_conflicts $ joinPatches $ + -- (sh $ resolveConflicts $ joinPatches $ -- mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $ - merge_list $ map head $ resolve_conflicts $ joinPatches $ + merge_list $ map head $ resolveConflicts $ joinPatches $ mapFL_FL (patchcontents . hopefully) $ reverseRL xs --where sh :: [[Sealed (FL Prim)]] -> Doc -- sh [] = greenText "no more conflicts" diff --git a/src/Darcs/RunCommand.hs b/src/Darcs/RunCommand.hs --- a/src/Darcs/RunCommand.hs +++ b/src/Darcs/RunCommand.hs @@ -26,30 +26,28 @@ import Darcs.Arguments ( DarcsFlag(..), help, - option_from_darcsoption, - list_options ) + optionFromDarcsoption, + listOptions ) import Darcs.ArgumentDefaults ( get_default_flags ) import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ), DarcsCommand, - command_name, - command_command, - command_prereq, - command_extra_arg_help, - command_extra_args, - command_argdefaults, - command_get_arg_possibilities, - command_options, command_alloptions, - disambiguate_commands, - get_command_help, get_command_mini_help, - get_subcommands, - extract_commands, - super_name, - subusage, chomp_newline ) -#ifdef HAVE_HASKELL_ZLIB + commandName, + commandCommand, + commandPrereq, + commandExtraArgHelp, + commandExtraArgs, + commandArgdefaults, + commandGetArgPossibilities, + commandOptions, commandAlloptions, + disambiguateCommands, + getCommandHelp, getCommandMiniHelp, + getSubcommands, + extractCommands, + superName, + subusage, chompNewline ) import Darcs.Commands.GZCRCs ( doCRCWarnings ) import Darcs.Global ( atexit ) -#endif -import Darcs.Commands.Help ( command_control_list ) +import Darcs.Commands.Help ( commandControlList ) import Darcs.External ( viewDoc ) import Darcs.Global ( setDebugMode, setSshControlMasterDisabled, setTimingsMode, setVerboseMode ) @@ -58,12 +56,13 @@ import Darcs.RepoPath ( getCurrentDirectory ) import Darcs.Test ( run_posthook, run_prehook ) import Darcs.Utils ( formatPath ) +import Data.List ( intersperse ) import Printer ( text ) import URL ( setDebugHTTP, setHTTPPipelining ) run_the_command :: String -> [String] -> IO () run_the_command cmd args = - either fail rtc $ disambiguate_commands command_control_list cmd args + either fail rtc $ disambiguateCommands commandControlList cmd args where rtc (CommandOnly c, as) = run_command Nothing c as rtc (SuperCommandOnly c, as) = run_raw_supercommand c as @@ -80,18 +79,18 @@ run_command msuper cmd args = do cwd <- getCurrentDirectory let options = opts1 ++ opts2 - (opts1, opts2) = command_options cwd cmd + (opts1, opts2) = commandOptions cwd cmd case getOpt Permute - (option_from_darcsoption cwd list_options++options) args of + (optionFromDarcsoption cwd listOptions++options) args of (opts,extra,[]) - | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd + | Help `elem` opts -> viewDoc $ text $ getCommandHelp msuper cmd | ListOptions `elem` opts -> do setProgressMode False - command_prereq cmd opts - file_args <- command_get_arg_possibilities cmd + commandPrereq cmd opts + file_args <- commandGetArgPossibilities cmd putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra - (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs) + (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs) where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts | otherwise = opts @@ -99,27 +98,27 @@ -> [DarcsFlag] -> [String] -> IO () consider_running msuper cmd opts old_extra = do cwd <- getCurrentDirectory - location <- command_prereq cmd opts + location <- commandPrereq cmd opts case location of Left complaint -> fail $ "Unable to " ++ - formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++ + formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++ " here.\n\n" ++ complaint Right () -> do specops <- add_command_defaults cmd opts - extra <- (command_argdefaults cmd) specops cwd old_extra + extra <- (commandArgdefaults cmd) specops cwd old_extra when (Disable `elem` specops) $ - fail $ "Command "++command_name cmd++" disabled with --disable option!" - if command_extra_args cmd < 0 + fail $ "Command "++commandName cmd++" disabled with --disable option!" + if commandExtraArgs cmd < 0 then runWithHooks specops extra - else if length extra > command_extra_args cmd + else if length extra > commandExtraArgs cmd then fail $ "Bad argument: `"++unwords extra++"'\n"++ - get_command_mini_help msuper cmd - else if length extra < command_extra_args cmd + getCommandMiniHelp msuper cmd + else if length extra < commandExtraArgs cmd then fail $ "Missing argument: " ++ nth_arg (length extra + 1) ++ - "\n" ++ get_command_mini_help msuper cmd + "\n" ++ getCommandMiniHelp msuper cmd else runWithHooks specops extra - where nth_arg n = nth_of n (command_extra_arg_help cmd) + where 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" @@ -135,52 +134,45 @@ when (HTTPPipelining `elem` os) $ setHTTPPipelining True when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False unless (SSHControlMaster `elem` os) setSshControlMasterDisabled -#ifdef HAVE_HASKELL_ZLIB unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os) -#endif -- actually run the command and its hooks preHookExitCode <- run_prehook os here if preHookExitCode /= ExitSuccess then exitWith preHookExitCode else do let fixFlag = FixFilePath here cwd - (command_command cmd) (fixFlag : os) ex + (commandCommand cmd) (fixFlag : os) ex postHookExitCode <- run_posthook os here exitWith postHookExitCode add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] add_command_defaults cmd already = do - let (opts1, opts2) = command_alloptions cmd - defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already + let (opts1, opts2) = commandAlloptions cmd + defaults <- get_default_flags (commandName cmd) (opts1 ++ opts2) already return $ already ++ defaults get_options_options :: [OptDescr DarcsFlag] -> String -get_options_options [] = "" -get_options_options (o:os) = - get_long_option o ++"\n"++ get_options_options os - -get_long_option :: OptDescr DarcsFlag -> String -get_long_option (Option _ [] _ _) = "" -get_long_option (Option a (o:os) b c) = "--"++o++ - get_long_option (Option a os b c) +get_options_options = concat . intersperse "\n" . concatMap goo + where + goo (Option _ os _ _) = map ("--"++) os run_raw_supercommand :: DarcsCommand -> [String] -> IO () run_raw_supercommand super [] = - fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n" + fail $ "Command '"++ commandName super ++"' requires subcommand!\n\n" ++ subusage super run_raw_supercommand super args = do cwd <- getCurrentDirectory case getOpt RequireOrder - (option_from_darcsoption cwd help++ - option_from_darcsoption cwd list_options) args of + (optionFromDarcsoption cwd help++ + optionFromDarcsoption cwd listOptions) args of (opts,_,[]) | Help `elem` opts -> - viewDoc $ text $ get_command_help Nothing super + viewDoc $ text $ getCommandHelp Nothing super | ListOptions `elem` opts -> do putStrLn "--help" - mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super) + mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super) | otherwise -> if Disable `elem` opts - then fail $ "Command " ++ (command_name super) ++ + then fail $ "Command " ++ (commandName super) ++ " disabled with --disable option!" else fail $ "Invalid subcommand!\n\n" ++ subusage super - (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs) + (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs) diff --git a/src/Darcs/Sealed.hs b/src/Darcs/Sealed.hs deleted file mode 100644 --- a/src/Darcs/Sealed.hs +++ /dev/null @@ -1,103 +0,0 @@ --- Copyright (C) 2007 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} -{-# LANGUAGE CPP #-} --- , MagicHash, GADTs #-} - -#include "gadts.h" - -module Darcs.Sealed ( Sealed(..), seal, unseal, mapSeal, -#ifndef GADT_WITNESSES - unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2, -#endif - Sealed2(..), seal2, unseal2, mapSeal2, - FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped, - unsealM, liftSM - ) where - -import GHC.Base ( unsafeCoerce# ) -import Darcs.Show - -data Sealed a where - Sealed :: a C(x ) -> Sealed a - -seal :: a C(x ) -> Sealed a -seal = Sealed - -data Sealed2 a where - Sealed2 :: !(a C(x y )) -> Sealed2 a - -seal2 :: a C(x y ) -> Sealed2 a -seal2 = Sealed2 - -data FlippedSeal a C(y) where - FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y) - -flipSeal :: a C(x y) -> FlippedSeal a C(y) -flipSeal = FlippedSeal - -#ifndef GADT_WITNESSES -unsafeUnseal :: Sealed a -> a -unsafeUnseal (Sealed a) = a - -unsafeUnflippedseal :: FlippedSeal a -> a -unsafeUnflippedseal (FlippedSeal a) = a - -unsafeUnseal2 :: Sealed2 a -> a -unsafeUnseal2 (Sealed2 a) = a -#endif - -seriouslyUnsafeUnseal :: Sealed a -> a C(()) -seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a - -unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b -unseal f x = f (seriouslyUnsafeUnseal x) - --- laziness property: --- unseal (const True) undefined == True - -unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b -unsealM m1 m2 = do sx <- m1 - unseal m2 sx - -liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b -liftSM f m = do sx <- m - return (unseal f sx) - -mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b -mapSeal f = unseal (seal . f) - -mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z) -mapFlipped f (FlippedSeal x) = FlippedSeal (f x) - -seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ()) -seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a - -unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b -unseal2 f a = f (seriouslyUnsafeUnseal2 a) - -mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b -mapSeal2 f = unseal2 (seal2 . f) - -unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b -unsealFlipped f (FlippedSeal a) = f a - -instance Show1 a => Show (Sealed a) where - showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x -instance Show2 a => Show (Sealed2 a) where - showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x diff --git a/src/Darcs/SelectChanges.hs b/src/Darcs/SelectChanges.hs --- a/src/Darcs/SelectChanges.hs +++ b/src/Darcs/SelectChanges.hs @@ -33,6 +33,7 @@ with_selected_last_changes_reversed, view_changes, with_selected_patch_from_repo, + filterOutConflicts, ) where import System.IO import Data.List ( intersperse ) @@ -43,33 +44,38 @@ import English ( Noun(..), englishNum ) import Darcs.Arguments ( showFriendly ) -import Darcs.Hopefully ( PatchInfoAnd, hopefully ) -import Darcs.Repository ( Repository, read_repo ) +import Darcs.Hopefully ( PatchInfoAnd, hopefully, n2pia ) +import Darcs.Repository ( Repository, read_repo, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Patchy, Prim, summary, - invert, list_touched_files, - commuteFL ) + invert, listTouchedFiles, + commuteFL, fromPrims, anonymous ) import qualified Darcs.Patch ( thing, things ) -import Darcs.Ordered ( FL(..), RL(..), (:>)(..), +import Darcs.Patch.Split ( Splitter(..) ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:||:)(..), (+>+), lengthFL, lengthRL, concatRL, mapFL_FL, spanFL, reverseFL, (+<+), mapFL, unsafeCoerceP ) -import Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps, - force_first, force_last, make_uncertain, tag, - get_choices, - separate_first_middle_from_last, - separate_first_from_middle_last, - patch_slot, - select_all_middles, - force_matching_last, - force_matching_first, make_everything_later, - TaggedPatch, tp_patch, Slot(..), +import Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps, + patchChoicesTpsSub, + forceFirst, forceLast, makeUncertain, tag, + getChoices, + separateFirstMiddleFromLast, + separateFirstFromMiddleLast, + patchSlot, + selectAllMiddles, + forceMatchingLast, + forceMatchingFirst, makeEverythingLater, + TaggedPatch, tpPatch, Slot(..), + substitute, ) +import Darcs.Patch.Permutations ( partitionConflictingFL, selfCommuter, commuterIdRL ) import Darcs.Patch.TouchesFiles ( deselect_not_touching, select_not_touching ) import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager ) -import Darcs.Match ( have_nonrange_match, match_a_patch, match_a_patchread ) -import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies), isInteractive ) -import Darcs.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2 ) +import Darcs.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread ) +import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies, SkipConflicts), isInteractive ) +import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2, Sealed(..) ) import Darcs.Utils ( askUser, promptCharFancy ) +import Darcs.Lock ( editText ) import Printer ( prefix, putDocLn ) #include "impossible.h" @@ -80,6 +86,7 @@ type WithPatches p a C(x y) = String -- jobname -> [DarcsFlag] -- opts + -> Maybe (Splitter p) -- for interactive editing -> FL p C(x y) -- patches to select among -> ((FL p :> FL p) C(x y) -> IO a) -- job -> IO a -- result of running job @@ -88,6 +95,7 @@ type WithPatchesToFiles p a C(x y) = String -- jobname -> [DarcsFlag] -- opts + -> Maybe (Splitter p) -- for interactive editing -> [FilePath] -- files -> FL p C(x y) -- patches to select among -> ((FL p :> FL p) C(x y) -> IO a) -- job @@ -107,8 +115,8 @@ triv _ _ _ = True iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p) -iswanted First opts p = match_a_patch opts . hopefully $ p -iswanted LastReversed opts p = match_a_patch opts . hopefully . invert $ p +iswanted First opts p = matchAPatch opts . hopefully $ p +iswanted LastReversed opts p = matchAPatch opts . hopefully . invert $ p iswanted Last _ _ = bug "don't support patch matching with Last in wasp" iswanted FirstReversed _ _ = bug "don't support patch matching with FirstReversed in wasp" @@ -133,34 +141,34 @@ -- | wasc and wasc_ are just shorthand for with_any_selected_changes wasc :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatches p a C(x y) -wasc mwch crit j o = wasc_ mwch crit j o [] +wasc mwch crit j o spl = wasc_ mwch crit j o spl [] wasc_ :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) wasc_ = with_any_selected_changes with_any_selected_changes :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -with_any_selected_changes Last crit jn opts fs = +with_any_selected_changes Last crit jn opts splitter fs = with_any_selected_changes_last (patches_to_consider_last' fs opts crit) - crit jn opts fs -with_any_selected_changes First crit jn opts fs = + crit jn opts splitter fs +with_any_selected_changes First crit jn opts splitter fs = with_any_selected_changes_first (patches_to_consider_first' fs opts crit) - crit jn opts fs -with_any_selected_changes FirstReversed crit jn opts fs = + crit jn opts splitter fs +with_any_selected_changes FirstReversed crit jn opts splitter fs = with_any_selected_changes_first_reversed (patches_to_consider_first_reversed' fs opts crit) - crit jn opts fs -with_any_selected_changes LastReversed crit jn opts fs = + crit jn opts splitter fs +with_any_selected_changes LastReversed crit jn opts splitter fs = with_any_selected_changes_last_reversed (patches_to_consider_last_reversed' fs opts crit) - crit jn opts fs + crit jn opts splitter fs view_changes :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () view_changes opts ps = do text_view opts Nothing 0 NilRL init_tps init_pc return () - where (init_pc, init_tps) = patch_choices_tps ps + where (init_pc, init_tps) = patchChoicesTps ps data KeyPress a = KeyPress { kp :: Char , kpHelp :: String } @@ -183,7 +191,7 @@ -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ()) -> IO () with_selected_patch_from_repo jn repository opts job = do p_s <- read_repo repository - sp <- wspfr jn (match_a_patchread opts) + sp <- wspfr jn (matchAPatchread opts) (concatRL p_s) NilFL case sp of Just (FlippedSeal (skipped :> selected)) -> job (skipped :> selected) @@ -228,69 +236,76 @@ repeat_this where jn_cap = (toUpper $ head jn) : tail jn +-- After selecting with a splitter, the results may not be canonical +canonizeWith :: Maybe (Splitter p) -> (FL p :> FL p) C(x y) -> (FL p :> FL p) C(x y) +canonizeWith Nothing xy = xy +canonizeWith (Just spl) (x :> y) = canonizeSplit spl x :> canonizeSplit spl y + with_any_selected_changes_last :: forall p a C(x y). Patchy p => (FL p C(x y) -> (FL p :> FL p) C(x y)) -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_last p2c crit jobname opts _ ps job = +with_any_selected_changes_last p2c crit jobname opts splitter _ ps job = case p2c ps of ps_to_consider :> other_ps -> if not $ isInteractive opts then job $ ps_to_consider :> other_ps - else do pc <- tentatively_text_select "" jobname (Noun "patch") Last crit + else do pc <- tentatively_text_select splitter "" jobname (Noun "patch") Last crit opts ps_len 0 NilRL init_tps init_pc - job $ selected_patches_last rejected_ps pc + job $ canonizeWith splitter $ selected_patches_last rejected_ps pc where rejected_ps = ps_to_consider ps_len = lengthFL init_tps - (init_pc, init_tps) = patch_choices_tps $ other_ps + (init_pc, init_tps) = patchChoicesTps $ other_ps with_any_selected_changes_first :: forall p a C(x y). Patchy p => (FL p C(x y) -> (FL p :> FL p) C(x y)) -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_first p2c crit jobname opts _ ps job = +with_any_selected_changes_first p2c crit jobname opts splitter _ ps job = case p2c ps of ps_to_consider :> other_ps -> if not $ isInteractive opts then job $ ps_to_consider :> other_ps - else do pc <- tentatively_text_select "" jobname (Noun "patch") First crit + else do pc <- tentatively_text_select splitter "" jobname (Noun "patch") First crit opts ps_len 0 NilRL init_tps init_pc - job $ selected_patches_first rejected_ps pc + job $ canonizeWith splitter $ selected_patches_first rejected_ps pc where rejected_ps = other_ps ps_len = lengthFL init_tps - (init_pc, init_tps) = patch_choices_tps $ ps_to_consider + (init_pc, init_tps) = patchChoicesTps $ ps_to_consider with_any_selected_changes_first_reversed :: forall p a C(x y). Patchy p => (FL p C(x y) -> (FL p :> FL p) C(y x)) -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_first_reversed p2c crit jobname opts _ ps job = +with_any_selected_changes_first_reversed p2c crit jobname opts splitter _ ps job = case p2c ps of ps_to_consider :> other_ps -> if not $ isInteractive opts then job $ invert other_ps :> invert ps_to_consider - else do pc <- tentatively_text_select "" jobname (Noun "patch") FirstReversed crit + else do pc <- tentatively_text_select splitter + "" jobname (Noun "patch") FirstReversed crit opts ps_len 0 NilRL init_tps init_pc - job $ selected_patches_first_reversed rejected_ps pc + job $ canonizeWith splitter $ selected_patches_first_reversed rejected_ps pc where rejected_ps = ps_to_consider ps_len = lengthFL init_tps - (init_pc, init_tps) = patch_choices_tps other_ps + (init_pc, init_tps) = patchChoicesTps other_ps with_any_selected_changes_last_reversed :: forall p a C(x y). Patchy p => (FL p C(x y) -> (FL p :> FL p) C(y x)) -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_last_reversed p2c crit jobname opts _ ps job = +with_any_selected_changes_last_reversed p2c crit jobname opts splitter _ ps job = case p2c ps of ps_to_consider :> other_ps -> if not $ isInteractive opts then job $ invert other_ps :> invert ps_to_consider - else do pc <- tentatively_text_select "" jobname (Noun "patch") LastReversed crit + else do pc <- tentatively_text_select splitter + "" jobname (Noun "patch") LastReversed crit opts ps_len 0 NilRL init_tps init_pc - job $ selected_patches_last_reversed rejected_ps pc + job $ canonizeWith splitter $ selected_patches_last_reversed rejected_ps pc where rejected_ps = other_ps ps_len = lengthFL init_tps - (init_pc, init_tps) = patch_choices_tps ps_to_consider + (init_pc, init_tps) = patchChoicesTps ps_to_consider patches_to_consider_first' :: Patchy p @@ -301,16 +316,16 @@ -> (FL p :> FL p) C(x y) patches_to_consider_first' fs opts crit ps = let deselect_unwanted pc = - if have_nonrange_match opts + if haveNonrangeMatch opts then if DontGrabDeps `elem` opts - then force_matching_last (not.iswanted_) pc - else make_everything_later $ force_matching_first iswanted_ pc + then forceMatchingLast (not.iswanted_) pc + else makeEverythingLater $ forceMatchingFirst iswanted_ pc else pc - iswanted_ = crit First opts . tp_patch - in if null fs && not (have_nonrange_match opts) + iswanted_ = crit First opts . tpPatch + in if null fs && not (haveNonrangeMatch opts) then ps :> NilFL - else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs - $ deselect_unwanted $ patch_choices ps + else tp_patches $ separateFirstMiddleFromLast $ deselect_not_touching fs + $ deselect_unwanted $ patchChoices ps patches_to_consider_last' :: Patchy p => [FilePath] -- ^ files @@ -320,15 +335,15 @@ -> (FL p :> FL p) C(x y) patches_to_consider_last' fs opts crit ps = let deselect_unwanted pc = - if have_nonrange_match opts + if haveNonrangeMatch opts then if DontGrabDeps `elem` opts - then force_matching_last (not.iswanted_) pc - else make_everything_later $ force_matching_first iswanted_ pc + then forceMatchingLast (not.iswanted_) pc + else makeEverythingLater $ forceMatchingFirst iswanted_ pc else pc - iswanted_ = crit Last opts . tp_patch - in if null fs && not (have_nonrange_match opts) + iswanted_ = crit Last opts . tpPatch + in if null fs && not (haveNonrangeMatch opts) then NilFL :> ps - else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices ps of + else case getChoices $ select_not_touching fs $ deselect_unwanted $ patchChoices ps of fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc patches_to_consider_first_reversed' :: Patchy p @@ -339,15 +354,15 @@ -> (FL p :> FL p) C(y x) patches_to_consider_first_reversed' fs opts crit ps = let deselect_unwanted pc = - if have_nonrange_match opts + if haveNonrangeMatch opts then if DontGrabDeps `elem` opts - then force_matching_last (not.iswanted_) pc - else make_everything_later $ force_matching_first iswanted_ pc + then forceMatchingLast (not.iswanted_) pc + else makeEverythingLater $ forceMatchingFirst iswanted_ pc else pc - iswanted_ = crit FirstReversed opts . tp_patch - in if null fs && not (have_nonrange_match opts) + iswanted_ = crit FirstReversed opts . tpPatch + in if null fs && not (haveNonrangeMatch opts) then NilFL :> (invert ps) - else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices $ invert ps of + else case getChoices $ select_not_touching fs $ deselect_unwanted $ patchChoices $ invert ps of fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc patches_to_consider_last_reversed' :: Patchy p @@ -358,55 +373,55 @@ -> (FL p :> FL p) C(y x) patches_to_consider_last_reversed' fs opts crit ps = let deselect_unwanted pc = - if have_nonrange_match opts + if haveNonrangeMatch opts then if DontGrabDeps `elem` opts - then force_matching_last (not.iswanted_) pc - else make_everything_later $ force_matching_first iswanted_ pc + then forceMatchingLast (not.iswanted_) pc + else makeEverythingLater $ forceMatchingFirst iswanted_ pc else pc - iswanted_ = crit LastReversed opts . tp_patch + iswanted_ = crit LastReversed opts . tpPatch in - if null fs && not (have_nonrange_match opts) + if null fs && not (haveNonrangeMatch opts) then (invert ps) :> NilFL - else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs - $ deselect_unwanted $ patch_choices $ invert ps + else tp_patches $ separateFirstMiddleFromLast $ deselect_not_touching fs + $ deselect_unwanted $ patchChoices $ invert ps -- | Returns the results of a patch selection user interaction selected_patches_last :: Patchy p => FL p C(x y) -> PatchChoices p C(y z) -> (FL p :> FL p) C(x z) selected_patches_last other_ps pc = - case get_choices pc of - fc :> mc :> lc -> other_ps +>+ mapFL_FL tp_patch (fc +>+ mc) :> mapFL_FL tp_patch lc + case getChoices pc of + fc :> mc :> lc -> other_ps +>+ mapFL_FL tpPatch (fc +>+ mc) :> mapFL_FL tpPatch lc selected_patches_first :: Patchy p => FL p C(y z) -> PatchChoices p C(x y) -> (FL p :> FL p) C(x z) selected_patches_first other_ps pc = - case separate_first_from_middle_last pc of - xs :> ys -> mapFL_FL tp_patch xs :> mapFL_FL tp_patch ys +>+ other_ps + case separateFirstFromMiddleLast pc of + xs :> ys -> mapFL_FL tpPatch xs :> mapFL_FL tpPatch ys +>+ other_ps selected_patches_last_reversed :: Patchy p => FL p C(y x) -> PatchChoices p C(z y) -> (FL p :> FL p) C(x z) selected_patches_last_reversed other_ps pc = - case separate_first_from_middle_last pc of - xs :> ys -> invert (mapFL_FL tp_patch ys +>+ other_ps) :> invert (mapFL_FL tp_patch xs) + case separateFirstFromMiddleLast pc of + xs :> ys -> invert (mapFL_FL tpPatch ys +>+ other_ps) :> invert (mapFL_FL tpPatch xs) selected_patches_first_reversed :: Patchy p => FL p C(z y) -> PatchChoices p C(y x) -> (FL p :> FL p) C(x z) selected_patches_first_reversed other_ps pc = - case get_choices pc of - fc :> mc :> lc -> invert (mapFL_FL tp_patch lc) :> invert (other_ps +>+ mapFL_FL tp_patch (fc +>+ mc)) + case getChoices pc of + fc :> mc :> lc -> invert (mapFL_FL tpPatch lc) :> invert (other_ps +>+ mapFL_FL tpPatch (fc +>+ mc)) -text_select :: forall p C(x y z). Patchy p => String -> WhichChanges +text_select :: forall p C(x y z). Patchy p => Maybe (Splitter p) -> String -> WhichChanges -> MatchCriterion p -> [DarcsFlag] -> Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) -> PatchChoices p C(x z) -> IO ((PatchChoices p) C(x z)) -text_select _ _ _ _ _ _ _ NilFL pc = return pc -text_select jn whichch crit opts n_max n +text_select _ _ _ _ _ _ _ _ NilFL pc = return pc +text_select splitter jn whichch crit opts n_max n tps_done tps_todo@(tp:>:tps_todo') pc = do (printFriendly opts) `unseal2` viewp repeat_this -- prompt the user where - do_next_action ja je = tentatively_text_select ja jn je whichch crit opts + do_next_action ja je = tentatively_text_select splitter ja jn je whichch crit opts n_max (n+1) (tp:<:tps_done) tps_todo' do_next = do_next_action "" (Noun "patch") @@ -414,6 +429,7 @@ helper = undefined thing = Darcs.Patch.thing (helper pc) things = Darcs.Patch.things (helper pc) + split = splitter >>= flip applySplitter (tpPatch tp) options_basic = [ KeyPress 'y' (jn++" this "++thing) , KeyPress 'n' ("don't "++jn++" it") @@ -434,7 +450,12 @@ options_nav = [ KeyPress 'j' ("skip to next "++thing) , KeyPress 'k' ("back up to previous "++thing) ] + options_split + | Just _ <- split + = [ KeyPress 'e' ("interactively edit this "++thing) ] + | otherwise = [] options = [options_basic] + ++ [options_split] ++ (if is_single_file_patch then [options_file] else []) ++ [options_view ++ if Summary `elem` opts then [] else options_summary] @@ -448,18 +469,28 @@ case yorn of 'y' -> do_next $ force_yes (tag tp) pc 'n' -> do_next $ force_no (tag tp) pc - 'w' -> do_next $ make_uncertain (tag tp) pc + 'w' -> do_next $ makeUncertain (tag tp) pc + 'e' | Just (text, parse) <- split + -> do newText <- editText "darcs-patch-edit" text + case parse newText of + Nothing -> repeat_this + Just ps -> do let tps_new = snd $ patchChoicesTpsSub (Just (tag tp)) ps + text_select splitter + jn whichch crit opts (n_max + lengthFL tps_new - 1) n + tps_done (tps_new+>+tps_todo') + (substitute (seal2 (tp :||: tps_new)) pc) + 's' -> do_next_action "Skipped" (Noun "change") $ skip_file 'f' -> do_next_action "Included" (Noun "change") $ do_file 'v' -> printPatch `unseal2` viewp >> repeat_this 'p' -> printPatchPager `unseal2` viewp >> repeat_this - 'l' -> do let selected = case get_choices pc of + 'l' -> do let selected = case getChoices pc of (first_chs:>_:>last_chs) -> if whichch == Last || whichch == FirstReversed then map_patches last_chs else map_patches first_chs map_patches = mapFL (\a -> - (showFriendly opts) `unseal2` (seal2 $ tp_patch a)) + (showFriendly opts) `unseal2` (seal2 $ tpPatch a)) putStrLn $ "---- Already selected "++things++" ----" mapM_ putDocLn $ selected putStrLn $ "---- end of already selected "++things++" ----" @@ -469,38 +500,38 @@ repeat_this 'd' -> return pc 'a' -> do ask_confirmation - return $ select_all_middles (whichch == Last || whichch == FirstReversed) pc + return $ selectAllMiddles (whichch == Last || whichch == FirstReversed) pc 'q' -> do putStrLn $ jn_cap++" cancelled." exitWith $ ExitSuccess 'j' -> case tps_todo' of NilFL -> -- May as well work out the length now we have all -- the patches in memory - text_select jn whichch crit opts + text_select splitter jn whichch crit opts n_max n tps_done tps_todo pc - _ -> text_select jn whichch crit opts + _ -> text_select splitter jn whichch crit opts n_max (n+1) (tp:<:tps_done) tps_todo' pc 'k' -> case tps_done of NilRL -> repeat_this (tp':<:tps_done') -> - text_select jn whichch crit opts + text_select splitter jn whichch crit opts n_max (n-1) tps_done' (tp':>:tps_todo) pc - 'c' -> text_select jn whichch crit opts + 'c' -> text_select splitter jn whichch crit opts n_max n tps_done tps_todo pc _ -> do putStrLn $ helpFor jn options repeat_this - force_yes = if whichch == Last || whichch == FirstReversed then force_last else force_first - force_no = if whichch == Last || whichch == FirstReversed then force_first else force_last + force_yes = if whichch == Last || whichch == FirstReversed then forceLast else forceFirst + force_no = if whichch == Last || whichch == FirstReversed then forceFirst else forceLast patches_to_skip = (tag tp:) $ catMaybes - $ mapFL (\tp' -> if list_touched_files tp' == touched_files + $ mapFL (\tp' -> if listTouchedFiles tp' == touched_files then Just (tag tp') else Nothing) tps_todo' skip_file = foldr force_no pc patches_to_skip do_file = foldr force_yes pc patches_to_skip - the_default = get_default (whichch == Last || whichch == FirstReversed) $ patch_slot tp pc + the_default = get_default (whichch == Last || whichch == FirstReversed) $ patchSlot tp pc jn_cap = (toUpper $ head jn) : tail jn - touched_files = list_touched_files $ tp_patch tp + touched_files = listTouchedFiles $ tpPatch tp is_single_file_patch = length touched_files == 1 - viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tp_patch tp) else seal2 $ tp_patch tp + viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tpPatch tp) else seal2 $ tpPatch tp ask_confirmation = if jn `elem` ["unpull", "unrecord", "obliterate"] then do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " @@ -512,10 +543,10 @@ text_view :: forall p C(x y u r s). Patchy p => [DarcsFlag] -> Maybe Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y u) -> PatchChoices p C(r s) -> IO ((PatchChoices p) C(r s)) -text_view _ _ _ _ NilFL _ = return $ patch_choices $ unsafeCoerceP NilFL --return pc +text_view _ _ _ _ NilFL _ = return $ patchChoices $ unsafeCoerceP NilFL --return pc text_view opts n_max n tps_done tps_todo@(tp:>:tps_todo') pc = do - printFriendly opts (tp_patch tp) + printFriendly opts (tpPatch tp) putStr "\n" repeat_this -- prompt the user where @@ -556,11 +587,11 @@ repeat_this = do yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h" case yorn of - 'y' -> printPatch (tp_patch tp) >> next_patch + 'y' -> printPatch (tpPatch tp) >> next_patch 'n' -> next_patch - 'v' -> printPatch (tp_patch tp) >> repeat_this - 'p' -> printPatchPager (tp_patch tp) >> repeat_this - 'x' -> do putDocLn $ prefix " " $ summary (tp_patch tp) + 'v' -> printPatch (tpPatch tp) >> repeat_this + 'p' -> printPatchPager (tpPatch tp) >> repeat_this + 'x' -> do putDocLn $ prefix " " $ summary (tpPatch tp) repeat_this 'q' -> exitWith ExitSuccess 'k' -> prev_patch @@ -571,25 +602,25 @@ repeat_this count_n_max | isJust n_max = n_max | otherwise = Just $ lengthFL tps_todo + lengthRL tps_done -tentatively_text_select :: Patchy p => String -> String -> Noun -> WhichChanges +tentatively_text_select :: Patchy p => Maybe (Splitter p) -> String -> String -> Noun -> WhichChanges -> MatchCriterion p -> [DarcsFlag] -> Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) -> PatchChoices p C(x z) -> IO ((PatchChoices p) C(x z)) -tentatively_text_select _ _ _ _ _ _ _ _ _ NilFL pc = return pc -tentatively_text_select jobaction jobname jobelement whichch crit +tentatively_text_select _ _ _ _ _ _ _ _ _ _ NilFL pc = return pc +tentatively_text_select splitter jobaction jobname jobelement whichch crit opts n_max n ps_done ps_todo pc = - case spanFL (\p -> decided $ patch_slot p pc) ps_todo of + case spanFL (\p -> decided $ patchSlot p pc) ps_todo of skipped :> unskipped -> do when (numSkipped > 0) show_skipped let (boringThenInteresting) = if DontPromptForDependencies `elem` opts - then spanFL (not.(crit whichch opts).tp_patch) unskipped + then spanFL (not.(crit whichch opts).tpPatch) unskipped else NilFL :> unskipped case boringThenInteresting of boring :> interesting -> do let numNotConsidered = lengthFL boring + numSkipped - text_select jobname whichch crit opts n_max (n + numNotConsidered) + text_select splitter jobname whichch crit opts n_max (n + numNotConsidered) (reverseFL boring +<+ reverseFL skipped +<+ ps_done) interesting pc where numSkipped = lengthFL skipped @@ -601,7 +632,7 @@ _action_ = if (length jobaction) == 0 then "Skipped" else jobaction _elem_ = englishNum numSkipped jobelement showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO () - showskippedpatch (tp:>:tps) = (putDocLn $ prefix " " $ summary (tp_patch tp)) >> showskippedpatch tps + showskippedpatch (tp:>:tps) = (putDocLn $ prefix " " $ summary (tpPatch tp)) >> showskippedpatch tps showskippedpatch NilFL = return () decided :: Slot -> Bool @@ -617,4 +648,26 @@ tp_patches :: (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) -> (FL p :> FL p) C(x y) -tp_patches (x:>y) = mapFL_FL tp_patch x :> mapFL_FL tp_patch y +tp_patches (x:>y) = mapFL_FL tpPatch x :> mapFL_FL tpPatch y + +-- |Optionally remove any patches (+dependencies) from a sequence that +-- conflict with the recorded or unrecorded changes in a repo +filterOutConflicts :: RepoPatch p + => [DarcsFlag] -- ^Command-line options. Only 'SkipConflicts' is + -- significant; filtering will happen iff it is present + -> RL (PatchInfoAnd p) C(x r) -- ^Recorded patches from repository, starting from + -- same context as the patches to filter + -> Repository p C(r u t) -- ^Repository itself, used for grabbing unrecorded changes + -> FL (PatchInfoAnd p) C(x z) -- ^Patches to filter + -> IO (Bool, Sealed (FL (PatchInfoAnd p) C(x))) -- ^(True iff any patches were removed, possibly filtered patches) +filterOutConflicts opts us repository them + | SkipConflicts `elem` opts + = do let commuter = commuterIdRL selfCommuter + unrec <- fmap n2pia . (anonymous . fromPrims) =<< unrecordedChanges [] repository [] + them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us) + return (check rest, Sealed them') + | otherwise + = return (False, Sealed them) + where check :: FL p C(a b) -> Bool + check NilFL = False + check _ = True diff --git a/src/Darcs/Show.hs b/src/Darcs/Show.hs deleted file mode 100644 --- a/src/Darcs/Show.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} -{-# LANGUAGE CPP #-} - -module Darcs.Show(Show1(..), Show2(..), showOp2, app_prec) where - -#include "gadts.h" - -class Show1 a where - show1 :: a C(x) -> String - show1 x = showsPrec1 0 x "" - showsPrec1 :: Int -> a C(x) -> ShowS - showsPrec1 _ x s = show1 x ++ s - -class Show2 a where - show2 :: a C(x y) -> String - show2 x = showsPrec2 0 x "" - showsPrec2 :: Int -> a C(x y) -> ShowS - showsPrec2 _ x s = show2 x ++ s - -showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String -showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x . - showString opstr . showsPrec2 (prec + 1) y - -app_prec :: Int -app_prec = 10 diff --git a/src/Darcs/SlurpDirectory.hs b/src/Darcs/SlurpDirectory.hs --- a/src/Darcs/SlurpDirectory.hs +++ b/src/Darcs/SlurpDirectory.hs @@ -21,7 +21,6 @@ FileContents, undefined_time, undefined_size, doesFileReallyExist, doesDirectoryReallyExist, isFileReallySymlink, - wait_a_moment, is_dir, is_file, get_slurp, slurp_name, slurp_has, slurp_has_anycase, slurp_hasfile, slurp_hasdir, diff --git a/src/Darcs/SlurpDirectory/Internal.hs b/src/Darcs/SlurpDirectory/Internal.hs --- a/src/Darcs/SlurpDirectory/Internal.hs +++ b/src/Darcs/SlurpDirectory/Internal.hs @@ -30,7 +30,7 @@ slurp_removefile, slurp_removedir, slurp_remove, slurp_modfile, slurp_hasfile, slurp_hasdir, - slurp_has_anycase, wait_a_moment, undefined_time, + slurp_has_anycase, undefined_time, undefined_size, slurp_has, list_slurpy, list_slurpy_files, get_path_list, @@ -56,7 +56,6 @@ fileSize, isRegularFile, isDirectory, isSymbolicLink ) -import System.Posix ( sleep ) import Data.Maybe ( catMaybes, isJust, maybeToList ) import Data.Map (Map) import qualified Data.Map as Map @@ -69,7 +68,7 @@ import qualified Data.ByteString as B import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir, - own_name, super_name ) + own_name, superName ) #if mingw32_HOST_OS import Data.Int ( Int64 ) #else @@ -183,7 +182,7 @@ write_file s fn = case withSlurpy s $ smReadFilePS fn of Left err -> fail err Right (_, c) -> do - ensureDirectories (super_name fn) + ensureDirectories (superName fn) mWriteFilePS fn c try_write_file :: Slurpy -> FilePath -> IO () @@ -199,7 +198,7 @@ isPar <- mDoesDirectoryExist d if isPar then return () - else ensureDirectories (super_name d) >> (mCreateDirectory d) + else ensureDirectories (superName d) >> (mCreateDirectory d) write_files :: Slurpy -> [FilePath] -> IO () write_files s fps = mapM_ (try_write_file s) fps @@ -256,7 +255,7 @@ insertSlurpy :: FileName -> Slurpy -> SlurpMonad () insertSlurpy f news = mksm $ \s -> - if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s) + if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (superName f) s) then Left $ "Error creating file "++fn2fp f else Right (addslurp f news s, ()) @@ -341,13 +340,6 @@ undef_time_size :: (Maybe String, EpochTime, FileOffset) undef_time_size = (Nothing, undefined_time, undefined_size) -wait_a_moment :: IO () -wait_a_moment = do { sleep 1; return () } - -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it - -- returns an integer just like sleep(3) does. To stay compatible - -- with older versions, though, we just ignore sleep's return - -- value. Hackery, like I said. - isFileReallySymlink :: FilePath -> IO Bool isFileReallySymlink f = do fs <- getSymbolicLinkStatus f return (isSymbolicLink fs) @@ -536,7 +528,7 @@ slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy slurp_move f f' s = - if not (slurp_has (fn2fp f') s) && slurp_hasdir (super_name f') s + if not (slurp_has (fn2fp f') s) && slurp_hasdir (superName f') s then case get_slurp f s of Nothing -> Nothing Just sf -> @@ -549,7 +541,7 @@ addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy addslurp fname s s' = - case get_slurp_context (super_name fname) s' of + case get_slurp_context (superName fname) s' of Just (ctx, Slurpy d (SlurpDir _ c)) -> ctx (Slurpy d (SlurpDir Nothing (uncurry Map.insert (slurpy_to_pair s) c))) _ -> s' @@ -567,7 +559,7 @@ slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy slurp_adddir f s = - if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s) + if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (superName f) s) then Nothing else Just $ addslurp f (Slurpy (own_name f) (SlurpDir Nothing Map.empty)) s diff --git a/src/Darcs/Test.lhs b/src/Darcs/Test.lhs --- a/src/Darcs/Test.lhs +++ b/src/Darcs/Test.lhs @@ -27,8 +27,8 @@ import Darcs.Arguments ( DarcsFlag( Quiet, AskPosthook, AskPrehook ), - get_posthook_cmd, get_prehook_cmd ) -import Darcs.Repository.Prefs ( get_prefval ) + getPosthookCmd, getPrehookCmd ) +import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Utils ( askUser ) import System.IO ( hPutStrLn, stderr ) \end{code} @@ -61,7 +61,7 @@ get_test opts = let putInfo s = when (not $ Quiet `elem` opts) $ putStr s in do - testline <- get_prefval "test" + testline <- getPrefval "test" return $ case testline of Nothing -> return ExitSuccess @@ -78,13 +78,14 @@ withCurrentDirectory repodir $ run_hook opts "Posthook" ph get_posthook :: [DarcsFlag] -> IO (Maybe String) -get_posthook opts = case get_posthook_cmd opts of +get_posthook opts = case getPosthookCmd opts of Nothing -> return Nothing Just command -> if AskPosthook `elem` opts - then do yorn <- askUser ("\nThe following command is set to execute.\n"++ + then do putStr ("\nThe following command is set to execute.\n"++ "Execute the following command now (yes or no)?\n"++ command++"\n") + yorn <- askUser "" case yorn of ('y':_) -> return $ Just command _ -> do putStrLn "Posthook cancelled..." return Nothing @@ -95,13 +96,14 @@ withCurrentDirectory repodir $ run_hook opts "Prehook" ph get_prehook :: [DarcsFlag] -> IO (Maybe String) -get_prehook opts = case get_prehook_cmd opts of +get_prehook opts = case getPrehookCmd opts of Nothing -> return Nothing Just command -> if AskPrehook `elem` opts - then do yorn <- askUser ("\nThe following command is set to execute.\n"++ + then do putStr ("\nThe following command is set to execute.\n"++ "Execute the following command now (yes or no)?\n"++ command++"\n") + yorn <- askUser "" case yorn of ('y':_) -> return $ Just command _ -> do putStrLn "Prehook cancelled..." return Nothing diff --git a/src/Darcs/Test/Patch/Check.hs b/src/Darcs/Test/Patch/Check.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Test/Patch/Check.hs @@ -0,0 +1,333 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +module Darcs.Test.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists, + remove_file, remove_dir, create_file, create_dir, + insert_line, delete_line, is_valid, do_verbose_check, + file_empty, + check_move, modify_file, FileContents(..) + ) where + +import System.IO.Unsafe ( unsafePerformIO ) +import qualified Data.ByteString as B (ByteString) +import Data.List ( isPrefixOf, inits ) +import Control.Monad.State ( State, evalState, runState ) +import Control.Monad.State.Class ( get, put, modify ) +-- use Map, not IntMap, because Map has mapKeys and IntMap hasn't +import Data.Map ( Map ) +import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null ) +import System.FilePath ( joinPath, splitDirectories ) + +-- | File contents are represented by a map from line numbers to line contents. +-- If for a certain line number, the line contents are Nothing, that means +-- that we are sure that that line exists, but we don't know its contents. +-- We must also store the greatest line number that is known to exist in a +-- file, to be able to exclude the possibility of it being empty without +-- knowing its contents. +data FileContents = FC { fc_lines :: Map Int B.ByteString + , fc_maxline :: Int + } deriving (Eq, Show) +data Prop = FileEx String | DirEx String | NotEx String + | FileLines String FileContents + deriving (Eq) +-- | A @KnownState@ is a simulated repository state. The repository is either +-- inconsistent, or it has two lists of properties: one list with properties +-- that hold for this repo, and one with properties that do not hold for this +-- repo. These two lists may not have any common elements: if they had, the +-- repository would be inconsistent. +data KnownState = P [Prop] [Prop] + | Inconsistent + deriving (Show) +instance Show Prop where + show (FileEx f) = "FileEx "++f + show (DirEx d) = "DirEx "++d + show (NotEx f) = "NotEx"++f + show (FileLines f l) = "FileLines "++f++": "++show l + +-- | PatchCheck is a state monad with a simulated repository state +type PatchCheck = State KnownState + +-- | The @FileContents@ structure for an empty file +empty_filecontents :: FileContents +empty_filecontents = FC M.empty 0 + +-- | Returns a given value if the repository state is inconsistent, and performs +-- a given action otherwise. +handle_inconsistent :: a -- ^ The value to return if the state is inconsistent + -> PatchCheck a -- ^ The action to perform otherwise + -> PatchCheck a +handle_inconsistent v a = do state <- get + case state of + Inconsistent -> return v + _ -> a + +do_check :: PatchCheck a -> a +do_check p = evalState p (P [] []) + +-- | Run a check, and print the final repository state +do_verbose_check :: PatchCheck a -> a +do_verbose_check p = + case runState p (P [] []) of + (b, pc) -> unsafePerformIO $ do putStrLn $ show pc + return b + +-- | Returns true if the current repository state is not inconsistent +is_valid :: PatchCheck Bool +is_valid = handle_inconsistent False (return True) + +has :: Prop -> [Prop] -> Bool +has _ [] = False +has k (k':ks) = k == k' || has k ks + +modify_file :: String + -> (Maybe FileContents -> Maybe FileContents) + -> PatchCheck Bool +modify_file f change = do + file_exists f + c <- file_contents f + case change c of + Nothing -> assert_not $ FileEx f -- shorthand for "FAIL" + Just c' -> do set_contents f c' + is_valid + +insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool +insert_line f n l = do + c <- file_contents f + case c of + Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent + Just c' -> do + let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c') + lines'' = M.insert n l lines' + maxline' = max n (fc_maxline c') + set_contents f (FC lines'' maxline') + return True + +-- deletes a line from a hunk patch (third argument) in the given file (first +-- argument) at the given line number (second argument) +delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool +delete_line f n l = do + c <- file_contents f + case c of + Nothing -> assert_not $ FileEx f + Just c' -> + let flines = fc_lines c' + flines' = M.mapKeys (\k -> if k > n then k-1 else k) + (M.delete n flines) + maxlinenum' | n <= fc_maxline c' = fc_maxline c' - 1 + | otherwise = n - 1 + c'' = FC flines' maxlinenum' + do_delete = do + set_contents f c'' + is_valid + in case M.lookup n flines of + Nothing -> do_delete + Just l' -> if l == l' + then do_delete + else assert_not $ FileEx f + +set_contents :: String -> FileContents -> PatchCheck () +set_contents f c = handle_inconsistent () $ do + P ks nots <- get + let ks' = FileLines f c : filter (not . is_file_lines_for f) ks + put (P ks' nots) + where is_file_lines_for file prop = case prop of + FileLines f' _ -> file == f' + _ -> False + +-- | Get (as much as we know about) the contents of a file in the current state. +-- Returns Nothing if the state is inconsistent. +file_contents :: String -> PatchCheck (Maybe FileContents) +file_contents f = handle_inconsistent Nothing $ do + P ks _ <- get + return (fic ks) + where fic (FileLines f' c:_) | f == f' = Just c + fic (_:ks) = fic ks + fic [] = Just empty_filecontents + +-- | Checks if a file is empty +file_empty :: String -- ^ Name of the file to check + -> PatchCheck Bool +file_empty f = do + c <- file_contents f + let empty = case c of + Just c' -> fc_maxline c' == 0 && M.null (fc_lines c') + Nothing -> True + if empty + then do set_contents f empty_filecontents + is_valid + -- Crude way to make it inconsistent and return false: + else assert_not $ FileEx f + return empty + +movedirfilename :: String -> String -> String -> String +movedirfilename d d' f + | (d ++ "/") `isPrefixOf` f = d' ++ drop (length d) f + | f == d = d' + | otherwise = f + +-- | Replaces a filename by another in all paths. Returns True if the repository +-- is consistent, False if it is not. +do_swap :: String -> String -> PatchCheck Bool +do_swap f f' = handle_inconsistent False $ do + modify (\(P ks nots) -> P (map sw ks) (map sw nots)) + return True + where sw (FileEx a) | f `is_soe` a = FileEx $ movedirfilename f f' a + | f' `is_soe` a = FileEx $ movedirfilename f' f a + sw (DirEx a) | f `is_soe` a = DirEx $ movedirfilename f f' a + | f' `is_soe` a = DirEx $ movedirfilename f' f a + sw (FileLines a c) | f `is_soe` a = FileLines (movedirfilename f f' a) c + | f' `is_soe` a = FileLines (movedirfilename f' f a) c + sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a + | f' `is_soe` a = NotEx $ movedirfilename f' f a + sw p = p + is_soe d1 d2 = -- is_superdir_or_equal + d1 == d2 || (d1 ++ "/") `isPrefixOf` d2 + +-- | Assert a property about the repository. If the property is already present +-- in the repo state, nothing changes, and the function returns True. If it is +-- not present yet, it is added to the repo state, and the function is True. If +-- the property is already in the list of properties that do not hold for the +-- repo, the state becomes inconsistent, and the function returns false. +assert :: Prop -> PatchCheck Bool +assert p = handle_inconsistent False $ do + P ks nots <- get + if has p nots + then do + put Inconsistent + return False + else if has p ks + then return True + else do + put (P (p:ks) nots) + return True + +-- | Like @assert@, but negatively: state that some property must not hold for +-- the current repo. +assert_not :: Prop -> PatchCheck Bool +assert_not p = handle_inconsistent False $ do + P ks nots <- get + if has p ks + then do + put Inconsistent + return False + else if has p nots + then return True + else do + put (P ks (p:nots)) + return True + +-- | Remove a property from the list of properties that do not hold for this +-- repo (if it's there), and add it to the list of properties that hold. +-- Returns False if the repo is inconsistent, True otherwise. +change_to_true :: Prop -> PatchCheck Bool +change_to_true p = handle_inconsistent False $ do + modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots)) + return True + +-- | Remove a property from the list of properties that hold for this repo (if +-- it's in there), and add it to the list of properties that do not hold. +-- Returns False if the repo is inconsistent, True otherwise. +change_to_false :: Prop -> PatchCheck Bool +change_to_false p = handle_inconsistent False $ do + modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots)) + return True + +assert_file_exists :: String -> PatchCheck Bool +assert_file_exists f = do assert_not $ NotEx f + assert_not $ DirEx f + assert $ FileEx f +assert_dir_exists :: String -> PatchCheck Bool +assert_dir_exists d = do assert_not $ NotEx d + assert_not $ FileEx d + assert $ DirEx d +assert_exists :: String -> PatchCheck Bool +assert_exists f = assert_not $ NotEx f + +assert_no_such :: String -> PatchCheck Bool +assert_no_such f = do assert_not $ FileEx f + assert_not $ DirEx f + assert $ NotEx f + +create_file :: String -> PatchCheck Bool +create_file fn = do + superdirs_exist fn + assert_no_such fn + change_to_true (FileEx fn) + change_to_false (NotEx fn) + +create_dir :: String -> PatchCheck Bool +create_dir fn = do + substuff_dont_exist fn + superdirs_exist fn + assert_no_such fn + change_to_true (DirEx fn) + change_to_false (NotEx fn) + +remove_file :: String -> PatchCheck Bool +remove_file fn = do + superdirs_exist fn + assert_file_exists fn + file_empty fn + change_to_false (FileEx fn) + change_to_true (NotEx fn) + +remove_dir :: String -> PatchCheck Bool +remove_dir fn = do + substuff_dont_exist fn + superdirs_exist fn + assert_dir_exists fn + change_to_false (DirEx fn) + change_to_true (NotEx fn) + +check_move :: String -> String -> PatchCheck Bool +check_move f f' = do + superdirs_exist f + superdirs_exist f' + assert_exists f + assert_no_such f' + do_swap f f' + +substuff_dont_exist :: String -> PatchCheck Bool +substuff_dont_exist d = handle_inconsistent False $ do + P ks _ <- get + if all noss ks + then return True + else do + put Inconsistent + return False + where noss (FileEx f) = not (is_within_dir f) + noss (DirEx f) = not (is_within_dir f) + noss _ = True + is_within_dir f = (d ++ "/") `isPrefixOf` f + +-- the init and tail calls dump the final init (which is just the path itself +-- again), the first init (which is empty), and the initial "." from +-- splitDirectories +superdirs_exist :: String -> PatchCheck Bool +superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs + where superdirs = map (("./"++) . joinPath) + (init (tail (inits (tail (splitDirectories fn))))) + +file_exists :: String -> PatchCheck Bool +file_exists fn = do + superdirs_exist fn + assert_file_exists fn + +dir_exists :: String -> PatchCheck Bool +dir_exists fn = do + superdirs_exist fn + assert_dir_exists fn diff --git a/src/Darcs/TheCommands.hs b/src/Darcs/TheCommands.hs --- a/src/Darcs/TheCommands.hs +++ b/src/Darcs/TheCommands.hs @@ -16,26 +16,22 @@ -- Boston, MA 02110-1301, USA. {-# LANGUAGE CPP #-} -module Darcs.TheCommands ( command_control_list ) where +module Darcs.TheCommands ( commandControlList ) where +import Prelude hiding ( log ) import Darcs.Commands.Add ( add ) import Darcs.Commands.AmendRecord ( amendrecord ) import Darcs.Commands.Annotate ( annotate ) import Darcs.Commands.Apply ( apply ) -import Darcs.Commands.Changes ( changes ) +import Darcs.Commands.Changes ( changes, log ) import Darcs.Commands.Check ( check ) import Darcs.Commands.Convert ( convert ) import Darcs.Commands.Diff import Darcs.Commands.Dist ( dist ) import Darcs.Commands.Get ( get, clone ) -#ifdef HAVE_HASKELL_ZLIB import Darcs.Commands.GZCRCs ( gzcrcs ) -#else --- import just to check it compiles -import Darcs.Commands.GZCRCs () -#endif import Darcs.Commands.Init ( initialize ) -import Darcs.Commands.Show ( show_command, list, query ) +import Darcs.Commands.Show ( showCommand, list, query ) import Darcs.Commands.MarkConflicts ( markconflicts, resolve ) import Darcs.Commands.Move ( move, mv ) import Darcs.Commands.Optimize ( optimize ) @@ -52,56 +48,54 @@ import Darcs.Commands.SetPref ( setpref ) import Darcs.Commands.Tag ( tag ) import Darcs.Commands.TrackDown ( trackdown ) -import Darcs.Commands.TransferMode ( transfer_mode ) +import Darcs.Commands.TransferMode ( transferMode ) import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate ) import Darcs.Commands.Unrevert ( unrevert ) import Darcs.Commands.WhatsNew ( whatsnew ) -import Darcs.Commands ( CommandControl(Command_data,Hidden_command,Group_name) ) +import Darcs.Commands ( CommandControl(CommandData,HiddenCommand,GroupName) ) -- | The commands that darcs knows about (e.g. whatsnew, record), -- organized into thematic groups. Note that hidden commands -- are also listed here. -command_control_list :: [CommandControl] -command_control_list = [Group_name "Changing and querying the working copy:", - Command_data add, - Command_data remove, Hidden_command unadd, Hidden_command rm, - Command_data move, Hidden_command mv, - Command_data replace, - Command_data revert, - Command_data unrevert, - Command_data whatsnew, - Group_name "Copying changes between the working copy and the repository:", - Command_data record, Hidden_command commit, - Command_data unrecord, - Command_data amendrecord, - Command_data markconflicts, Hidden_command resolve, - Group_name "Direct modification of the repository:", - Command_data tag, - Command_data setpref, - Group_name "Querying the repository:", - Command_data diff_command, - Command_data changes, - Command_data annotate, - Command_data dist, - Command_data trackdown, - Command_data show_command, Hidden_command list, Hidden_command query, - Hidden_command transfer_mode, - Group_name "Copying patches between repositories with working copy update:", - Command_data pull, - Command_data obliterate, Hidden_command unpull, - Command_data rollback, - Command_data push, - Command_data send, - Command_data apply, - Command_data get, Hidden_command clone, - Command_data put, - Group_name "Administrating repositories:", - Command_data initialize, - Command_data optimize, - Command_data check, - Command_data repair, - Command_data convert -#ifdef HAVE_HASKELL_ZLIB - ,Hidden_command gzcrcs -#endif +commandControlList :: [CommandControl] +commandControlList = [GroupName "Changing and querying the working copy:", + CommandData add, + CommandData remove, HiddenCommand unadd, HiddenCommand rm, + CommandData move, HiddenCommand mv, + CommandData replace, + CommandData revert, + CommandData unrevert, + CommandData whatsnew, + GroupName "Copying changes between the working copy and the repository:", + CommandData record, HiddenCommand commit, + CommandData unrecord, + CommandData amendrecord, + CommandData markconflicts, HiddenCommand resolve, + GroupName "Direct modification of the repository:", + CommandData tag, + CommandData setpref, + GroupName "Querying the repository:", + CommandData diffCommand, + CommandData changes, HiddenCommand log, + CommandData annotate, + CommandData dist, + CommandData trackdown, + CommandData showCommand, HiddenCommand list, HiddenCommand query, + HiddenCommand transferMode, + GroupName "Copying patches between repositories with working copy update:", + CommandData pull, + CommandData obliterate, HiddenCommand unpull, + CommandData rollback, + CommandData push, + CommandData send, + CommandData apply, + CommandData get, HiddenCommand clone, + CommandData put, + GroupName "Administrating repositories:", + CommandData initialize, + CommandData optimize, + CommandData check, + CommandData repair, + CommandData convert + ,HiddenCommand gzcrcs ] diff --git a/src/Darcs/Utils.hs b/src/Darcs/Utils.hs --- a/src/Darcs/Utils.hs +++ b/src/Darcs/Utils.hs @@ -3,16 +3,20 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand, - clarify_errors, prettyException, prettyError, + clarifyErrors, prettyException, prettyError, putStrLnError, putDocLnError, withCurrentDirectory, withUMask, askUser, stripCr, showHexLen, add_to_error_loc, maybeGetEnv, firstNotBlank, firstJustM, firstJustIO, isUnsupportedOperationError, isHardwareFaultError, - get_viewer, edit_file, promptYorn, promptCharFancy, + get_viewer, edit_file, run_editor, + promptYorn, promptCharFancy, environmentHelpEditor, environmentHelpPager, - formatPath ) where + formatPath + -- * Tree filtering. + , filterFilePaths, filterPaths + ) where import Prelude hiding ( catch ) import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try ) @@ -39,6 +43,8 @@ import Progress ( withoutProgress ) +import Storage.Hashed.AnchoredPath( AnchoredPath, isPrefix, floatPath ) + import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine, getInputChar, outputStrLn ) import System.Console.Haskeline.Encoding ( encode ) @@ -91,8 +97,8 @@ firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing) -clarify_errors :: IO a -> String -> IO a -clarify_errors a e = a `catch` (\x -> fail $ unlines [prettyException x,e]) +clarifyErrors :: IO a -> String -> IO a +clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e]) prettyException :: Control.Exception.Exception -> String prettyException (IOException e) | isUserError e = ioeGetErrorString e @@ -184,15 +190,8 @@ edit_file :: FilePathLike p => p -> IO ExitCode edit_file ff = do - ed <- get_editor old_content <- file_content - ec <- exec_interactive ed f - `ortryrunning` exec_interactive "emacs" f - `ortryrunning` exec_interactive "emacs -nw" f - `ortryrunning` exec_interactive "nano" f -#ifdef WIN32 - `ortryrunning` exec_interactive "edit" f -#endif + ec <- run_editor f new_content <- file_content when (new_content == old_content) $ do yorn <- promptYorn "File content did not change. Continue anyway?" @@ -206,6 +205,17 @@ return $ Just content else return Nothing +run_editor :: FilePath -> IO ExitCode +run_editor f = do + ed <- get_editor + exec_interactive ed f + `ortryrunning` exec_interactive "emacs" f + `ortryrunning` exec_interactive "emacs -nw" f + `ortryrunning` exec_interactive "nano" f +#ifdef WIN32 + `ortryrunning` exec_interactive "edit" f +#endif + get_editor :: IO String get_editor = getEnv "DARCS_EDITOR" `catchall` getEnv "DARCSEDITOR" `catchall` @@ -256,3 +266,16 @@ setDefault s = case md of Nothing -> s 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 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 = filterPaths . map floatPath + diff --git a/src/Darcs/Witnesses/Ordered.hs b/src/Darcs/Witnesses/Ordered.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Witnesses/Ordered.hs @@ -0,0 +1,277 @@ +-- Copyright (C) 2007 David Roundy +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , MagicHash, TypeOperators, GADTs #-} + +#include "gadts.h" + +module Darcs.Witnesses.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), (:||:)(..), + FL(..), RL(..),Proof(..), +#ifndef GADT_WITNESSES + unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL, +#endif + lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, + splitAtFL, bunchFL, foldlRL, + lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL, + unsafeMap_l2f, filterE, filterFL, + reverseFL, reverseRL, (+>+), (+<+), + nullFL, concatFL, concatRL, concatReverseFL, headRL, + MyEq, unsafeCompare, (=\/=), (=/\=), + consRLSealed, nullRL, + unsafeCoerceP, unsafeCoerceP2 + ) where + +#include "impossible.h" +import GHC.Base (unsafeCoerce#) +import Darcs.Witnesses.Show +import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal ) + +data EqCheck C(a b) where + IsEq :: EqCheck C(a a) + NotEq :: EqCheck C(a b) + +instance Eq (EqCheck C(a b)) where + IsEq == IsEq = True + NotEq == NotEq = True + _ == _ = False + +isEq :: EqCheck C(a b) -> Bool +isEq IsEq = True +isEq NotEq = False + +instance Show (EqCheck C(a b)) where + show IsEq = "IsEq" + show NotEq = "NotEq" + +data Proof a C(x y) where + Proof :: a -> Proof a C(x x) + +data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y)) +infixr 1 :> +data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z)) +infix 1 :< +infix 1 :/\:, :\/:, :||: +data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y)) +data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z)) +data (a1 :||: a2) C(x y) = (a1 C(x y)) :||: (a2 C(x y)) +class MyEq p where + -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=. + unsafeCompare :: p C(a b) -> p C(c d) -> Bool + unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b) + (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c) + a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq + | otherwise = NotEq + (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b) + a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq + | otherwise = NotEq + +infix 4 =\/=, =/\= + +unsafeCoerceP :: a C(x y) -> a C(b c) +unsafeCoerceP = unsafeCoerce# + +unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d) +unsafeCoerceP2 = unsafeCoerce# + +instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where + showsPrec d (x :> y) = showOp2 1 ":>" d x y + +instance (Show2 a, Show2 b) => Show2 (a :> b) where + showsPrec2 = showsPrec + +instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where + showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y + +instance (Show2 a, Show2 b) => Show2 (a :\/: b) where + showsPrec2 = showsPrec + +infixr 5 :>:, :<:, +>+, +<+ + +-- forward list +data FL a C(x z) where + (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z) + NilFL :: FL a C(x x) + +instance Show2 a => Show (FL a C(x z)) where + showsPrec _ NilFL = showString "NilFL" + showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x . + showString " :>: " . showsPrec (prec + 1) xs + where prec = 5 + +instance Show2 a => Show2 (FL a) where + showsPrec2 = showsPrec + +-- reverse list +data RL a C(x z) where + (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z) + NilRL :: RL a C(x x) + +nullFL :: FL a C(x z) -> Bool +nullFL NilFL = True +nullFL _ = False + +nullRL :: RL a C(x z) -> Bool +nullRL NilRL = True +nullRL _ = False + +filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z) +filterFL _ NilFL = NilFL +filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs + | otherwise = x :>: filterFL f xs + +filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)] +filterE _ [] = [] +filterE p (x:xs) + | IsEq <- p x = Proof x : filterE p xs + | otherwise = filterE p xs + +(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z) +NilFL +>+ ys = ys +(x:>:xs) +>+ ys = x :>: xs +>+ ys + +(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z) +NilRL +<+ ys = ys +(x:<:xs) +<+ ys = x :<: xs +<+ ys + +reverseFL :: FL a C(x z) -> RL a C(x z) +reverseFL xs = r NilRL xs + where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o) + r ls NilFL = ls + r ls (a:>:as) = r (a:<:ls) as + +reverseRL :: RL a C(x z) -> FL a C(x z) +reverseRL xs = r NilFL xs -- r (xs :> NilFL) + where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o) + r ls NilRL = ls + r ls (a:<:as) = r (a:>:ls) as + +concatFL :: FL (FL a) C(x z) -> FL a C(x z) +concatFL NilFL = NilFL +concatFL (a:>:as) = a +>+ concatFL as + +concatRL :: RL (RL a) C(x z) -> RL a C(x z) +concatRL NilRL = NilRL +concatRL (a:<:as) = a +<+ concatRL as + +spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z) +spanFL f (x:>:xs) | f x = case spanFL f xs of + ys :> zs -> (x:>:ys) :> zs +spanFL _ xs = NilFL :> xs + +splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z) +splitAtFL 0 xs = NilFL :> xs +splitAtFL _ NilFL = NilFL :> NilFL +splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of + (xs':>xs'') -> (x:>:xs' :> xs'') + +-- 'bunchFL n' groups patches into batches of n, except that it always puts +-- the first patch in its own group, this being a recognition that the +-- first patch is often *very* large. + +bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y) +bunchFL _ NilFL = NilFL +bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs + where bFL :: FL a C(x y) -> FL (FL a) C(x y) + bFL NilFL = NilFL + bFL bs = case splitAtFL n bs of + a :> b -> a :>: bFL b + + +allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool +allFL f xs = and $ mapFL f xs + +foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a +foldlFL _ x NilFL = x +foldlFL f x (y:>:ys) = foldlFL f (f x y) ys + +foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a +foldlRL _ x NilRL = x +foldlRL f x (y:<:ys) = foldlRL f (f x y) ys + +mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z) +mapFL_FL _ NilFL = NilFL +mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as + +zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y)) + -> [a] -> FL p C(w z) -> FL q C(w z) +zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys +zipWithFL _ _ NilFL = NilFL +zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list" + +mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z) +mapRL_RL _ NilRL = NilRL +mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as + +mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b] +mapFL _ NilFL = [] +mapFL f (a :>: b) = f a : mapFL f b + +mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b] +mapRL _ NilRL = [] +mapRL f (a :<: b) = f a : mapRL f b + +unsafeMap_l2f :: (FORALL(w z) a -> b C(w z)) -> [a] -> FL b C(x y) +unsafeMap_l2f _ [] = unsafeCoerceP NilFL +unsafeMap_l2f f (x:xs) = f x :>: unsafeMap_l2f f xs + +lengthFL :: FL a C(x z) -> Int +lengthFL xs = l xs 0 + where l :: FL a C(x z) -> Int -> Int + l NilFL n = n + l (_:>:as) n = l as $! n+1 + +lengthRL :: RL a C(x z) -> Int +lengthRL xs = l xs 0 + where l :: RL a C(x z) -> Int -> Int + l NilRL n = n + l (_:<:as) n = l as $! n+1 + +isShorterThanRL :: RL a C(x y) -> Int -> Bool +isShorterThanRL _ n | n <= 0 = False +isShorterThanRL NilRL _ = True +isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1) + +concatReverseFL :: FL (RL a) C(x y) -> RL a C(x y) +concatReverseFL = concatRL . reverseFL + +headRL :: RL a C(x y) -> FlippedSeal a C(y) +headRL (x:<:_) = flipSeal x +headRL _ = impossible + +consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z) +consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as + +#ifndef GADT_WITNESSES +-- These are useful for interfacing with modules which do not yet use type witnesses +unsafeUnFL :: FL a -> [a] +unsafeUnFL NilFL = [] +unsafeUnFL (a:>:as) = a : unsafeUnFL as + +unsafeUnRL :: RL a -> [a] +unsafeUnRL NilRL = [] +unsafeUnRL (a:<:as) = a : unsafeUnRL as + +unsafeFL :: [a] -> FL a +unsafeFL [] = NilFL +unsafeFL (a:as) = a :>: unsafeFL as + +unsafeRL :: [a] -> RL a +unsafeRL [] = NilRL +unsafeRL (a:as) = a :<: unsafeRL as +#endif diff --git a/src/Darcs/Witnesses/Sealed.hs b/src/Darcs/Witnesses/Sealed.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Witnesses/Sealed.hs @@ -0,0 +1,103 @@ +-- Copyright (C) 2007 David Roundy +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , MagicHash, GADTs #-} + +#include "gadts.h" + +module Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal, +#ifndef GADT_WITNESSES + unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2, +#endif + Sealed2(..), seal2, unseal2, mapSeal2, + FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped, + unsealM, liftSM + ) where + +import GHC.Base ( unsafeCoerce# ) +import Darcs.Witnesses.Show + +data Sealed a where + Sealed :: a C(x ) -> Sealed a + +seal :: a C(x ) -> Sealed a +seal = Sealed + +data Sealed2 a where + Sealed2 :: !(a C(x y )) -> Sealed2 a + +seal2 :: a C(x y ) -> Sealed2 a +seal2 = Sealed2 + +data FlippedSeal a C(y) where + FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y) + +flipSeal :: a C(x y) -> FlippedSeal a C(y) +flipSeal = FlippedSeal + +#ifndef GADT_WITNESSES +unsafeUnseal :: Sealed a -> a +unsafeUnseal (Sealed a) = a + +unsafeUnflippedseal :: FlippedSeal a -> a +unsafeUnflippedseal (FlippedSeal a) = a + +unsafeUnseal2 :: Sealed2 a -> a +unsafeUnseal2 (Sealed2 a) = a +#endif + +seriouslyUnsafeUnseal :: Sealed a -> a C(()) +seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a + +unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b +unseal f x = f (seriouslyUnsafeUnseal x) + +-- laziness property: +-- unseal (const True) undefined == True + +unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b +unsealM m1 m2 = do sx <- m1 + unseal m2 sx + +liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b +liftSM f m = do sx <- m + return (unseal f sx) + +mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b +mapSeal f = unseal (seal . f) + +mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z) +mapFlipped f (FlippedSeal x) = FlippedSeal (f x) + +seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ()) +seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a + +unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b +unseal2 f a = f (seriouslyUnsafeUnseal2 a) + +mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b +mapSeal2 f = unseal2 (seal2 . f) + +unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b +unsealFlipped f (FlippedSeal a) = f a + +instance Show1 a => Show (Sealed a) where + showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x +instance Show2 a => Show (Sealed2 a) where + showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x diff --git a/src/Darcs/Witnesses/Show.hs b/src/Darcs/Witnesses/Show.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Witnesses/Show.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +module Darcs.Witnesses.Show(Show1(..), Show2(..), showOp2, app_prec) where + +#include "gadts.h" + +class Show1 a where + show1 :: a C(x) -> String + show1 x = showsPrec1 0 x "" + showsPrec1 :: Int -> a C(x) -> ShowS + showsPrec1 _ x s = show1 x ++ s + +class Show2 a where + show2 :: a C(x y) -> String + show2 x = showsPrec2 0 x "" + showsPrec2 :: Int -> a C(x y) -> ShowS + showsPrec2 _ x s = show2 x ++ s + +showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String +showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x . + showString opstr . showsPrec2 (prec + 1) y + +app_prec :: Int +app_prec = 10 diff --git a/src/Exec.hs b/src/Exec.hs --- a/src/Exec.hs +++ b/src/Exec.hs @@ -32,7 +32,7 @@ import Control.Exception ( bracket ) import System.Posix.Env ( setEnv, getEnv, unsetEnv ) import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput ) -import System.IO ( stdin ) +import System.IO ( stdin ) #else import Control.Exception ( catchJust, Exception(IOException) ) import Data.List ( isInfixOf ) @@ -40,9 +40,9 @@ import System.Exit ( ExitCode (..) ) import System.Cmd ( system ) -import System.IO ( IOMode(..), openBinaryFile, stdout ) +import System.IO ( IOMode(..), openBinaryFile, stdout ) import System.Process ( runProcess, terminateProcess, waitForProcess ) -import GHC.Handle ( hDuplicate ) +import GHC.Handle ( hDuplicate ) -- urgh. hDuplicate isn't available from a standard place. import Control.Exception ( bracketOnError ) diff --git a/src/OldDate.hs b/src/OldDate.hs deleted file mode 100644 --- a/src/OldDate.hs +++ /dev/null @@ -1,350 +0,0 @@ --- Copyright (C) 2003 Peter Simons --- Copyright (C) 2003,2008 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - --- This module is intended to provide backwards-compatibility in the parsing --- of darcs patches. In other words: don't change it, new features don't get --- added here. The only user should be Darcs.Patch.Info. - -module OldDate ( readUTCDate, showIsoDateTime ) where - -import Text.ParserCombinators.Parsec -import System.Time -import Data.Char ( toUpper, isDigit ) -import Control.Monad ( liftM, liftM2 ) -import qualified Data.ByteString.Char8 as B -import Data.Maybe ( fromMaybe ) - --- | Read/interpret a date string, assuming UTC if timezone --- is not specified in the string -readUTCDate :: String -> CalendarTime -readUTCDate = readDate 0 - -readDate :: Int -> String -> CalendarTime -readDate tz d = - case parseDate tz d of - Left e -> error e - Right ct -> ct - -parseDate :: Int -> String -> Either String CalendarTime -parseDate tz d = - if length d >= 14 && B.all isDigit bd - then Right $ - CalendarTime (readI $ B.take 4 bd) - (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd) - (readI $ B.take 2 $ B.drop 6 bd) -- Day - (readI $ B.take 2 $ B.drop 8 bd) -- Hour - (readI $ B.take 2 $ B.drop 10 bd) -- Minute - (readI $ B.take 2 $ B.drop 12 bd) -- Second - 0 Sunday 0 -- Picosecond, weekday and day of year unknown - "GMT" 0 False - else let dt = do { x <- date_time tz; eof; return x } - in case parse dt "" d of - Left e -> Left $ "bad date: "++d++" - "++show e - Right ct -> Right ct - where bd = B.pack (take 14 d) - readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s) - -showIsoDateTime :: CalendarTime -> String -showIsoDateTime ct = concat [ show $ ctYear ct - , twoDigit . show . (+1) . fromEnum $ ctMonth ct - , twoDigit . show $ ctDay ct - , twoDigit . show $ ctHour ct - , twoDigit . show $ ctMin ct - , twoDigit . show $ ctSec ct - ] - where twoDigit [] = undefined - twoDigit x@(_:[]) = '0' : x - twoDigit x@(_:_:[]) = x - twoDigit _ = undefined - ------ Parser Combinators --------------------------------------------- - --- |Case-insensitive variant of Parsec's 'char' function. - -caseChar :: Char -> GenParser Char a Char -caseChar c = satisfy (\x -> toUpper x == toUpper c) - --- |Case-insensitive variant of Parsec's 'string' function. - -caseString :: String -> GenParser Char a () -caseString cs = mapM_ caseChar cs cs - --- |Match a parser at least @n@ times. - -manyN :: Int -> GenParser a b c -> GenParser a b [c] -manyN n p - | n <= 0 = return [] - | otherwise = liftM2 (++) (count n p) (many p) - --- |Match a parser at least @n@ times, but no more than @m@ times. - -manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c] -manyNtoM n m p - | n < 0 = return [] - | n > m = return [] - | n == m = count n p - | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) - | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) - - ------ Date/Time Parser ----------------------------------------------- - -date_time :: Int -> CharParser a CalendarTime -date_time tz = - choice [try $ cvs_date_time tz, - try $ iso8601_date_time tz, - old_date_time] - -cvs_date_time :: Int -> CharParser a CalendarTime -cvs_date_time tz = - do y <- year - char '/' - mon <- month_num - char '/' - d <- day - my_spaces - h <- hour - char ':' - m <- minute - char ':' - s <- second - z <- option tz $ my_spaces >> zone - return (CalendarTime y mon d h m s 0 Monday 0 "" z False) - -old_date_time :: CharParser a CalendarTime -old_date_time = do wd <- day_name - my_spaces - mon <- month_name - my_spaces - d <- day - my_spaces - h <- hour - char ':' - m <- minute - char ':' - s <- second - my_spaces - z <- zone - my_spaces - y <- year - return (CalendarTime y mon d h m s 0 wd 0 "" z False) - -{- FIXME: In case you ever want to use this outside of darcs, you should note - that this implementation of ISO 8601 is not complete. - - reluctant to implement (ambiguous!): - * years > 9999 - * truncated representations with implied century (89 for 1989) - unimplemented: - * repeated durations (not relevant) - * lowest order component fractions in intervals - * negative dates (BC) - unverified or too relaxed: - * the difference between 24h and 0h - * allows stuff like 2005-1212; either you use the hyphen all the way - (2005-12-12) or you don't use it at all (20051212), but you don't use - it halfway, likewise with time - * No bounds checking whatsoever on intervals! - (next action: read iso doc to see if bounds-checking required?) -} -iso8601_date_time :: Int -> CharParser a CalendarTime -iso8601_date_time localTz = try $ - do d <- iso8601_date - t <- option id $ try $ do optional $ oneOf " T" - iso8601_time - return $ t $ d { ctTZ = localTz } - -iso8601_date :: CharParser a CalendarTime -iso8601_date = - do d <- calendar_date <|> week_date <|> ordinal_date - return $ foldr ($) nullCalendar d - where - calendar_date = -- yyyy-mm-dd - try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] - -- allow other variants to be parsed correctly - notFollowedBy (digit <|> char 'W') - return d - week_date = --yyyy-Www-dd - try $ do yfn <- year_ - optional dash - char 'W' - -- offset human 'week 1' -> computer 'week 0' - w' <- (\x -> x-1) `liftM` two_digits - wd <- option 1 $ do { optional dash; n_digits 1 } - let y = yfn nullCalendar - firstDay = ctWDay y - -- things that make this complicated - -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday - -- 2. the first week is the one that contains at least Thursday - -- if the year starts after Thursday, then some days of the year - -- will have already passed before the first week - let afterThursday = firstDay == Sunday || firstDay > Thursday - w = if afterThursday then w'+1 else w' - diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) } - return [(toUTCTime.toClockTime.diff.yfn)] - ordinal_date = -- yyyy-ddd - try $ optchain year_ [ (dash, yearDay_) ] - -- - year_ = try $ do y <- four_digits "year (0000-9999)" - return $ \c -> c { ctYear = y } - month_ = try $ do m <- two_digits "month (1 to 12)" - -- we (artificially) use ctPicosec to indicate - -- whether the month has been specified. - return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 } - day_ = try $ do d <- two_digits "day in month (1 to 31)" - return $ \c -> c { ctDay = d } - yearDay_ = try $ do d <- n_digits 3 "day in year (1 to 366)" - return $ \c -> c { ctYDay = d } - dash = char '-' - --- we return a function which sets the time on another calendar -iso8601_time :: CharParser a (CalendarTime -> CalendarTime) -iso8601_time = try $ - do ts <- optchain hour_ [ (colon , min_) - , (colon , sec_) - , (oneOf ",.", pico_) ] - z <- option id $ choice [ zulu , offset ] - return $ foldr (.) id (z:ts) - where - hour_ = do h <- two_digits - return $ \c -> c { ctHour = h } - min_ = do m <- two_digits - return $ \c -> c { ctMin = m } - sec_ = do s <- two_digits - return $ \c -> c { ctSec = s } - pico_ = do digs <- many digit - let picoExp = 12 - digsExp = length digs - let frac | null digs = 0 - | digsExp > picoExp = read $ take picoExp digs - | otherwise = 10 ^ (picoExp - digsExp) * (read digs) - return $ \c -> c { ctPicosec = frac } - zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) } - offset = do sign <- choice [ do { char '+' >> return 1 } - , do { char '-' >> return (-1) } ] - h <- two_digits - m <- option 0 $ do { optional colon; two_digits } - return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) } - colon = char ':' - -optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] -optchain p next = try $ - do r1 <- p - r2 <- case next of - [] -> return [] - ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } - return (r1:r2) - -n_digits :: Int -> CharParser a Int -n_digits n = read `liftM` count n digit - -two_digits, four_digits :: CharParser a Int -two_digits = n_digits 2 -four_digits = n_digits 4 - -my_spaces :: CharParser a String -my_spaces = manyN 1 $ char ' ' - -day_name :: CharParser a Day -day_name = choice - [ caseString "Mon" >> return Monday - , try (caseString "Tue") >> return Tuesday - , caseString "Wed" >> return Wednesday - , caseString "Thu" >> return Thursday - , caseString "Fri" >> return Friday - , try (caseString "Sat") >> return Saturday - , caseString "Sun" >> return Sunday - ] - -year :: CharParser a Int -year = four_digits - -month_num :: CharParser a Month -month_num = do mn <- manyNtoM 1 2 digit - return $ intToMonth $ (read mn :: Int) - -intToMonth :: Int -> Month -intToMonth 1 = January -intToMonth 2 = February -intToMonth 3 = March -intToMonth 4 = April -intToMonth 5 = May -intToMonth 6 = June -intToMonth 7 = July -intToMonth 8 = August -intToMonth 9 = September -intToMonth 10 = October -intToMonth 11 = November -intToMonth 12 = December -intToMonth _ = error "invalid month!" - -month_name :: CharParser a Month -month_name = choice - [ try (caseString "Jan") >> return January - , caseString "Feb" >> return February - , try (caseString "Mar") >> return March - , try (caseString "Apr") >> return April - , caseString "May" >> return May - , try (caseString "Jun") >> return June - , caseString "Jul" >> return July - , caseString "Aug" >> return August - , caseString "Sep" >> return September - , caseString "Oct" >> return October - , caseString "Nov" >> return November - , caseString "Dec" >> return December - ] - -day :: CharParser a Int -day = do d <- manyNtoM 1 2 digit - return (read d :: Int) - -hour :: CharParser a Int -hour = two_digits - -minute :: CharParser a Int -minute = two_digits - -second :: CharParser a Int -second = two_digits - -zone :: CharParser a Int -zone = choice - [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) } - , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) } - , mkZone "UTC" 0 - , mkZone "UT" 0 - , mkZone "GMT" 0 - , mkZone "EST" (-5) - , mkZone "EDT" (-4) - , mkZone "CST" (-6) - , mkZone "CDT" (-5) - , mkZone "MST" (-7) - , mkZone "MDT" (-6) - , mkZone "PST" (-8) - , mkZone "PDT" (-7) - , mkZone "CEST" 2 - , mkZone "EEST" 3 - -- if we don't understand it, just give a GMT answer... - , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' ']) - (lookAhead space_digit); - return 0 } - ] - where mkZone n o = try $ do { caseString n; return (o*60*60) } - space_digit = try $ do { char ' '; oneOf ['0'..'9'] } - -nullCalendar :: CalendarTime -nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False diff --git a/src/Preproc.hs b/src/Preproc.hs --- a/src/Preproc.hs +++ b/src/Preproc.hs @@ -13,23 +13,24 @@ -- LaTeX text. In particular, \\darcsCommand{foo} is replaced by -- LaTeX markup describing the command @foo@. module Preproc ( preproc_main ) where +import qualified Ratified( readFile ) import System.FilePath ( () ) import System.Environment ( getArgs ) import System.Exit ( exitWith, ExitCode(..) ) import Text.Regex ( matchRegex, mkRegex ) import Darcs.Commands ( DarcsCommand(SuperCommand, - command_sub_commands, command_name, - command_extra_arg_help, command_basic_options, - command_advanced_options, command_help, - command_description), - extract_commands ) -import Darcs.Arguments ( options_latex ) -import Darcs.Commands.Help ( command_control_list, environmentHelp ) + commandSubCommands, commandName, + commandExtraArgHelp, commandBasicOptions, + commandAdvancedOptions, commandHelp, + commandDescription), + extractCommands ) +import Darcs.Arguments ( optionsLatex ) +import Darcs.Commands.Help ( commandControlList, environmentHelp ) import English ( andClauses ) -import ThisVersion ( darcs_version ) +import Version ( version ) the_commands :: [DarcsCommand] -the_commands = extract_commands command_control_list +the_commands = extractCommands commandControlList -- | The entry point for this program. The path to the TeX master -- file is supplied as the first argument. Bootstrapping into @@ -79,17 +80,17 @@ else return $ "\\end{Verbatim}" : rest preproc ("\\darcsVersion":ss) = do rest <- preproc ss - return $ darcs_version:rest + return $ version:rest preproc (s:ss) = do rest <- preproc ss let rx = mkRegex "^\\\\(input|darcs(Command|Env))\\{(.+)\\}$" case matchRegex rx s of Just ["input", _, path] -> - do cs <- readFile $ "src" path -- ratify readFile: not part of darcs executable + do cs <- Ratified.readFile $ "src" path -- not part of normal darcs operation this <- preproc $ lines cs return $ this ++ rest Just ["darcsCommand", _, command] -> - return $ commandHelp command : rest + return $ latexCommandHelp command : rest Just ["darcsEnv", _, variable] -> return $ envHelp variable : rest -- The base case for the whole preproc function. Nothing to @@ -97,18 +98,18 @@ -- the result unmodified. _ -> return $ s : rest -commandHelp :: String -> String -commandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++ +latexCommandHelp :: String -> String +latexCommandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++ "\\label{" ++ command ++ "}\n" ++ gh ++ get_options command ++ gd where section = if ' ' `elem` command then "\\subsubsection" else "\\subsection" -- | Given a Darcs command name as a string, return that command's (multi-line) help string. gh :: String - gh = escape_latex_specials $ command_property command_help the_commands command + gh = escape_latex_specials $ command_property commandHelp the_commands command -- | Given a Darcs command name as a string, return that command's (one-line) description string. gd :: String - gd = command_property command_description the_commands command + gd = command_property commandDescription the_commands command get_options :: String -> String get_options comm = get_com_options $ get_c names the_commands @@ -120,10 +121,10 @@ [] -> [get name commands] _ -> case get name commands of c@SuperCommand { } -> - c:(get_c ns $ extract_commands $ command_sub_commands c) + c:(get_c ns $ extractCommands $ commandSubCommands c) _ -> error $ "Not a supercommand: " ++ name - where get n (c:cs) | command_name c == n = c + where get n (c:cs) | commandName c == n = c | otherwise = get n cs get n [] = error $ "No such command: "++n get_c [] _ = error "no command specified" @@ -131,12 +132,12 @@ get_com_options :: [DarcsCommand] -> String get_com_options c = "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " ++ - args ++ "!\n\n" ++ "Options:\n\n" ++ options_latex opts1 ++ - (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ options_latex opts2) - where cmd = unwords $ map command_name c - args = unwords $ command_extra_arg_help $ last c - opts1 = command_basic_options $ last c - opts2 = command_advanced_options $ last c + args ++ "!\n\n" ++ "Options:\n\n" ++ optionsLatex opts1 ++ + (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ optionsLatex opts2) + where cmd = unwords $ map commandName c + args = unwords $ commandExtraArgHelp $ last c + opts1 = commandBasicOptions $ last c + opts2 = commandAdvancedOptions $ last c command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String -> String diff --git a/src/Progress.hs b/src/Progress.hs --- a/src/Progress.hs +++ b/src/Progress.hs @@ -46,11 +46,12 @@ printProgress :: String -> ProgressData -> IO () printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) = - myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t) + myput output output + where output = (k++" "++show s++" done, "++show (t - s)++" queued. "++l) printProgress k (ProgressData {latest=Just l}) = myput (k++" "++l) k printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s = - myput (k++" "++show s++"/"++show t) (k++" "++show s) + myput (k++" "++show s++" done, "++show (t - s)++" queued") (k++" "++show s) printProgress k (ProgressData {sofar=s}) = myput (k++" "++show s) k diff --git a/src/Ratified.hs b/src/Ratified.hs new file mode 100644 --- /dev/null +++ b/src/Ratified.hs @@ -0,0 +1,2 @@ +module Ratified( readFile, hGetContents ) where +import System.IO( hGetContents ) diff --git a/src/RegChars.hs b/src/RegChars.hs deleted file mode 100644 --- a/src/RegChars.hs +++ /dev/null @@ -1,75 +0,0 @@ --- Copyright (C) 2003 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - - -module RegChars ( regChars, - ) where - -(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -(&&&) a b c = a c && b c - -(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -(|||) a b c = a c || b c - -{-# INLINE regChars #-} - --- | 'regChars' returns a filter function that tells if a char is a member --- of the regChar expression or not. The regChar expression is basically a --- set of chars, but it can contain ranges with use of the '-' (dash), and --- it can also be specified as a complement set by prefixing with '^' --- (caret). The dash and caret, as well as the backslash, can all be --- escaped with a backslash to suppress their special meaning. --- --- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning --- if it is not escaped, but the default 'filename_toks' in --- Darcs.Commands.Replace uses an escaped dot (WHY?). - -regChars :: String -> (Char -> Bool) -regChars ('^':cs) = not . normalRegChars (unescapeChars cs) -regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs -regChars cs = normalRegChars $ unescapeChars cs - -{-# INLINE unescapeChars #-} - --- | 'unescapeChars' unescapes whitespace, which is escaped in the replace --- patch file format. It will also unescape escaped carets, which is useful --- for escaping a leading caret that should not invert the regChars. All --- other escapes are left for the unescaping in 'normalRegChars'. - -unescapeChars :: String -> String -unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs -unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs -unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs -unescapeChars (c:cs) = c : unescapeChars cs -unescapeChars [] = [] - -{-# INLINE normalRegChars #-} - --- | 'normalRegChars' assembles the filter function. It handles special --- chars, and also unescaping of escaped special chars. If a non-special --- char is still escaped by now we get a failure. - -normalRegChars :: String -> (Char -> Bool) -normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs -normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs -normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs -normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported." -normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs -normalRegChars (c:cs) = (== c) ||| normalRegChars cs -normalRegChars [] = \_ -> False - - diff --git a/src/Ssh.hs b/src/Ssh.hs --- a/src/Ssh.hs +++ b/src/Ssh.hs @@ -5,6 +5,7 @@ ) where import Prelude hiding ( lookup, catch ) +import qualified Ratified( hGetContents ) import System.Exit ( ExitCode(..) ) import System.Environment ( getEnv ) @@ -15,7 +16,7 @@ import Data.Bits ( (.&.) ) import System.Random ( randomIO ) #endif -import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hGetContents, hClose, hFlush ) +import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hClose, hFlush ) import System.IO.Unsafe ( unsafePerformIO ) import System.Directory ( doesFileExist, createDirectoryIfMissing ) import Control.Monad ( when ) @@ -42,18 +43,19 @@ data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: String -> IO () } -withSSHConnection :: String -> (Connection -> IO a) -> IO a -> IO a -withSSHConnection x withconnection withoutconnection = +withSSHConnection :: String -> String -> (Connection -> IO a) -> IO a -> IO a +withSSHConnection rdarcs repoid withconnection withoutconnection = withoutProgress $ do cs <- readIORef sshConnections - let uhost = takeWhile (/= ':') x - url = cleanrepourl x + let uhost = takeWhile (/= ':') repoid + url = cleanrepourl repoid case lookup url (cs :: Map String (Maybe Connection)) of Just Nothing -> withoutconnection Just (Just c) -> withconnection c Nothing -> do mc <- do (ssh,sshargs_) <- getSSHOnly SSH - let sshargs = sshargs_ ++ [uhost,"darcs","transfer-mode","--repodir",cleanrepodir x] + let sshargs = sshargs_ ++ [uhost,rdarcs, + "transfer-mode","--repodir",cleanrepodir repoid] debugMessage $ "ssh "++unwords sshargs (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing l <- hGetLine o @@ -67,7 +69,7 @@ `catchNonSignal` \e -> do debugMessage $ "Failed to start ssh connection:\n "++ prettyException e - severSSHConnection x + severSSHConnection repoid debugMessage $ unlines $ [ "NOTE: the server may be running a version of darcs prior to 2.0.0." , "" @@ -98,10 +100,10 @@ clean "" = bug $ "Buggy path in grabSSH: "++x file = clean dir failwith e = do severSSHConnection x - eee <- hGetContents (err c) -- ratify hGetContents: it's okay - -- here because we're only grabbing - -- stderr, and we're also about to - -- throw the contents. + -- hGetContents is ok here because we're + -- only grabbing stderr, and we're also + -- about to throw the contents. + eee <- Ratified.hGetContents (err c) debugFail $ e ++ " grabbing ssh file "++x++"\n"++eee deb c $ "get "++file hPutStrLn (inp c) $ "get " ++ file @@ -123,8 +125,8 @@ sshStdErrMode = withDebugMode $ \amdebugging -> return $ if amdebugging then AsIs else Null -copySSH :: String -> FilePath -> IO () -copySSH uRaw f = withSSHConnection uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $ +copySSH :: String -> String -> FilePath -> IO () +copySSH rdarcs uRaw f = withSSHConnection rdarcs uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $ do let u = escape_dollar uRaw stderr_behavior <- sshStdErrMode r <- runSSH SCP u [] [u,f] (AsIs,AsIs,stderr_behavior) @@ -136,11 +138,11 @@ where tr '$' = "\\$" tr c = [c] -copySSHs :: String -> [String] -> FilePath -> IO () -copySSHs u ns d = - withSSHConnection u (\c -> withCurrentDirectory d $ - mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $ - progressList "Copying via ssh" ns) $ +copySSHs :: String -> String -> [String] -> FilePath -> IO () +copySSHs rdarcs u ns d = + withSSHConnection rdarcs u (\c -> withCurrentDirectory d $ + mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $ + progressList "Copying via ssh" ns) $ do let path = drop 1 $ dropWhile (/= ':') u host = takeWhile (/= ':') u cd = "cd "++path++"\n" diff --git a/src/ThisVersion.hs b/src/ThisVersion.hs deleted file mode 100644 --- a/src/ThisVersion.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -cpp #-} - -module ThisVersion ( darcs_version ) where - -#ifndef PACKAGE_VERSION -#define PACKAGE_VERSION "0" -#define PACKAGE_VERSION_STATE "no version info" -#endif - -{-# NOINLINE darcs_version #-} -darcs_version :: String -darcs_version = PACKAGE_VERSION ++ " (" ++ PACKAGE_VERSION_STATE ++ ")" diff --git a/src/UTF8.lhs b/src/UTF8.lhs deleted file mode 100644 --- a/src/UTF8.lhs +++ /dev/null @@ -1,173 +0,0 @@ -Copyright (c) 2002, members of the Haskell Internationalisation Working -Group All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -* Neither the name of the Haskell Internationalisation Working Group nor - the names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - -This module provides lazy stream encoding/decoding facilities for UTF-8, -the Unicode Transformation Format with 8-bit words. - -2002-09-02 Sven Moritz Hallberg - - -> {-# OPTIONS_GHC -cpp #-} -> module UTF8 -> ( encode ) where - - -SUNSET: we should remove this module after the 2009-07 release -of darcs and just use Codec.Binary.UTF8.String instead - -#ifdef HAVE_UTF8STRING -> import qualified Codec.Binary.UTF8.String (encode) -> import Data.Word (Word8) -#else -> import Data.Char (ord) -> import Data.Word (Word8, Word16, Word32) -> import Data.Bits (Bits, shiftR, (.&.), (.|.)) -#endif - - - -///- UTF-8 in General -/// - -Adapted from the Unicode standard, version 3.2, -Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings): - - Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte - 000000000xxxxxxx 0xxxxxxx - 00000yyyyyxxxxxx 110yyyyy 10xxxxxx - zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx - 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx - -Also from the Unicode standard, version 3.2, -Table 3.1B "Legal UTF-8 Byte Sequences": - - Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte - U+0000..U+007F 00..7F - U+0080..U+07FF C2..DF 80..BF - U+0800..U+0FFF E0 A0..BF 80..BF - U+1000..U+CFFF E1..EC 80..BF 80..BF - U+D000..U+D7FF ED 80..9F 80..BF - U+D800..U+DFFF ill-formed - U+E000..U+FFFF EE..EF 80..BF 80..BF - U+10000..U+3FFFF F0 90..BF 80..BF 80..BF - U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF - U+100000..U+10FFFF F4 80..8F 80..BF 80..BF - - - -///- Encoding Functions -/// - -Must the encoder ensure that no illegal byte sequences are output or -can we trust the Haskell system to supply only legal values? -For now I include error case for the surrogate values U+D800..U+DFFF and -out-of-range scalars. - -The function is pretty much a transscript of table 3.1B with error checks. -It dispatches the actual encoding to functions specific to the number of -required bytes. - -#ifndef HAVE_UTF8STRING -> encodeOne :: Char -> [Word8] -> encodeOne c ->-- The report guarantees in (6.1.2) that this won't happen: ->-- | n < 0 = error "encodeUTF8: ord returned a negative value" -> | n < 0x0080 = encodeOne_onebyte n8 -> | n < 0x0800 = encodeOne_twobyte n16 -> | n < 0xD800 = encodeOne_threebyte n16 -> | n < 0xE000 = error "encodeUTF8: ord returned a surrogate value" -> | n < 0x10000 = encodeOne_threebyte n16 ->-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1. -> | n < 0x10FFFF = encodeOne_fourbyte n32 -> | otherwise = error "encodeUTF8: ord returned a value above 0x10FFFF" -> where -> n = ord c :: Int -> n8 = fromIntegral n :: Word8 -> n16 = fromIntegral n :: Word16 -> n32 = fromIntegral n :: Word32 -#endif - - -With the above, a stream decoder is trivial: - - -> encode :: [Char] -> [Word8] -#ifdef HAVE_UTF8STRING -> encode = Codec.Binary.UTF8.String.encode -#else -> encode = concatMap encodeOne -#endif - - -Now follow the individual encoders for certain numbers of bytes... - _ - / | __ ___ __ __ - / ^| // /__/ // // - /.==| \\ //_ // // -It's // || // \_/_//_//_ and it's here to stay! - -#ifndef HAVE_UTF8STRING -> encodeOne_onebyte :: Word8 -> [Word8] -> encodeOne_onebyte cp = [cp] -#endif - - -00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx - -#ifndef HAVE_UTF8STRING -> encodeOne_twobyte :: Word16 -> [Word8] -> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)] -> where -> xs, ys :: Word8 -> ys = fromIntegral (shiftR cp 6) -> xs = (fromIntegral cp) .&. 0x3F -#endif - - -zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx - -#ifndef HAVE_UTF8STRING -> encodeOne_threebyte :: Word16 -> [Word8] -> encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)] -> where -> xs, ys, zs :: Word8 -> xs = (fromIntegral cp) .&. 0x3F -> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F -> zs = fromIntegral (shiftR cp 12) -#endif - - -000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx - -#ifndef HAVE_UTF8STRING -> encodeOne_fourbyte :: Word32 -> [Word8] -> encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs] -> where -> xs, ys, zs, us :: Word8 -> xs = (fromIntegral cp) .&. 0x3F -> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F -> zs = (fromIntegral (shiftR cp 12)) .&. 0x3F -> us = fromIntegral (shiftR cp 18) -#endif diff --git a/src/atomic_create.h b/src/atomic_create.h --- a/src/atomic_create.h +++ b/src/atomic_create.h @@ -12,14 +12,6 @@ int renamefile(const char *from, const char *to); #endif -int open_read(const char *fname); -int open_write(const char *fname); -int smart_wait(int pid); - -int execvp_no_vtalarm(const char *file, char *const argv[]); - -int is_symlink(const char *file); - int stdout_is_a_pipe(); int maybe_relink(const char *src, const char *dst, int careful); diff --git a/src/c_compat.c b/src/c_compat.c deleted file mode 100644 --- a/src/c_compat.c +++ /dev/null @@ -1,88 +0,0 @@ - -#include -#include -#include -#include -#include -#include - -#include -#include -#include -#include - -#ifdef _WIN32 -#include -#include -#endif - -#ifndef _WIN32 - -int open_read(const char *fname) { - return open(fname, O_RDONLY); -} - -int open_write(const char *fname) { - return open(fname, O_WRONLY | O_TRUNC | O_CREAT, - S_IWUSR | S_IRUSR | S_IROTH | S_IRGRP); -} - -int get_errno() { - return errno; -} - -#include -#include -#if HAVE_SIGINFO_H -#include -#endif - -/* This waits and then returns the exit status of the process that was - waited for. */ -int smart_wait(int pid) { - int stat; - pid_t rc; - - do { - rc = waitpid(pid, &stat, 0); - } while(rc < 0 && errno == EINTR); - - if(rc < 0) { - perror("waitpid"); - return -138; - } else if (WIFEXITED(stat)) { - return WEXITSTATUS(stat); - } else if (WIFSIGNALED(stat)) { - /* Fixme: psignal isn't portable (not in POSIX). */ - psignal(WTERMSIG(stat), "Error in subprocess"); - return - WTERMSIG(stat); - } else { - return -137; - } -} - -#include -#include -#include -#include - -int execvp_no_vtalarm(const char *file, char *const argv[]) { - /* Reset the itimers in the child, so it doesn't get plagued - * by SIGVTALRM interrupts. - */ - struct timeval tv_null = { 0, 0 }; - struct itimerval itv; - itv.it_interval = tv_null; - itv.it_value = tv_null; - setitimer(ITIMER_REAL, &itv, NULL); - setitimer(ITIMER_VIRTUAL, &itv, NULL); - setitimer(ITIMER_PROF, &itv, NULL); - execvp(file, argv); - perror("Error in execvp"); - return errno; -} - -#include -#include -#endif - diff --git a/src/compat.h b/src/compat.h deleted file mode 100644 --- a/src/compat.h +++ /dev/null @@ -1,12 +0,0 @@ - -#include -#include -#include - -int open_read(const char *fname); -int open_write(const char *fname); -int smart_wait(int pid); -int get_errno(); - -int execvp_no_vtalarm(const char *file, char *const argv[]); - diff --git a/src/darcs.hs b/src/darcs.hs --- a/src/darcs.hs +++ b/src/darcs.hs @@ -28,10 +28,9 @@ import Darcs.RunCommand ( run_the_command ) import Darcs.Flags ( DarcsFlag(Verbose) ) -import Darcs.Commands.Help ( help_cmd, list_available_commands, print_version ) -import ThisVersion ( darcs_version ) +import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion ) import Darcs.SignalHandler ( withSignalsHandled ) -import Context ( context ) +import Version ( version, context ) import Darcs.Global ( with_atexit ) import Preproc( preproc_main ) import Exec ( ExecException(..) ) @@ -55,14 +54,14 @@ argv <- getArgs case argv of -- User called "darcs" without arguments. - [] -> print_version >> help_cmd [] [] + [] -> printVersion >> helpCmd [] [] -- User called "darcs --foo" for some special foo. - ["-h"] -> help_cmd [] [] - ["--help"] -> help_cmd [] [] - ["--overview"] -> help_cmd [Verbose] [] - ["--commands"] -> list_available_commands - ["-v"] -> putStrLn darcs_version - ["--version"] -> putStrLn darcs_version + ["-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 diff --git a/src/darcs.tex b/src/darcs.tex new file mode 100644 --- /dev/null +++ b/src/darcs.tex @@ -0,0 +1,674 @@ +% Copyright (C) 2002-2003 David Roundy +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2, or (at your option) +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; see the file COPYING. If not, write to +% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +% Boston, MA 02110-1301, USA. + +\documentclass{book} +%\usepackage{color} + +\usepackage{verbatim} +\usepackage{html} +\usepackage{fancyvrb} +\newenvironment{code}{\comment}{\endcomment} +% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim} + +\begin{document} + + +% Definition of title page: +\title{Darcs User Manual} +\date{ +\darcsVersion +} % icky newline before closing brace is to appease preproc.hs. +\author{David Roundy} + +\maketitle + +\tableofcontents + +\chapter{Introduction} + +%% FIXME: DVCS is no longer distinctive; it is the norm. + +Darcs is a revision control system, along the lines of CVS or arch. That +means that it keeps track of various revisions and branches of your +project, allows for changes to propagate from one branch to another. Darcs +is intended to be an ``advanced'' revision control system. Darcs has two +particularly distinctive features which differ from other revision control +systems: 1) each copy of the source is a fully functional branch, and 2) +underlying darcs is a consistent and powerful theory of patches. + +%% FIXME: don't talk about CVS and arch as if they are our +%% contemporaries, it makes us sound as dated as they are. Our key +%% competitors are git, hg, bzr and svn. + +\paragraph{Every source tree a branch} +The primary simplifying notion of darcs is that \emph{every} copy of your +source code is a full repository. This is dramatically different from CVS, +in which the normal usage is for there to be one central repository from +which source code will be checked out. It is closer to the notion of arch, +since the `normal' use of arch is for each developer to create his own +repository. However, darcs makes it even easier, since simply checking out +the code is all it takes to create a new repository. This has several +advantages, since you can harness the full power of darcs in any scratch +copy of your code, without committing your possibly destabilizing changes to +a central repository. + +%% FIXME: unbound personal pronoun (me). Use third person, passive voice. + +\paragraph{Theory of patches} +The development of a simplified theory of patches is what originally +motivated me to create darcs. This patch formalism means that darcs patches +have a set of properties, which make possible manipulations that couldn't be +done in other revision control systems. First, every patch is invertible. +Secondly, sequential patches (i.e.\ patches that are created in sequence, one +after the other) can be reordered, although this reordering can fail, which +means the second patch is dependent on the first. Thirdly, patches which are +in parallel (i.e.\ both patches were created by modifying identical trees) +can be merged, and the result of a set of merges is independent of the order +in which the merges are performed. This last property is critical to darcs' +philosophy, as it means that a particular version of a source tree is fully +defined by the list of patches that are in it, i.e.\ there is no issue +regarding the order in which merges are performed. For a more thorough +discussion of darcs' theory of patches, see Appendix~\ref{Patch}. + +%% FIXME: clarify - the theory is advanced, the UI is simple. + +\paragraph{A simple advanced tool} +Besides being ``advanced'' as discussed above, darcs is actually also quite +simple. Versioning tools can be seen as three layers. At the foundation is +the ability to manipulate changes. On top of that must be placed some kind +of database system to keep track of the changes. Finally, at the very top is +some sort of distribution system for getting changes from one place to +another. + +Really, only the first of these three layers is of particular interest to +me, so the other two are done as simply as possible. At the database +layer, darcs just has an ordered list of patches along with the patches +themselves, each stored as an individual file. Darcs' distribution system +is strongly inspired by that of arch. Like arch, darcs uses a dumb server, +typically apache or just a local or network file system when pulling +patches. darcs has built-in support for using \verb!ssh! to write to a remote file +system. A darcs executable is called on the remote system to apply the patches. +Arbitrary other transport protocols are supported, through an environment +variable describing a command that will run darcs on the remote system. +See the documentation for DARCS\_APPLY\_FOO in Chapter~\ref{configuring} +for details. + +The recommended method is to send patches through gpg-signed email +messages, which has the advantage of being mostly asynchronous. + +\paragraph{Keeping track of changes rather than versions} + +In the last paragraph, I explained revision control systems in terms of +three layers. One can also look at them as having two distinct uses. One +is to provide a history of previous versions. The other is to keep track +of changes that are made to the repository, and to allow these changes to +be merged and moved from one repository to another. These two uses are +distinct, and almost orthogonal, in the sense that a tool can support one +of the two uses optimally while providing no support for the other. Darcs +is not intended to maintain a history of versions, although it is possible +to kludge together such a revision history, either by making each new patch +depend on all previous patches, or by tagging regularly. In a sense, this +is what the tag feature is for, but the intention is that tagging will be +used only to mark particularly notable versions (e.g.\ released versions, or +perhaps versions that pass a time consuming test suite). + +Other revision control systems are centered upon the job of keeping track +of a history of versions, with the ability to merge changes being added as +it was seen that this would be desirable. But the fundamental object +remained the versions themselves. + +In such a system, a patch (I am using patch here to mean an encapsulated +set of changes) is uniquely determined by two trees. Merging changes that +are in two trees consists of finding a common parent tree, computing the +diffs of each tree with their parent, and then cleverly combining those two +diffs and applying the combined diff to the parent tree, possibly at some +point in the process allowing human intervention, to allow for fixing up +problems in the merge such as conflicts. + +In the world of darcs, the source tree is \emph{not} the fundamental +object, but rather the patch is the fundamental object. Rather than a +patch being defined in terms of the difference between two trees, a tree is +defined as the result of applying a given set of patches to an empty tree. +Moreover, these patches may be reordered (unless there are dependencies +between the patches involved) without changing the tree. As a result, +there is no need to find a common parent when performing a merge. Or, if +you like, their common parent is defined by the set of common patches, and +may not correspond to any version in the version history. + +One useful consequence of darcs' patch-oriented philosophy is that since a +patch need not be uniquely defined by a pair of trees (old and new), we can +have several ways of representing the same change, which differ only in how +they commute and what the result of merging them is. Of course, creating +such a patch will require some sort of user input. This is a Good Thing, +since the user \emph{creating} the patch should be the one forced to think +about what he really wants to change, rather than the users merging the +patch. An example of this is the token replace patch (See +Section~\ref{token_replace}). This feature makes it possible to create a +patch, for example, which changes every instance of the variable +``stupidly\_named\_var'' to ``better\_var\_name'', while leaving +``other\_stupidly\_named\_var'' untouched. When this patch is merged with +any other patch involving the ``stupidly\_named\_var'', that instance will +also be modified to ``better\_var\_name''. This is in contrast to a more +conventional merging method which would not only fail to change new +instances of the variable, but would also involve conflicts when merging +with any patch that modifies lines containing the variable. By more using +additional information about the programmer's intent, darcs is thus able to +make the process of changing a variable name the trivial task that it +really is, which is really just a trivial search and replace, modulo +tokenizing the code appropriately. + +The patch formalism discussed in Appendix~\ref{Patch} is what makes darcs' +approach possible. In order for a tree to consist of a set of patches, +there must be a deterministic merge of any set of patches, regardless of the +order in which they must be merged. This requires that one be able to +reorder patches. While I don't know that the patches are required to be +invertible as well, my implementation certainly requires invertibility. In +particular, invertibility is required to make use of +Theorem~\ref{merge_thm}, which is used extensively in the manipulation of +merges. + +\input{features.tex} + +\chapter{Getting started} + +This chapter will lead you through an example use of darcs, which hopefully +will allow you to get started using darcs with your project. + +\section{Creating your repository} + +Creating your repository in the first place just involves telling darcs to +create the special directory (called {\tt \_darcs}) in your project tree, +which will hold the revision information. This is done by simply calling +from the root directory of your project: +\begin{verbatim} +$ cd my_project/ +$ darcs initialize +\end{verbatim} +This creates the \verb|_darcs| directory and populates it with whatever +files and directories are needed to describe an empty project. You now +need to tell darcs what files and directories in your project should be +under revision control. You do this using the command \verb|darcs add|% +\footnote{Note that darcs does not do wildcard expansion, instead relying +on the command shell. The Windows port of darcs has a limited form of +expansion provided by the C runtime}: +\begin{verbatim} +$ darcs add *.c Makefile.am configure.ac +\end{verbatim} +When you have added all your files (or at least, think you have), you will +want to record your changes. ``Recording'' always includes adding a note +as to why the change was made, or what it does. In this case, we'll just +note that this is the initial version. +\begin{verbatim} +$ darcs record --all +What is the patch name? Initial revision. +\end{verbatim} +Note that since we didn't specify a patch name on the command line we were +prompted for one. If the environment variable `EMAIL' isn't set, you will +also be prompted for your email address. Each patch that is recorded is +given a unique identifier consisting of the patch name, its creator's email +address, and the date when it was created. + +\section{Making changes} + +Now that we have created our repository, make a change to one or more of +your files. After making the modification run: +\begin{verbatim} +$ darcs whatsnew +\end{verbatim} +This should show you the modifications that you just made, in the darcs +patch format. If you prefer to see your changes in a different format, +read Section~\ref{whatsnew}, which describes the whatsnew command in +detail. + +Let's say you have now made a change to your project. The next thing to do +is to record a patch. Recording a patch consists of grouping together a +set of related changes, and giving them a name. It also tags the patch +with the date it was recorded and your email address. + +To record a patch simply type: +\begin{verbatim} +$ darcs record +\end{verbatim} +darcs will then prompt you with all the changes that you have made that +have not yet been recorded, asking you which ones you want to include in +the new patch. Finally, darcs will ask you for a name for the patch. + +You can now rerun whatsnew, and see that indeed the changes you have +recorded are no longer marked as new. + +\section{Making your repository visible to others} +How do you let the world know about these wonderful changes? Obviously, +they must be able to see your repository. Currently the easiest way to do +this is typically by http using any web server. The recommended way to do +this (using apache in a UNIX environment) is to create a directory called +{\tt /var/www/repos}, and then put a symlink to your repository there: +\begin{verbatim} +$ cd /var/www/repos +$ ln -s /home/username/myproject . +\end{verbatim} + +\section{Getting changes made to another repository} +Ok, so I can now browse your repository using my web browser\ldots\ so +what? How do I get your changes into \emph{my} repository, where they can +do some good? It couldn't be easier. I just \verb|cd| into my repository, +and there type: +\begin{verbatim} +$ darcs pull http://your.server.org/repos/yourproject +\end{verbatim} +Darcs will check to see if you have recorded any changes that aren't in my +current repository. If so, it'll prompt me for each one, to see which ones +I want to add to my repository. Note that you may see a different series +of prompts depending on your answers, since sometimes one patch depends on +another, so if you answer yes to the first one, you won't be prompted for +the second if the first depends on it. + +Of course, maybe I don't even have a copy of your repository. In that case +I'd want to do a +\begin{verbatim} +$ darcs get http://your.server.org/repos/yourproject +\end{verbatim} +which gets the whole repository. + +I could instead create an empty repository and fetch all of your patches +with pull. Get is just a more efficient way to clone a whole repository. + +Get, pull and push also work over ssh. Ssh-paths are of the same form +accepted by scp, namely \verb|[username@]host:/path/to/repository|. + +\section{Moving patches from one repository to another} + +Darcs is flexible as to how you move patches from one repository to another. +This section will introduce all the ways you can get patches from one place +to another, starting with the simplest and moving to the most complicated. + +\subsection{All pulls} + +The simplest method is the ``all-pull'' method. This involves making each +repository readable (by http, ftp, nfs-mounted disk, whatever), and you +run \verb|darcs pull| in the repository you want to move the patch to. This is nice, +as it doesn't require you to give write access to anyone else, and is +reasonably simple. + +\subsection{Send and apply manually} + +Sometimes you have a machine on which it is not convenient to set up a web +server, perhaps because it's behind a firewall or perhaps for security +reasons, or because it is often turned off. In this case you can use +\verb|darcs send| +from that computer to generate a patch bundle destined for another +repository. You can either let darcs email the patch for you, or save it +as a file and transfer it by hand. Then in the destination repository you +(or the owner of that repository) run \verb|darcs apply| to apply the patches contained +in the bundle. This is also quite a simple method since, like the all-pull +method, it doesn't require that you give anyone write access to your +repository. But it's less convenient, since you have to keep track of the +patch bundle (in the email, or whatever). + +If you use the send and apply method with email, you'll probably want to +create a \verb!_darcs/prefs/email! file containing your email address. +This way anyone who sends to your repository will automatically send the +patch bundle to your email address. + +If you receive many patches by email, you probably will benefit by running +darcs apply directly from your mail program. I have in my \verb!.muttrc! +the following: +\begin{verbatim} +auto_view text/x-patch text/x-darcs-patch +macro pager A "darcs apply --verbose --mark-conflicts \ + --reply droundy@abridgegame.org --repodir ~/darcs" +\end{verbatim} +which allows me to view a sent patch, and then apply the patch directly from \verb!mutt!, sending a +confirmation email to the person who sent me the patch. The autoview line relies on on the following +lines, or something like them, being present in one's \verb!.mailcap!: +\begin{verbatim} +text/x-patch; cat; copiousoutput +text/x-darcs-patch; cat; copiousoutput +\end{verbatim} + +\subsection{Push} + +If you use ssh (and preferably also ssh-agent, so you won't have to keep +retyping your password), you can use the push method to transfer changes +(using the scp protocol for communication). This method is again not very +complicated, since you presumably already have the ssh permissions set up. +Push can also be used when the target repository is local, in which case +ssh isn't needed. On the other hand, in this situation you could as easily +run a pull, so there isn't much benefit. + +Note that you can use push to administer a multiple-user repository. You +just need to create a user for the repository (or repositories), and give +everyone with write access ssh access, perhaps using +\verb!.ssh/authorized_keys!. Then they run +\begin{verbatim} +$ darcs push repouser@repo.server:repo/directory +\end{verbatim} + +\subsection{Push ---apply-as} + +Now we get more subtle. If you like the idea in the previous paragraph +about creating a repository user to own a repository which is writable by +a number of users, you have one other option. + +Push \verb!--apply-as! can run on either a local repository or one accessed +with ssh, but uses \verb!sudo! to run a darcs apply command (having created +a patch bundle as in send) as another user. You can add the following line +in your \verb|sudoers| file to allow the users to apply their patches to a +centralized repository: +{\small +\begin{verbatim} +ALL ALL = (repo-user) NOPASSWD: /usr/bin/darcs apply --all --repodir /repo/path* +\end{verbatim} +} +This method is ideal for a centralized repository when all the users have +accounts on the same computer, if you don't want your users to be able to +run arbitrary commands as repo-user. + +\subsection{Sending signed patches by email} + +Most of the previous methods are a bit clumsy if you don't want to give +each person with write access to a repository an account on your server. Darcs +send can be configured to send a cryptographically signed patch by email. +You can then set up your mail system to have darcs verify that patches were +signed by an authorized user and apply them when a patch is received by +email. The results of the apply can be returned to the user by email. +Unsigned patches (or patches signed by unauthorized users) will be +forwarded to the repository owner (or whoever you configure them to be +forwarded to\ldots). + +This method is especially nice when combined with the \verb!--test! option +of darcs apply, since it allows you to run the test suite (assuming you +have one) and reject patches that fail---and it's all done on the server, +so you can happily go on working on your development machine without +slowdown while the server runs the tests. + +Setting up darcs to run automatically in response to email is by far the +most complicated way to get patches from one repository to another\ldots\ so it'll +take a few sections to explain how to go about it. + +\paragraph{Security considerations} + +When you set up darcs to run apply on signed patches, you should assume +that a user with write access can write to any file or directory that is +writable by the user under which the apply process runs. Unless you +specify the \verb!--no-test! flag to darcs apply (and this is \emph{not} +the default), you are also allowing anyone with write access to that +repository to run arbitrary code on your machine (since they can run a test +suite---which they can modify however they like). This is quite a +potential security hole. + +For these reasons, if you don't implicitly trust your users, it is +recommended that you create a user for each repository to limit the damage +an attacker can do with access to your repository. When considering who to +trust, keep in mind that a security breach on any developer's machine could +give an attacker access to their private key and passphrase, and thus to +your repository. + +\paragraph{Installing necessary programs} + +You also must install the following programs: gnupg, a mailer configured to +receive mail (e.g.\ exim, sendmail or postfix), and a web server (usually +apache). + +\paragraph{Granting access to a repository} + +You create your gpg key by running (as your normal user): +\begin{verbatim} +$ gpg --gen-key +\end{verbatim} +You will be prompted for your name and email address, among other options. +%%To add your public key to the allowed keys keyring. +Of course, you can +skip this step if you already have a gpg key you wish to use. + +You now need to export the public key so we can tell the patcher about it. +You can do this with the following command (again as your normal user): +\begin{verbatim} +$ gpg --export "email@address" > /tmp/exported_key +\end{verbatim} +And now we can add your key to the \verb!allowed_keys!: +\begin{verbatim} +(as root)> gpg --keyring /var/lib/darcs/repos/myproject/allowed_keys \ + --no-default-keyring --import /tmp/exported_key +\end{verbatim} +You can repeat this process any number of times to authorize multiple users +to send patches to the repository. + +You should now be able to send a patch to the repository by running as your +normal user, in a working copy of the repository: +\begin{verbatim} +$ darcs send --sign http://your.computer/repos/myproject +\end{verbatim} +You may want to add ``send sign'' to the file \verb!_darcs/prefs/defaults! +so that you won't need to type \verb!--sign! every time you want to +send\ldots + +If your gpg key is protected by a passphrase, then executing \verb!send! +with the \verb!--sign! option might give you the following error: +\begin{verbatim} +darcs failed: Error running external program 'gpg' +\end{verbatim} +The most likely cause of this error is that you have a misconfigured +gpg that tries to automatically use a non-existent gpg-agent +program. GnuPG will still work without gpg-agent when you try to sign +or encrypt your data with a passphrase protected key. However, it will +exit with an error code 2 (\verb!ENOENT!) causing \verb!darcs! to +fail. To fix this, you will need to edit your \verb!~/.gnupg/gpg.conf! +file and comment out or remove the line that says: +\begin{verbatim} +use-agent +\end{verbatim} +If after commenting out or removing the \verb!use-agent! line in your +gpg configuration file you still get the same error, then you probably +have a modified GnuPG with use-agent as a hard-coded option. In that +case, you should change \verb!use-agent! to \verb!no-use-agent! to +disable it explicitly. + +\paragraph{Setting up a sendable repository using procmail} +If you don't have root access on your machine, or perhaps simply don't want +to bother creating a separate user, you can set up a darcs repository using +procmail to filter your mail. I will assume that you already use procmail +to filter your email. If not, you will need to read up on it, or perhaps +should use a different method for routing the email to darcs. + +To begin with, you must configure your repository so that a darcs send to +your repository will know where to send the email. Do this by creating a +file in \verb!/path/to/your/repo/_darcs/prefs! called \verb!email! +containing your email address. As a trick (to be explained below), we will +create the email address with ``darcs repo'' as your name, in an email +address of the form ``David Roundy $<$droundy@abridgegame.org$>$.'' +\begin{verbatim} +$ echo 'my darcs repo ' \ + > /path/to/your/repo/_darcs/prefs/email +\end{verbatim} + +The next step is to set up a gnupg keyring containing the public keys of +people authorized to send to your repository. Here I'll give a second way of +going about this (see above for the first). This time I'll assume you +want to give me write access to your repository. You can do this by: +\begin{verbatim} +gpg --no-default-keyring \ + --keyring /path/to/the/allowed_keys --recv-keys D3D5BCEC +\end{verbatim} +This works because ``D3D5BCEC'' is the ID of my gpg key, and I have +uploaded my key to the gpg keyservers. Actually, this also requires that +you have configured gpg to access a valid keyserver. You can, of course, +repeat this command for all keys you want to allow access to. + +Finally, we add a few lines to your \verb!.procmailrc!: +\begin{verbatim} +:0 +* ^TOmy darcs repo +|(umask 022; darcs apply --reply user@host.com \ + --repodir /path/to/your/repo --verify /path/to/the/allowed_keys) +\end{verbatim} +The purpose for the ``my darcs repo'' trick is partially to make it easier +to recognize patches sent to the repository, but is even more crucial to +avoid nasty bounce loops by making the \verb!--reply! option have an email +address that won't go back to the repository. This means that unsigned +patches that are sent to your repository will be forwarded to your ordinary +email. + +Like most mail-processing programs, Procmail by default sets a tight umask. +However, this will prevent the repository from remaining world-readable; +thus, the ``umask 022'' is required to relax the umask. +(Alternatively, you could set Procmail's global \verb!UMASK! variable +to a more suitable value.) + +\paragraph{Checking if your e-mail patch was applied} + +After sending a patch with \verb!darcs send!, you may not receive any feedback, +even if the patch is applied. You can confirm whether or not your patch was applied +to the remote repository by pointing \verb!darcs changes! at a remote repository: +\begin{verbatim} +darcs changes --last=10 --repo=http://darcs.net/ +\end{verbatim} + +That shows you the last 10 changes in the remote repository. You can adjust the options given +to \verb!changes! if a more advanced query is needed. + +\input{configuring_darcs.tex} + +\input{best_practices.tex} + +\input{formats.tex} + +\chapter{Darcs commands} + +\input{Darcs/Commands.lhs} + +\section{Options apart from darcs commands} +\begin{options} +--help +\end{options} +Calling darcs with just \verb|--help| as an argument gives a brief +summary of what commands are available. +\begin{options} +--version, --exact-version +\end{options} +Calling darcs with the flag \verb|--version| tells you the version of +darcs you are using. Calling darcs with the flag \verb|--exact-version| +gives the precise version of darcs, even if that version doesn't correspond +to a released version number. This is helpful with bug reports, especially +when running with a ``latest'' version of darcs. +\begin{options} +--commands +\end{options} +Similarly calling darcs with only \verb|--commands| gives a simple list +of available commands. This latter arrangement is primarily intended for +the use of command-line autocompletion facilities, as are available in +bash. + +\section{Getting help} + +\input{Darcs/Commands/Help.lhs} + +\section{Creating repositories} + +\input{Darcs/Commands/Init.lhs} + +\input{Darcs/Commands/Get.lhs} + +\input{Darcs/Commands/Put.lhs} + +\section{Modifying the contents of a repository} + +\input{Darcs/Commands/Add.lhs} + +\input{Darcs/Commands/Remove.lhs} + +\input{Darcs/Commands/Move.lhs} + +\input{Darcs/Commands/Replace.lhs} + +\section{Working with changes} + +\input{Darcs/Commands/Record.lhs} + +\input{Darcs/Commands/Pull.lhs} + +\input{Darcs/Commands/Push.lhs} + +\input{Darcs/Commands/Send.lhs} + +\input{Darcs/Commands/Apply.lhs} + +\section{Seeing what you've done} + +\input{Darcs/Commands/WhatsNew.lhs} + +\input{Darcs/Commands/Changes.lhs} + +\input{Darcs/Commands/Show.lhs} + +\section{More advanced commands} + +\input{Darcs/Commands/Tag.lhs} + +\input{Darcs/Commands/SetPref.lhs} + +\input{Darcs/Commands/Check.lhs} + +\input{Darcs/Commands/Optimize.lhs} + +\section{Undoing, redoing and running in circles} + +\input{Darcs/Commands/AmendRecord.lhs} + +\input{Darcs/Commands/Rollback.lhs} + +\input{Darcs/Commands/Unrecord.lhs} + +\input{Darcs/Commands/Revert.lhs} + +\input{Darcs/Commands/Unrevert.lhs} + +\section{Advanced examination of the repository} + +\input{Darcs/Commands/Diff.lhs} + +\input{Darcs/Commands/Annotate.lhs} + +% Includes the show commands. +\input{Darcs/Commands/Show.lhs} + +\section{Rarely needed and obscure commands} + +\input{Darcs/Commands/Convert.lhs} + +\input{Darcs/Commands/MarkConflicts.lhs} + +\input{Darcs/Commands/Dist.lhs} + +\input{Darcs/Commands/TrackDown.lhs} + +\input{Darcs/Commands/Repair.lhs} + +\appendix + +\input{switching.tex} + +\input{building_darcs.tex} + +\input{Darcs/Patch.lhs} + +\input{Darcs/Repository/DarcsRepo.lhs} + +\input{gpl.tex} + +\end{document} + + diff --git a/src/formats.tex b/src/formats.tex new file mode 100644 --- /dev/null +++ b/src/formats.tex @@ -0,0 +1,69 @@ +\chapter{Repository Formats} + +Darcs 2 supports three repository formats: + +\begin{itemize} +\item The current format, called `darcs-2'. It has the most features. +\item The original format, called `darcs-1' or `old-fashioned inventory'. + It is the only format supported by Darcs releases prior to 2.0. + Patches cannot be shared between darcs-2 and darcs-1 repositories. +\item An intermediary format, called `hashed'. It provides some of + the features of darcs-2, while retaining the ability to exchange + patches with darcs-1. Patches cannot be shared between darcs-2 and + hashed repositories. +\end{itemize} + +Note that references to the hashed format refer to hashed darcs-1 +repositories. All darcs-2 repositories are also hashed, and `darcs +show repo' in a darcs-2 repository will report the format as `hashed, +darcs-2'. + +The hashed (and darcs-2) format improves on the darcs-1 format in the +following ways: + +\begin{itemize} +\item Improved atomicity of operations. This improves the safety and + efficiency of those operations. +\item File names in the `pristine' copy of the working tree are + hashed. This greatly reduces the chance of a program accidentally + treating files in \_darcs/pristine as part of the working tree. + + For example, in darcs-1 running \verb|find -name "*.gif" -delete| + instead of \verb|find -name _darcs -prune -o -name "*.gif" -delete| + would result in GIF files in pristine files being deleted. + +\item Support for `lazy' repositories. This causes patches to be + copied from the parent repository on demand, rather than during the + initial `darcs get'. For repositories that only operate on recent + patches (such as feature branches), this reduces the repository's + size, and the time and bandwidth taken to create it. + + Lazy repositories are first-class repositories, and all operations + are supported as long as the parent repository remains accessible. + This isn't the case for the `partial' feature of the darcs-1 format. + +\item Support for caches that are shared by all repositories. When + operating on many similar repositories, the patches and pristine + files they have in common are hard links to the cache. This greatly + reduces storage requirements, and the time and bandwidth needed to + make similar repositories. +\end{itemize} + +The darcs-2 format improves on the hashed format in the following +ways: + +\begin{itemize} +\item The `exponential merge' problem is \emph{far} less likely to + occur (it can still be produced in deliberately pathological cases). +\item Identical primitive changes no longer conflict. For example, if + two patches both attempt to add a directory `tests', these patches + will not conflict. +\end{itemize} + +% The following reference is particularly important because init +% explains *when* to use each format, which I don't want to +% copy-and-paste here because then the two copies will get out of +% sync. + +See also `darcs initialize' (\ref{initialize}), `darcs convert' +(\ref{convert}) and `darcs get' (\ref{get}). diff --git a/src/fpstring.c b/src/fpstring.c --- a/src/fpstring.c +++ b/src/fpstring.c @@ -26,132 +26,12 @@ #include #endif -/* A locale-independent isspace(3) so patches are interpreted the same - * everywhere. */ -// #define ISSPACE(c) \ -// ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r') - -// int first_white(const char *s, int len) -// { -// const char *start; -// const char *end; -// -// for (start = s, end = s + len; s < end && !ISSPACE(*s); s++); -// -// return s - start; -// } - -// int first_nonwhite(const char *s, int len) -// { -// const char *start; -// const char *end; -// -// for (start = s, end = s + len; s < end && ISSPACE(*s); s++); -// -// return s - start; -// } - int has_funky_char(const char *s, int len) { // We check first for the more likely \0 so we can break out of // memchr that much sooner. return !!(memchr(s, 0, len) || memchr(s, 26, len)); -} - -// ForeignPtr debugging stuff... - -static int num_alloced = 0; - -void debug_free(void *p) { - num_alloced--; - fprintf(stderr, "Freeing %p (%d left)\n", p, num_alloced); -} - -void debug_alloc(void *p, const char *name) { - num_alloced++; - fprintf(stderr, "Allocating %p named %s (%d left)\n", - p, name, num_alloced); -} - -/* Specification: RFC 2279 */ - -int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n) { - /* returns number of unicode chars in the output. The output array is - assumed to have the same number of elements as the input array, which - is n. */ - - HsInt *pwc_original = pwc; - while (n > 0) { - unsigned char c = s[0]; - - if (c < 0x80) { - *pwc++ = c; - n--; - s++; - } else if (c < 0xc2) { - return -1; - } else if (c < 0xe0) { - if (n < 2) return -1; - if (!((s[1] ^ 0x80) < 0x40)) return -1; - *pwc++ = ((unsigned) (c & 0x1f) << 6) - | (unsigned) (s[1] ^ 0x80); - n -= 2; - s += 2; - } else if (c < 0xf0) { - if (n < 3) return -1; - if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 - && (c >= 0xe1 || s[1] >= 0xa0))) - return -1; - *pwc++ = ((unsigned) (c & 0x0f) << 12) - | ((unsigned) (s[1] ^ 0x80) << 6) - | (unsigned) (s[2] ^ 0x80); - n -= 3; - s += 3; - } else if (c < 0xf8 && sizeof(unsigned)*8 >= 32) { - if (n < 4) return -1; - if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 - && (s[3] ^ 0x80) < 0x40 - && (c >= 0xf1 || s[1] >= 0x90))) - return -1; - *pwc++ = ((unsigned) (c & 0x07) << 18) - | ((unsigned) (s[1] ^ 0x80) << 12) - | ((unsigned) (s[2] ^ 0x80) << 6) - | (unsigned) (s[3] ^ 0x80); - n -= 4; - s += 4; - } else if (c < 0xfc && sizeof(unsigned)*8 >= 32) { - if (n < 5) return -1; - if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 - && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 - && (c >= 0xf9 || s[1] >= 0x88))) - return -1; - *pwc++ = ((unsigned) (c & 0x03) << 24) - | ((unsigned) (s[1] ^ 0x80) << 18) - | ((unsigned) (s[2] ^ 0x80) << 12) - | ((unsigned) (s[3] ^ 0x80) << 6) - | (unsigned) (s[4] ^ 0x80); - n -= 5; - s += 5; - } else if (c < 0xfe && sizeof(unsigned)*8 >= 32) { - if (n < 6) return -1; - if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 - && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 - && (s[5] ^ 0x80) < 0x40 - && (c >= 0xfd || s[1] >= 0x84))) - return -1; - *pwc++ = ((unsigned) (c & 0x01) << 30) - | ((unsigned) (s[1] ^ 0x80) << 24) - | ((unsigned) (s[2] ^ 0x80) << 18) - | ((unsigned) (s[3] ^ 0x80) << 12) - | ((unsigned) (s[4] ^ 0x80) << 6) - | (unsigned) (s[5] ^ 0x80); - n -= 6; - s += 6; - } else - return -1; - } - return pwc - pwc_original; } /* Conversion to and from hex */ diff --git a/src/fpstring.h b/src/fpstring.h --- a/src/fpstring.h +++ b/src/fpstring.h @@ -1,15 +1,7 @@ #include #include -int wfindps_helper(char c, const char *s, int len); -void debug_free(void *p); -void debug_alloc(void *p, const char *name); - -// int first_white(const char *s, int len); -// int first_nonwhite(const char *s, int len); int has_funky_char(const char *s, int len); - -int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n); void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars); void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars); diff --git a/src/unit.lhs b/src/unit.lhs --- a/src/unit.lhs +++ b/src/unit.lhs @@ -48,23 +48,24 @@ import System.IO.Unsafe ( unsafePerformIO ) import ByteStringUtils hiding ( intercalate ) +import Codec.Binary.UTF8.Generic ( toString ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -import qualified Data.ByteString as B ( empty, concat, length, unpack, foldr, - cons, ByteString, null, filter, head ) -import Data.Char ( isPrint ) +import qualified Data.ByteString as B ( concat, empty ) import Darcs.Patch -import Darcs.Patch.Test -import Darcs.Patch.Unit ( patch_unit_tests ) +import Darcs.Test.Patch.Test +import Darcs.Test.Patch.Unit ( patch_unit_tests ) +import Darcs.Test.Email ( email_parsing, email_header_no_long_lines, + email_header_ascii_chars, email_header_lines_start, + email_header_no_empty_lines ) import Lcs ( shiftBoundaries ) import Test.QuickCheck -import Printer ( renderPS, text ) +import Printer ( renderPS ) import Darcs.Patch.Commute import Data.Array.Base import Data.Array.Unboxed import Control.Monad.ST -import Darcs.Ordered -import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal ) -import Darcs.Email ( make_email, read_email, formatHeader ) +import Darcs.Witnesses.Ordered +import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal ) import Test.HUnit ( assertBool, assertFailure ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework.Providers.HUnit ( testCase ) @@ -99,27 +100,22 @@ tests :: [Test] tests = patch_unit_tests ++ [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'" - (unpackPSfromUTF8 (BC.pack "hello world") == "hello world"), + (toString (BC.pack "hello world") == "hello world"), testBool "Checking that hex packing and unpacking preserves 'hello world'" (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world") == "hello world"), - testProperty "Checking that email can be parsed" - (\s -> - unlines ("":s++["", ""]) == - BC.unpack (read_email (renderPS - $ make_email "reponame" [] (Just (text "contents\n")) - (text $ unlines s) (Just "filename")))), - testProperty "Checking email header line length" email_header_no_long_lines, - testProperty "Checking email for illegal characters" email_header_ascii_chars, - testProperty "Checking for spaces at start of folded email header lines" email_header_lines_start, - testProperty "Checking that there are no empty lines in email headers" email_header_no_empty_lines, + email_parsing, + email_header_no_long_lines, + email_header_ascii_chars, + email_header_lines_start, + email_header_no_empty_lines, testProperty "Checking that B.concat works" prop_concatPS, testProperty "Checking that hex conversion works" prop_hex_conversion, testProperty "Checking that show and read work right" prop_read_show, testStringList "Checking known commutes" commute_tests, testStringList "Checking known merges" merge_tests, testStringList "Checking known canons" canonization_tests] - ++ check_subcommutes subcommutes_inverse "patch and inverse both commutex" + ++ check_subcommutes subcommutes_inverse "patch and inverse both commute" ++ check_subcommutes subcommutes_nontrivial_inverse "nontrivial commutes are correct" ++ check_subcommutes subcommutes_failure "inverses fail" ++ @@ -147,18 +143,18 @@ --runQuickCheckTest returnval prop_unravel_seq_merge testProperty "Checking inverse of inverse" prop_inverse_composition, testProperty "Checking the order of commutes" prop_commute_either_order, - testProperty "Checking commutex either way" prop_commute_either_way, - testProperty "Checking the double commutex" prop_commute_twice, - testProperty "Checking that merges commutex and are well behaved" prop_merge_is_commutable_and_correct, + testProperty "Checking commute either way" prop_commute_either_way, + testProperty "Checking the double commute" prop_commute_twice, + testProperty "Checking that merges commute and are well behaved" prop_merge_is_commutable_and_correct, testProperty "Checking that merges can be swapped" prop_merge_is_swapable, testProperty "Checking again that merges can be swapped (I'm paranoid) " prop_merge_is_swapable, testStringList "Checking that the patch validation works" test_check, - testStringList "Checking commutex/recommute" commute_recommute_tests, + testStringList "Checking commute/recommute" commute_recommute_tests, testStringList "Checking merge properties" generic_merge_tests, testStringList "Testing the lcs code" show_lcs_tests, testStringList "Checking primitive patch IO functions" primitive_show_read_tests, testStringList "Checking IO functions" show_read_tests, - testStringList "Checking primitive commutex/recommute" primitive_commute_recommute_tests + testStringList "Checking primitive commute/recommute" primitive_commute_recommute_tests ] \end{code} @@ -183,54 +179,6 @@ = (thetest p1 p2)++(pair_unit_tester thetest ps) \end{code} -\chapter{Email format tests} - -These tests check whether the emails generated by darcs meet a few criteria. -We check for line length and non-ASCII characters. We apparently do not have to -check for CR-LF newlines because that's handled by sendmail. - -\begin{code} - --- Check that formatHeader never creates lines longer than 78 characters --- (excluding the carriage return and line feed) -email_header_no_long_lines :: String -> String -> Bool -email_header_no_long_lines field value = - not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField value - where cleanField = clean_field_string field - -bs_lines :: B.ByteString -> [B.ByteString] -bs_lines = finalizeFold . B.foldr splitAtLines (B.empty, []) - where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines) - splitAtLines c (thisLine, prevLines) = (B.cons c thisLine, prevLines) - finalizeFold (lastLine, otherLines) = lastLine : otherLines - --- Check that an email header does not contain non-ASCII characters --- formatHeader doesn't escape field names, there is no such thing as non-ascii --- field names afaik -email_header_ascii_chars :: String -> String -> Bool -email_header_ascii_chars field value - = not (any (>127) (B.unpack (formatHeader cleanField value))) - where cleanField = clean_field_string field - --- Check that header the second and later lines of a header start with a space -email_header_lines_start :: String -> String -> Bool -email_header_lines_start field value = - all (\l -> B.null l || B.head l == 32) (tail headerLines) - where headerLines = bs_lines (formatHeader cleanField value) - cleanField = clean_field_string field - --- Checks that there are no lines in email headers with only whitespace -email_header_no_empty_lines :: String -> String -> Bool -email_header_no_empty_lines field value = - all (not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines - where headerLines = bs_lines (formatHeader cleanField value) - cleanField = clean_field_string field - -clean_field_string :: String -> String -clean_field_string = filter (\c -> isPrint c && c < '\x80' && c /= ':') - -\end{code} - \chapter{LCS} Here are a few quick tests of the shiftBoundaries function. @@ -307,10 +255,10 @@ canonization_tests = concatMap check_known_canon known_canons check_known_canon :: (Patch, Patch) -> [String] check_known_canon (p1,p2) = - if (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1) == p2 + if (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1) == p2 then [] else ["Canonization failed:\n"++show p1++"canonized is\n" - ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1 :: Patch) + ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1 :: Patch) ++"which is not\n"++show p2] known_canons :: [(Patch,Patch)] known_canons = @@ -383,7 +331,7 @@ Here we test to see if commuting patch A and patch B and then commuting the result gives us patch A and patch B again. The set of patches (A,B) is chosen from the set of all pairs of test patches by selecting those which -commutex with one another. +commute with one another. \begin{code} commute_recommute_tests :: [String] @@ -391,7 +339,7 @@ case take 200 [(p2:checkseq [p1,p]) test_patches, - commutex (p2:p2) /= Nothing] of commute_pairs -> pair_unit_tester t_commute_recommute commute_pairs where checkseq ps = check_a_patch $ join_patches ps primitive_commute_recommute_tests :: [String] @@ -400,15 +348,15 @@ [(p1:p1) /= Nothing, check_a_patch $ join_patches [p2,p1]] t_commute_recommute :: TwoPatchUnitTest t_commute_recommute p1 p2 = - if (commutex (p1:>= commutex) == Just (p1:p1) >>= commute) == Just (p2:>p1) then [] - else ["Failed to recommute:\n"++(show p1)++(show p2)++ - "we saw it as:\n"++show (commutex (p1:>= commutex) + else ["Failed to recommute:\n"++(show p2)++(show p1)++ + "we saw it as:\n"++show (commute (p2:>p1))++ + "\nAnd recommute was:\n"++show (commute (p2:>p1) >>= commute) ++ "\n"] \end{code} @@ -422,8 +370,8 @@ concatMap check_cant_commute known_cant_commute check_known_commute :: (Patch:< Patch, Patch:< Patch) -> [String] check_known_commute (p1: + case commute (p2:>p1) of + Just (p1a:>p2a) -> if (p2a:< p1a) == (p2':< p1') then [] else ["Commute gave wrong value!\n"++show p1++"\n"++show p2 @@ -431,8 +379,8 @@ ++"but is\n"++show p2a++"\n"++show p1a] Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2] ++ - case commutex (p2': + case commute (p1':>p2') of + Just (p2a:>p1a) -> if (p1a:< p2a) == (p1:< p2) then [] else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a @@ -491,10 +439,10 @@ check_cant_commute :: (Patch:< Patch) -> [String] check_cant_commute (p1:p1) of Nothing -> [] _ -> [show p1 ++ "\n\n" ++ show p2 ++ - "\nArgh, these guys shouldn't commutex!\n"] + "\nArgh, these guys shouldn't commute!\n"] known_cant_commute :: [(Patch:< Patch)] known_cant_commute = [ (testhunk 2 ["o"] ["n"]:< @@ -644,8 +592,8 @@ _ :/\: p2' -> case merge (p1:\/:p2) of _ :/\: p1' -> - case commutex (p2': + case commute (p1:>p2') of + Just (_:>p1'b) -> if p1'b /= p1' then ["Merge swapping problem with...\np1 "++ show p1++"merged with\np2 "++ @@ -657,7 +605,7 @@ Nothing -> ["Merge commuting problem with...\np1 "++ show p1++"merged with\np2 "++ show p2++"gives\np2' "++ - show p2'++"which doesn't commutex with p1.\n" + show p2'++"which doesn't commute with p1.\n" ] \end{code} @@ -731,15 +679,15 @@ take 50 [join_patches [p1,p2]| p1<-primitive_test_patches, p2<-filter (\p->checkseq [p1,p]) primitive_test_patches, - commutex (p2:p2) == Nothing] where checkseq ps = check_a_patch $ join_patches ps test_patches_composite = take 100 [join_patches [p1,p2]| p1<-primitive_test_patches, p2<-filter (\p->checkseq [p1,p]) primitive_test_patches, - commutex (p2:p2) /= Nothing, + commute (p1:>p2) /= Just (p2:>p1)] where checkseq ps = check_a_patch $ join_patches ps test_patches_two_composite_hunks = @@ -773,7 +721,7 @@ ++take 10 test_patches_two_composite_hunks ++take 2 test_patches_composite_four_hunks, check_a_patch $ join_patches [invert p1, p2], - commutex (p1:p1) /= Just (p1:>p2) ] test_patches = primitive_test_patches ++ diff --git a/src/win32/System/Posix.hs b/src/win32/System/Posix.hs --- a/src/win32/System/Posix.hs +++ b/src/win32/System/Posix.hs @@ -3,35 +3,31 @@ module System.Posix where -import Foreign.Ptr ( Ptr, castPtr, plusPtr ) -import Foreign.Storable ( peek, poke, sizeOf ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( peek ) import Foreign.C.Types ( CInt, CUInt, CULong, CTime ) import Foreign.C.String ( CString, withCString ) -import Foreign.Marshal.Alloc ( allocaBytes ) +import Foreign.Marshal.Array ( withArray ) +import Foreign.Marshal.Alloc ( alloca ) import System.Posix.Types ( EpochTime ) import System.IO ( Handle ) - -foreign import ccall "sys/utime.h _utime" c_utime :: CString -> Ptr a -> IO CInt +foreign import ccall "sys/utime.h _utime" c_utime :: CString -> Ptr CTime -> IO CInt setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () setFileTimes path atime mtime = path `withCString` \s -> do - allocaBytes 8 $ \p -> do - poke (castPtr p :: Ptr CTime) (atime) - poke (castPtr (plusPtr p 4) :: Ptr CTime) (mtime) - c_utime s p - return () + withArray [atime,mtime] $ \p -> do c_utime s p + return () foreign import ccall "time" c_ctime :: Ptr CTime -> IO CInt epochTime :: IO EpochTime epochTime = do - allocaBytes (sizeOf (undefined :: CTime)) $ \p -> do - c_ctime p - t <- peek p :: IO CTime - return t + alloca $ \p -> do c_ctime p + t <- peek p :: IO CTime + return t foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt diff --git a/src/witnesses.hs b/src/witnesses.hs --- a/src/witnesses.hs +++ b/src/witnesses.hs @@ -1,3 +1,6 @@ +import Version +-- import Preproc -- imports Darcs.Commands.Help +-- import Darcs.ArgumentDefaults -- imports Darcs.Commands.Help import Darcs.Patch.Real import Darcs.Patch.Properties import Darcs.Patch.Bundle @@ -6,16 +9,46 @@ import Darcs.Patch.Match import Darcs.Repository.HashedRepo import Darcs.Resolution -import Darcs.Patch.Check +import Darcs.Test.Patch.Check import Darcs.Repository.Pristine import Darcs.Repository.DarcsRepo import Darcs.Repository.Internal -import Darcs.Commands.Unrevert -import Darcs.Commands.WhatsNew -import Darcs.Commands.Show -import Darcs.Commands.Unrecord +-- import Darcs.Commands.Add +import Darcs.Commands.Annotate +-- import Darcs.Commands.AmendRecord -- depends on Darcs.Commands.Record +import Darcs.Commands.Apply +-- import Darcs.Commands.Changes -- does lots of nasty filtering of patch lists +-- import Darcs.Commands.Check +-- import Darcs.Commands.Convert +import Darcs.Commands.Diff import Darcs.Commands.Dist -import Darcs.Commands.TransferMode +-- import Darcs.Commands.Get import Darcs.Commands.GZCRCs +-- import Darcs.Commands.Help -- depends on Darcs.TheCommands +import Darcs.Commands.Init +-- import Darcs.Commands.MarkConflicts +-- import Darcs.Commands.Move +-- import Darcs.Commands.Optimize +import Darcs.Commands.Pull +import Darcs.Commands.Push +-- import Darcs.Commands.Put +-- import Darcs.Commands.Record +-- import Darcs.Commands.Remove -- depends on Darcs.Commands.Add +-- import Darcs.Commands.Repair +-- import Darcs.Commands.Replace +-- import Darcs.Commands.Revert +-- import Darcs.Commands.Rollback -- depends on Darcs.Commands.Rollback +import Darcs.Commands.Send +import Darcs.Commands.SetPref +import Darcs.Commands.Show +-- import Darcs.Commands.Tag -- depends on Darcs.Commands.Tag +import Darcs.Commands.TrackDown +import Darcs.Commands.TransferMode +import Darcs.Commands.Unrevert +import Darcs.Commands.Unrecord +import Darcs.Commands.WhatsNew + +-- import Darcs.RunCommand -- imports Darcs.Commands.Help +-- import Darcs.TheCommands -- pulls in all other commands main = return () diff --git a/tests/EXAMPLE.sh b/tests/EXAMPLE.sh --- a/tests/EXAMPLE.sh +++ b/tests/EXAMPLE.sh @@ -28,11 +28,16 @@ rm -rf R S # Another script may have left a mess. darcs init --repo R # Create our test repos. darcs init --repo S -mkdir R/d/ R/e/ # Change the working tree. -echo 'Example content.' >R/d/f -darcs record --repo R -lam 'Add d/f and e.' -darcs mv --repo R d/f e/ -darcs record --repo R -am 'Move d/f to e/f.' -darcs push --repo R S -a # Try to push patches between repos. -darcs push --repo S R -rm -rf R/ S/ # Clean up after ourselves. + +cd R +mkdir d e # Change the working tree. +echo 'Example content.' > d/f +darcs record -lam 'Add d/f and e.' +darcs mv d/f e/ +darcs record -am 'Move d/f to e/f.' +darcs push ../S -a # Try to push patches between repos. +cd .. + +cd S +darcs push ../R -a +cd .. diff --git a/tests/check.sh b/tests/check.sh --- a/tests/check.sh +++ b/tests/check.sh @@ -27,9 +27,16 @@ . lib # Load some portability helpers. rm -rf R # Another script may have left a mess. darcs init --repo R -darcs setpref --repo R test true -darcs record --repo R -am 'true test' +darcs setpref --repo R test 'grep hello f' +not darcs record --repo R -am 'true test' +darcs record --repo R -am 'true test' --no-test + touch R/f -darcs record --repo R -lam 'added foo' -darcs check --repo R --test +darcs record --repo R -lam 'added foo' --no-test +darcs tag --repo R -m 'got f?' + +echo hello > R/f +darcs record --repo R -lam 'hellofoo' +darcs chec --repo R --test + rm -rf R # Clean up after ourselves. diff --git a/tests/checkpoint.sh b/tests/checkpoint.sh --- a/tests/checkpoint.sh +++ b/tests/checkpoint.sh @@ -2,6 +2,9 @@ # A test for unrecording checkpoint tags, inspired by issue517 +exit 200 # checkpoint creation is not supported by current darcs + # we would need a testdata tarball for this test + set -ev darcs --version diff --git a/tests/diff.sh b/tests/diff.sh --- a/tests/diff.sh +++ b/tests/diff.sh @@ -10,8 +10,8 @@ darcs add afile.txt darcs record --author me --all --no-test --patch-name init darcs diff -darcs diff -p . --store > diffinmem -darcs diff -p . > diffondisk +darcs diff -p . --store-in-mem > diffinmem +darcs diff -p . --no-store-in-mem > diffondisk diff diffinmem diffondisk cd .. diff --git a/tests/dist-v.sh b/tests/dist-v.sh new file mode 100644 --- /dev/null +++ b/tests/dist-v.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +# tests for "darcs dist" + +not () { "$@" && exit 1 || :; } + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +# needs fixed on FreeBSD +darcs dist -v 2> log +not grep error log +cd .. + +rm -rf temp1 + diff --git a/tests/emailformat.sh b/tests/emailformat.sh new file mode 100644 --- /dev/null +++ b/tests/emailformat.sh @@ -0,0 +1,43 @@ +#!/usr/bin/env bash + +. ../tests/lib + +set -ev +switch_to_latin9_locale +rm -rf temp1 +rm -rf temp2 +mkdir temp1 +mkdir temp2 +cd temp1 + +seventysevenaddy="" + +darcs init + +echo "Have you seen the smørrebrød of René Çavésant?" > non_ascii_file +darcs add non_ascii_file +darcs record -am "non-ascii file add" -A test + +cd ../temp2 +darcs init +cd ../temp1 + +# long email adress: check that email adresses of <= 77 chars don't get split up +darcs send --from="Kjålt Überström $seventysevenaddy" \ + --subject "Un patch pour le répositoire" \ + --to="Un garçon français " \ + --sendmail-command='tee mail_as_file %<' \ + -a ../temp2 + +cat mail_as_file +# The long mail address should be in there as a whole +grep $seventysevenaddy mail_as_file + +# Check that there are no non-ASCII characters in the mail +ghc -e 'getContents >>= return . not . any (> Data.Char.chr 127)' < mail_as_file | grep '^True$' + + +cd .. +rm -rf temp1 +rm -rf temp2 + diff --git a/tests/external-resolution.sh b/tests/external-resolution.sh new file mode 100644 --- /dev/null +++ b/tests/external-resolution.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash +. lib + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 +darcs init +echo "Conflict, Base ." > child_of_conflict +darcs add child_of_conflict +darcs record -am 'Conflict Base' +cd .. +darcs get temp1 temp2 + +# Add and record differing lines to both repos +cd temp1 +echo "Conflict, Part 1." > child_of_conflict +darcs record -A author -am 'Conflict Part 1' +cd .. +cd temp2 +echo "Conflict, Part 2." > child_of_conflict +darcs record -A author -am 'Conflict Part 2' +cd .. + +cd temp1 +echo | darcs pull -a ../temp2 --external-merge 'cp %2 %o' +cd .. + +diff -u temp1/child_of_conflict temp2/child_of_conflict + +rm -rf temp1 temp2 diff --git a/tests/failed-amend-should-not-break-repo.sh b/tests/failed-amend-should-not-break-repo.sh new file mode 100644 --- /dev/null +++ b/tests/failed-amend-should-not-break-repo.sh @@ -0,0 +1,58 @@ +#!/usr/bin/env bash +## Test for keeping the repository in consitent state in case +## of a test failure on amend-record. The bug was almost introduced +## when trying to fix issue 1406. +## +## Copyright (C) 2009 Kamil Dworakowski +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib +set -ev +rm -rf R +mkdir R +cd R +darcs init +# first patch: new file A +touch A +darcs add A +darcs record -a -m 'A' +# second patch: mv A to B +darcs mv A B +echo y | darcs record -a -m 'move' +# third patch: modify B +echo "content" > B +echo y | darcs record -a -m 'add content' + +# amending 'move' results in commuting 'move' patch +# to the end for removal. The commute changes the "add content" +# patch to modify A instead of B. But the amend is interrupted +# because of test failure. Check the consitency after the operation. +darcs setpref test false +echo yy | not darcs amend -p move +darcs check + +# Note: Amend-record in case of test failure is broken as described in issue1406, +# though when trying to fix it I almost managed to break darcs even more. +# This test is to guard against such regressions in the future. + +cd .. +rm -rf R diff --git a/tests/failing-add_permissions.sh b/tests/failing-add_permissions.sh new file mode 100644 --- /dev/null +++ b/tests/failing-add_permissions.sh @@ -0,0 +1,36 @@ +#!/usr/bin/env bash +## Darcs should refuse to add an unreadable file, because unreadable +## files aren't recordable. +## +## Copyright (C) 2005 Mark Stosberg +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +abort_windows # does not work on Windows. +rm -rf temp1 # Another script may have left a mess. +darcs initialize --repodir temp1 +touch temp1/unreadable +chmod a-r temp1/unreadable # Make the file unreadable. +not darcs add --repodir temp1 no_perms.txt 2>temp1/log +fgrep -i 'permission denied' temp1/log +rm -rf temp1 diff --git a/tests/failing-issue1013_either_dependency.sh b/tests/failing-issue1013_either_dependency.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1013_either_dependency.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash +set -ev +export DARCS_EMAIL=test +rm -rf tmp_d1 tmp_d2 tmp_d +# Preparations: +# Set up two repos, each with a patch (d1 and d2 respectively) with both +# an individual change and a change that is identical in both repos, +# and thus auto-merge, i.e., they don't conflict in darcs2. Pull them +# together and record a patch (problem) on top of the auto-merged change, +# so that it depends on EITHER of two patches. + +mkdir tmp_d1; cd tmp_d1 +darcs init --darcs-2 +echo a > a +echo b > b +echo c > c +darcs rec -alm init +echo a-independent > a +echo c-common > c +darcs rec -am d1 +cd .. +darcs get --to-patch init tmp_d1 tmp_d2 +cd tmp_d2 +echo b-independent > b +echo c-common > c +darcs rec -am d2 +darcs pull -a ../tmp_d1 +# no conflicts -- c-common is identical +echo c-problem > c +darcs rec -am problem +cd .. + +# I want to pull the 'problem' patch, but expect darcs to get confused +# because it doesn't know how to select one of the two dependent patches. + +darcs get --to-patch init tmp_d2 tmp_d +cd tmp_d +echo n/n/y |tr / \\012 |darcs pull ../tmp_d2 +darcs cha + +# This is weird, we got d2 though we said No. I would have expected +# darcs to skip the 'problem' patch in this case. + +# Try to pull d1 and unpull d2. + +darcs pull -a ../tmp_d1 +exit 1 # darcs hangs here (2.0.2+77)! +echo n/y/d |tr / \\012 |darcs obl -p d2 + +# The obliterate fails with: patches to commute_to_end does not commutex (1) + +cd .. +rm -rf tmp_d1 tmp_d2 tmp_d diff --git a/tests/failing-issue1014_identical_patches.sh b/tests/failing-issue1014_identical_patches.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1014_identical_patches.sh @@ -0,0 +1,60 @@ +#!/usr/bin/env bash +set -ev + +# Set up a base repo. Our experiment will start from this point +mkdir base +cd base +darcs init --darcs-2 +printf "Line1\nLine2\nLine3\n" > foo +darcs rec -alm Base +cd .. + +# Now we want to record patch A, which will turn "Line2" into "Hello" +darcs get base a +cd a +printf "Line1\nHello\nLine3\n" > foo +darcs rec --ignore-times -am A +cd .. + +# Make B the same as A +darcs get base b +cd b +printf "Line1\nHello\nLine3\n" > foo +darcs rec --ignore-times -am B +cd .. + +# Now we make a patch C that depends on A +darcs get a ac +cd ac +printf "Line1\nWorld\nLine3\n" > foo +darcs rec --ignore-times -am C +cd .. + +# Merge A and B +darcs get a ab +cd ab +darcs pull -a ../b +darcs revert -a +cd .. + +# And merge in C too +darcs get ab abc +cd abc +darcs pull -a ../ac +darcs revert -a +cd .. + +# Now we can pull just B and C into base +darcs get base bc +cd bc +darcs pull ../abc -ap 'B|C' +cd .. + +# Now we have base, B and C in a repository. At this point we're correct. + +# Let's try merging AC with BC now, here we discover a bug. + +darcs get ac abc2 +cd abc2 +darcs pull -a ../bc + diff --git a/tests/failing-issue1190_unmarked_hunk_replace_conflict.sh b/tests/failing-issue1190_unmarked_hunk_replace_conflict.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1190_unmarked_hunk_replace_conflict.sh @@ -0,0 +1,43 @@ +#!/usr/bin/env bash +## Test for issue1190 - conflicts between HUNK and REPLACE are not +## marked by --mark-conflicts. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf d e # Another script may have left a mess. +darcs init --repo d/ +printf %s\\n foo bar baz >d/f +darcs record --repo d/ -lam f1 +darcs get d/ e/ +darcs replace --repo e/ --force bar baz f +darcs record --repo e/ -lam replacement +printf %s\\n foo bar quux >d/f # replace baz with quux +darcs record --repo d/ -am f2 + +## There ought to be a conflict here, and there is. +darcs pull --repo e/ d/ -a --mark-conflicts +## The file ought to now have conflict markers in it. +grep 'v v v' e/f +rm -rf d/ e/ # Clean up after ourselves. diff --git a/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh b/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +not () { "$@" && exit 1 || :; } + +rm -rf temp1 +mkdir temp1 +cd temp1 + +darcs init +touch aargh +darcs add aargh +echo utrecht > aargh + +darcs wh foo foo/../foo/. > out +cat out +not grep utrecht out + +cd .. +rm -rf temp1 + diff --git a/tests/failing-issue1266_init_inside_a_repo.sh b/tests/failing-issue1266_init_inside_a_repo.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1266_init_inside_a_repo.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +## Test for issue1266 - attempting to initialize a repository inside +## another repository should cause a warning, because while perfectly +## legitimate, it is likely to be accidental. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf temp1 out # Another script may have left a mess. +darcs init --repodir temp1 +darcs init --repodir temp1/temp2 2>&1 | tee out +grep -i WARNING out # A warning should be printed. diff --git a/tests/failing-issue1317_list-options_subdir.sh b/tests/failing-issue1317_list-options_subdir.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1317_list-options_subdir.sh @@ -0,0 +1,39 @@ +#!/bin/sh + +# Test for issue1317 - darcs mv --list-options returns results from root, and +# not from the current directory + +# Copyright 2009 Marco Túlio Gontijo e Silva + +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to deal +# in the Software without restriction, including without limitation the rights +# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +# copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: + +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. + +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +# THE SOFTWARE. + +. ../tests/lib +rm -rf R +mkdir R +cd R +darcs init +touch abcd +mkdir foo +darcs add foo +cd foo +touch abcc +mkdir bar +darcs mv --list-options | grep -x abcc +cd ../.. +rm -rf R diff --git a/tests/failing-issue1325_pending_minimisation.sh b/tests/failing-issue1325_pending_minimisation.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1325_pending_minimisation.sh @@ -0,0 +1,55 @@ +#!/usr/bin/env bash +## Test for issue1325 - hunk patches interfere with pending patch +## minimisation +## +## Copyright (C) 2009 Marco Túlio Gontijo e Silva, Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo=R +darcs init --repo=S + +# this is expected to pass regardless of issue1325 +# and is here to provide contrast +cd R +touch file +darcs add file +darcs record -am ' file' +mkdir b +darcs add b +darcs mv file b +rm -r b +darcs whatsnew | not grep adddir +cd .. + +# this is/was the failing part of issue1325 +cd S +echo file > file # we need a hunk to make this interesting +darcs add file +darcs record -am ' file' +mkdir b +darcs add b +darcs mv file b +rm -r b +darcs whatsnew | not grep adddir +cd .. diff --git a/tests/failing-issue1327.sh b/tests/failing-issue1327.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1327.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +set -ev + +# See issue1327. +# results in the error: +# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452 + + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo fileA version 1 > fileA +echo fileB version 1 > fileB +darcs add fileA fileB +darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB" +echo fileA version 2 > fileA +darcs record --author foo@bar --ignore-times --all -m "Modify fileA" +cd .. +darcs get temp1 temp2 +cd temp2 +darcs obliterate -p "Modify fileA" --all +darcs unrecord -p "Add fileA and fileB" --all +darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA" +cd ../temp1 +darcs pull --all ../temp2 +echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB" diff --git a/tests/failing-issue1332_add_r_boring.sh b/tests/failing-issue1332_add_r_boring.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1332_add_r_boring.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Test for issue1332 - add -r ignores --boring +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d +touch core f +# this is already known to work +darcs add --boring core f +darcs whatsnew > log +grep 'addfile ./f' log +grep 'addfile ./core' log +rm _darcs/patches/pending +# this fails for issue1332 +darcs add -r --boring . +darcs whatsnew > log +grep 'addfile ./f' log +grep 'addfile ./core' log +rm _darcs/patches/pending +cd .. diff --git a/tests/failing-issue1337_darcs_changes_false_positives.sh b/tests/failing-issue1337_darcs_changes_false_positives.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1337_darcs_changes_false_positives.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue1337 - darcs changes shows unrelated patches +## Asking "darcs changes" about an unrecorded file d/f will list the +## patch that creates the parent directory d/ (instead of no patches). +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf temp1 +darcs init --repodir temp1 +cd temp1 +mkdir d +darcs record -lam d d +# We use --match 'touch d/f' instead of simply d/f because the latter +# prints "Changes to d/f:\n" before the count. +test 0 -eq "$(darcs changes --count --match 'touch d/f')" diff --git a/tests/failing-issue1396_changepref-conflict.sh b/tests/failing-issue1396_changepref-conflict.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1396_changepref-conflict.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash +set -ev + +. ../tests/lib + +rm -rf temp1 temp1a temp1b + +mkdir temp1 +cd temp1 +darcs init +darcs setpref test 'echo nothing' +darcs record -am 'null pref' +cd .. + +darcs get temp1 temp1a +cd temp1a +darcs setpref test 'echo a' +darcs record -am 'pref a' +cd .. + +darcs get temp1 temp1b +cd temp1b +darcs setpref test 'echo b' +darcs record -am 'pref b' +cd .. + +cd temp1 +darcs pull -a ../temp1a --dont-allow-conflicts +not darcs pull -a ../temp1b --dont-allow-conflicts +cd .. + +rm -rf temp1 temp1a temp1b diff --git a/tests/failing-issue1401_bug_in_get_extra.sh b/tests/failing-issue1401_bug_in_get_extra.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1401_bug_in_get_extra.sh @@ -0,0 +1,44 @@ +#!/usr/bin/env bash +## Test for issue1401 - when two repos share a HUNK patch, but that +## patch's ADDFILE dependency is met by different patches in each +## repo, it becomes impossible to pull between the two repos. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +## This bug only affects darcs-2 repositories. +fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0 + +rm -rf d e # Another script may have left a mess. +darcs initialize --repodir d/ +darcs initialize --repodir e/ +touch d/f d/g e/f +darcs record --repodir d/ -lam 'Add f and g' +darcs record --repodir e/ -lam 'Add f' +echo >d/f +darcs record --repodir d/ -am 'Change f' +darcs pull --repodir e/ -a d/ +darcs obliterate --repodir e/ -ap 'Add f and g' +darcs pull --repodir e/ -a d/ +rm -rf d/ e/ # Clean up after ourselves. diff --git a/tests/failing-issue1406.sh b/tests/failing-issue1406.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1406.sh @@ -0,0 +1,85 @@ +#!/usr/bin/env bash +## Test for issue1406 - failed test on amend unrecords the +## original patch +## +## Copyright (C) 2009 Adam Vogt, Kamil Dworakowski +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +darcs init --repo S +mkdir R/d/ R/e/ # Change the working tree. +echo 'Example content.' >R/d/f +darcs record --repo R -lam 'Add d/f and e.' +darcs mv --repo R d/f e/ +darcs record --repo R -am 'Move d/f to e/f.' +darcs push --repo R S -a # Try to push patches between repos. +darcs push --repo S R +rm -rf R/ S/ # Clean up after ourselves. +#!/bin/sh +set -ev + +. ../tests/lib + +rm -rf temp1 +darcs init --repodir temp1 + +cd temp1 + +echo "test exit 1" > _darcs/prefs/prefs +echo "a" > a +darcs record --look-for-adds --no-test --all --patch-name=p1 +echo "b" >> a +echo "y" | not darcs amend-record --all --patch=p1 + +# There should be one patch in the repo +test 1 -eq `darcs changes --count` || exit 1 + +# Another check: there should be nothing new after a is restored +echo "a" > a +not darcs whatsnew -l + +cd .. +rm -rf test1 + +# the following section of the test does not create a new repo, +# it oprates on an existing old-fashioned repo; no need to run it 3 times +if grep 'old-fashioned' .darcs/defaults; then + + # check that we do the operations on checkpoints tentatively + rm -rf old-with-checkpoint + tar zxf ../tests/repos/old-with-checkpoint.tgz + + echo "test exit 1" > old-with-checkpoint/_darcs/prefs/prefs + + # this amend will fail + echo 'y' | not darcs amend --repo old-with-checkpoint -m 'no longer a checkpoint :P' -p "checkpoint here" + + # check that the patch has not been removed from + # the checkpoints inventory + grep "checkpoint here" old-with-checkpoint/_darcs/checkpoints/inventory + #NOTE: checking the file is a rather white box way of testing it, but + # I could not think of any other way at the time, please improve + + rm -rf old-with-checkpint +fi diff --git a/tests/failing-issue1442_encoding_round-trip.sh b/tests/failing-issue1442_encoding_round-trip.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1442_encoding_round-trip.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## -*- coding: utf-8 -*- +## Test for issue1442 - if we disable Darcs escaping and don't change +## our encoding, the bytes in a filename should be the same bytes that +## "darcs changes -v" prints to the right of "addfile" and "hunk". +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf R # Another script may have left a mess. + +## Use the first UTF-8 locale we can find. +export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1) +export DARCS_DONT_ESCAPE_ANYTHING=True + +## If LC_ALL is the empty string, this system doesn't support UTF-8. +if test -z "$LC_ALL" +then exit 1 +fi + +darcs init --repo R +echo '首頁 = א₀' >R/'首頁 = א₀' +darcs record --repo R -lam '首頁 = א₀' '首頁 = א₀' +darcs changes --repo R -v '首頁 = א₀' >R/log +#cat R/log # Show the humans what the output was. +grep -c '首頁 = א₀' R/log >R/count +echo 5 >R/expected-count +cmp R/count R/expected-count # Both count files should contain "5\n". +rm -rf R # Clean up after ourselves. diff --git a/tests/failing-issue1461_case_folding.sh b/tests/failing-issue1461_case_folding.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1461_case_folding.sh @@ -0,0 +1,83 @@ +#!/usr/bin/env bash +## Test for issue1461 - patches to files whose names only differ by +## case can be wrongly applied to the same file in the working directory. +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf lower upper joint # Another script may have left a mess. +mkdir lower upper + +cd lower +darcs init +cat > a << EOF +1 +2 +3 +EOF +darcs add a +darcs record -am 'lower init a' +cd .. + +cd upper +darcs init +cat > A << EOF +1 +2 +3 +EOF +darcs add A +darcs record -am 'upper init A' +cd .. + +darcs get lower joint +cd joint +darcs pull -a ../upper +cd .. + +cd lower +cat > a << EOF +one lower +2 +3 +EOF +darcs record -am 'lower modify' +cd .. + +cd upper +cat > A << EOF +1 +2 +three upper +EOF +darcs record -am 'upper modify' +cd .. + +cd joint +darcs pull ../lower -a +darcs pull ../upper -a +grep one a && not grep three a +grep three A && not grep one A +cd .. +# clean up after ourselves +rm -rf lower upper joint diff --git a/tests/failing-issue1473_annotate_repodir.sh b/tests/failing-issue1473_annotate_repodir.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1473_annotate_repodir.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +. ../tests/lib +rm -rf temp +mkdir temp +cd temp +darcs init +mkdir a b +touch a/a b/b +darcs add --rec . +darcs record -a -m ab -A test +darcs annotate a/a +# annotate --repodir=something '.' should work +cd .. +darcs annotate --repodir temp '.' +cd temp + +cd .. +rm -rf temp + diff --git a/tests/failing-issue1609_ot_convergence.sh b/tests/failing-issue1609_ot_convergence.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1609_ot_convergence.sh @@ -0,0 +1,104 @@ +#!/usr/bin/env bash +## Test for issue1609 - standard test for the TP2 property +## in the Operational Transformation literature. +## +## According to Wikipedia: +## For every three concurrent operations op1,op2 and op3 defined on the same +## document state, the transformation function T satisfies CP2/TP2 property +## if and only if: +## T(op_3, op_1 \circ T(op_2,op_1)) = T(op_3, op_2 \circ T(op_1,op_2)). +## +## Copyright (C) 2009 Eric Kow +## Copyright (C) 2009 Pascal Molli +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf S1 S2 S3 # Another script may have left a mess. +darcs init --repo S1 # Create our test repos. + +cd S1 +cat > f << END +1 +2 +3 +4 +5 +END +darcs add f +darcs record -am init +cd .. + +darcs get S1 S2 +darcs get S1 S3 + +cd S1 +cat > f << END +1 +2 +X +3 +4 +5 +END +darcs record -am 'insert X before line 3' +cd .. + +cd S2 +cat > f << END +1 +2 +4 +5 +END +darcs record -am 'delete line 3' +cd .. + +cd S3 +cat > f << END +1 +2 +3 +Y +4 +5 +END +darcs record -am 'insert Y after line 3' +cd .. + +darcs pull --allow-conflicts -a --repo S1 S2 +darcs pull --allow-conflicts -a --repo S2 S1 + +darcs pull --allow-conflicts -a --repo S1 S3 +darcs pull --allow-conflicts -a --repo S2 S3 + +darcs pull --allow-conflicts -a --repo S3 S1 + +# TP2 is just fine for conflict resolution itself... +diff S1/f S2/f # no difference +diff S2/f S3/f # no difference + +# But what about the conflict marking? +darcs mark-conflicts --repo S1 +darcs mark-conflicts --repo S2 +darcs mark-conflicts --repo S3 +diff S1/f S2/f # no difference +diff S2/f S3/f # no difference diff --git a/tests/failing-issue1610_get_extra.sh b/tests/failing-issue1610_get_extra.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1610_get_extra.sh @@ -0,0 +1,90 @@ +#!/usr/bin/env bash +## Test for issue1610 - another bug in get_extra problem +## This is an offshoot of the issue1609 test +## +## Copyright (C) 2009 Eric Kow +## Copyright (C) 2009 Pascal Molli +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. + +# this test is not relevant for darcs 2 repositories +(not grep darcs-2 $HOME/.darcs/defaults) || exit 200 + +rm -rf S1 S2 S3 # Another script may have left a mess. +darcs init --repo S1 # Create our test repos. + +cd S1 +cat > f << END +1 +2 +3 +4 +5 +END +darcs add f +darcs record -am init +cd .. + +darcs get S1 S2 +darcs get S1 S3 + +cd S1 +cat > f << END +1 +2 +X +3 +4 +5 +END +darcs record -am 'insert X before line 3' +cd .. + +cd S2 +cat > f << END +1 +2 +4 +5 +END +darcs record -am 'delete line 3' +cd .. + +cd S3 +cat > f << END +1 +2 +3 +Y +4 +5 +END +darcs record -am 'insert Y after line 3' +cd .. + +# please compare this with the issue1609 test +darcs pull -a --repo S1 S2 +darcs pull -a --repo S1 S3 + +darcs pull -a --repo S2 S1 +darcs pull -a --repo S2 S3 diff --git a/tests/failing-issue1632_changes_nonexisting.sh b/tests/failing-issue1632_changes_nonexisting.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1632_changes_nonexisting.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash +## Test for issue1632 - 'darcs changes d/f' should not list any changes, +## where d is part of the repo and f is a non-existent file. +## +## Copyright (C) 2009 Ben Franksen +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d +darcs record -lam 'added directory d' +# darcs should not list any changes here: +darcs changes non-existent-file > log +not grep 'added directory d' log +# ...and neither here: +darcs changes d/non-existent-file > log +not grep 'added directory d' log +cd .. diff --git a/tests/failing-issue1645-ignore-symlinks.sh b/tests/failing-issue1645-ignore-symlinks.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1645-ignore-symlinks.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash +## Test for issue1645 - whatsnew -l should not consider symlinks to be +## "real" files in the working tree. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R f # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +echo 'Example content.' > ../f # a file outside the repo +ln -s ../f # a symlink to same inside the repo +darcs whatsnew -l >log +fgrep 'No changes!' log # Darcs shouldn't report any changes. diff --git a/tests/failing-issue1702-optimize-relink-vs-cache.sh b/tests/failing-issue1702-optimize-relink-vs-cache.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1702-optimize-relink-vs-cache.sh @@ -0,0 +1,77 @@ +#!/usr/bin/env bash +## Test for issue1702 - an optimize --relink does not relink the files +## in ~/.darcs/cache. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +## Create a patch. +echo 'Example content.' > R/f +darcs record -lam 'Add f.' --repodir R + +## Get a hard link into the cache. +darcs get R S + +## Are hard links available? +x=(R/_darcs/patches/*-*) +x=${x#R/_darcs/patches/} +if [[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] +then + echo This test requires filesystem support for hard links. + echo This test requires the hashed (or darcs-2) repo format. + exit 200 +fi + +## IMPORTANT! In bash [[ ]] is neither a builtin nor a command; it is +## a keyword. This means it can fail without tripping ./lib's set -e. +## This is why all invocations below have the form [[ ... ]] || false. + +## Confirm that all three are hard linked. +ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging +[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false + +## Break all hard links. +rm -rf S +cp -r R S +rm -rf R +cp -r S R + +## Confirm that there are no hard links. +ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging +[[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ ! S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ ! R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false + +## Optimize *should* hard-link all three together. +darcs optimize --relink --repodir R --sibling S + +## Confirm that all three are hard linked. +ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging +[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false diff --git a/tests/failing-issue390_whatsnew.sh b/tests/failing-issue390_whatsnew.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue390_whatsnew.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash + +# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory + +set -ev + +if ! test -x "$(which strace)" +then echo skipping test since strace was not found + exit +fi + +rm -rf temp +mkdir temp +cd temp +darcs init +date > file1 +date > file2 +darcs add file* +darcs record -am "test" + +strace darcs whatsnew file1 &> out +# we should be accessing file1 +grep file1 out +# but shouldn't be accessing file2 +if grep file2 out +then + echo A whatsnew for file1 should not involve a 'stat' call to file2 + exit 1 +else + echo Yay. We pass. +fi + +rm -rf temp diff --git a/tests/failing-issue68_broken_pipe.sh b/tests/failing-issue68_broken_pipe.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue68_broken_pipe.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +# For issue68, 'don't report "resource vanished" when stdout pipe is broken.' + +set -ev + +rm -rf temp1 # Another script may have left a mess. + +darcs init --repodir temp1 + +cd temp1 + +date > f +darcs add f +darcs rec -am firstp +for (( i=0 ; i < 500; i=i+1 )); do + echo $i >> f; + darcs rec -am p$i +done + +darcs changes 2> err | head + +touch correcterr + +diff correcterr err + +cd .. diff --git a/tests/failing-issue944_partial_inventory.sh b/tests/failing-issue944_partial_inventory.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue944_partial_inventory.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash + +set -ev + +test $DARCS || DARCS=$PWD/../darcs +ACTUAL_DARCS=`which $DARCS` +DARCSPATH=`dirname $ACTUAL_DARCS` +PATH="$DARCSPATH:$PATH" +export PATH + +# create base repository +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +echo first > a +darcs add a +darcs record -am first +darcs tag --checkpoint 'Tag 1' + +echo second > b +darcs add b +darcs record -am second +darcs tag --checkpoint 'Tag 2' + +echo third > c +darcs add c +darcs record -am third +darcs tag --checkpoint 'Tag 3' + +# create a partial copy of the base repository and modify it +cd .. +rm -rf temp2 +darcs get --partial temp1 temp2 +cd temp2 + +# instead of the following three commands one could also use darcs optimize +echo mistake > a +darcs record -am mistake +darcs unrecord -ap mistake + +# now check the repository +darcs check +# => darcs: failed to read patch: ... + diff --git a/tests/failing-merging_newlines.sh b/tests/failing-merging_newlines.sh new file mode 100644 --- /dev/null +++ b/tests/failing-merging_newlines.sh @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +set -ev + +# Note that this is fixed, the lines marked # BUG HERE +# should be moved back into merging_newlines.sh + +# trick: requiring something to fail +not () { "$@" && exit 1 || :; } + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +cd temp1 +echo "apply allow-conflicts" > _darcs/prefs/defaults +# note: to make this pass, change echo to echo -n +# is that right? +echo "from temp1" > one.txt +darcs add one.txt +darcs record -A bar -am "add one.txt" +echo >> one.txt +darcs wh -u +cd .. + +darcs get temp1 temp2 +cd temp2 +# reality check +darcs show files | grep one.txt +echo "in tmp2" >> one.txt +darcs whatsnew -s | grep M +darcs record -A bar -am "add extra line" +darcs annotate -p . -u +darcs push -av > log +cat log +not grep -i conflicts log +# BUG HERE +# after a conflict, darcs resolve should report a conflict +darcs mark-conflicts > log 2>&1 +cat log +not grep -i 'no conflicts' log +cd .. + +rm -rf temp1 temp2 diff --git a/tests/failing-newlines.sh b/tests/failing-newlines.sh new file mode 100644 --- /dev/null +++ b/tests/failing-newlines.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +cd temp1 +echo -n "from temp1" > one.txt +darcs add one.txt +darcs record -A bar -am "add one.txt" +echo >> one.txt +cd .. + +darcs get temp1 temp2 +cd temp2 +echo "in tmp2" >> one.txt +darcs record -A bar -am "add extra line" +lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l` +echo $lines_added +test $lines_added -eq 1 +cd .. + +rm -rf temp1 temp2 diff --git a/tests/failing-nice-resolutions.sh b/tests/failing-nice-resolutions.sh new file mode 100644 --- /dev/null +++ b/tests/failing-nice-resolutions.sh @@ -0,0 +1,52 @@ +#!/bin/sh + +set -ev + +mkdir temp1 +cd temp1 +darcs init + +echo a > foo +darcs add foo +darcs record -am addfoo + +cd .. +darcs get temp1 temp2 + +cd temp2 +echo B > foo +darcs record -am B + +cd ../temp1 +echo b > foo +darcs record -am b +echo c > foo +darcs record -am c +cd ../temp2 +darcs pull -a + +cat foo + +grep b foo && exit 1 +grep a foo && exit 1 +grep B foo +grep c foo + +echo C > foo +darcs record -am C + +cd ../temp1 +echo d > foo +darcs record -am d + +cd ../temp2 +darcs pull -a + +cat foo + +grep b foo && exit 1 +grep a foo && exit 1 +grep B foo && exit 1 +grep c foo && exit 1 +grep C foo +grep d foo diff --git a/tests/failing-record-scaling.sh b/tests/failing-record-scaling.sh new file mode 100644 --- /dev/null +++ b/tests/failing-record-scaling.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issueN - darcs record shouldn't access old inventories! +## +## Copyright (C) 2008 David Roundy +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +which strace || exit 200 # This test requires strace(1). + +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repo. +touch R/a-unique-filename +strace -eopen -oR/trace \ + darcs record --repo R -lam 'A unique commit message.' +grep a-unique-filename R/trace +grep _darcs/hashed_inventory R/trace +not grep _darcs/inventories/ R/trace +rm -rf R # Clean up after ourselves. diff --git a/tests/haskell_policy.sh b/tests/haskell_policy.sh --- a/tests/haskell_policy.sh +++ b/tests/haskell_policy.sh @@ -1,59 +1,41 @@ #!/usr/bin/env bash +## This is a pseudo-test that runs tweaked hlint on the source code. +## +## Copyright (C) 2009 Petr Rockai +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. -RESULT=tmpfile -ROOT=.. -ERRORSTATUS=0 +. lib -# lookfor ( $1=what, $2=reason, $3=source module exception ) -lookfor () { - rm -f "$RESULT" - darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do - grep -Hnwe "$1" "$ROOT/$f" | grep -v "$3\.$1" | \ - grep -v ":[0-9]\+:import " | grep -Fv "ratify $1: " >> "$RESULT" - done - if [ -s "$RESULT" ]; then - echo "Found the following unratified uses of $1:" - # ugly sed expresion to fix relative paths; think pretty cat - sed -e 's/[^:]*\/\.\///' "$RESULT" - echo "$2" - echo "Comment 'ratify $1: ' on the same line to allow it" - echo - ERRORSTATUS=1 - fi - rm -f "$RESULT" +explain() { + echo >&2 + echo "## It seems that hlint has found errors. This usually means that you" >&2 + echo "## have used a forbidden function. See contrib/darcs-errors.hlint for" >&2 + echo "## explanation. Please also disregard any possible parse errors." >&2 } -# On 2009-02-12 Petr Rockai explained this on darcs-users: -# The problem with Prelude readFile is that it's based on hGetContents, which -# is lazy by definition. This also means that unless you force consumption of -# the produced list, it will keep an fd open for the file, possibly -# indefinitely. This is called a fd leak. Other than being annoying and if done -# often, leading to fd exhaustion and failure to open any new files (which is -# usually fatal), it also prevents the file to be unlinked (deleted) on win32. -# -# On the other hand, *strict* bytestring version of readFile will read the whole -# file into a contiguous buffer, *close the fd* and return. This is perfectly -# safe with regards to fd leaks. Btw., this is *not* the case with lazy -# bytestring variant of readFile, so that one is unsafe. -lookfor readFile \ - "Prelude.readFile doesn't ensure the file is closed before it is deleted!\nConsider import Data.ByteString.Char8 as B (readFile), B.readFile instead." \ - B # importing readFile from Data.ByteString as B, is allowed - -lookfor hGetContents \ - "hGetContents doesn't ensure the file is closed before it is deleted!" +trap explain ERR -# look for tabs in haskell source -rm -f "$RESULT" -darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do - grep -FHnwe " " "$ROOT/$f" >> "$RESULT" -done -if [ -s "$RESULT" ]; then - echo "Found the following lines with unwanted tabs:" - # ugly sed expresion to fix relative paths; think pretty cat - sed -e 's/[^:]*\/\.\///' "$RESULT" - echo - ERRORSTATUS=1 -fi -rm -f "$RESULT" +hlint >& /dev/null || exit 200 # skip if there's no hlint -exit "$ERRORSTATUS" +wd="`pwd`" +cd .. +hlint --hint=contrib/darcs-errors.hlint src diff --git a/tests/issue1139-diff-last.sh b/tests/issue1139-diff-last.sh --- a/tests/issue1139-diff-last.sh +++ b/tests/issue1139-diff-last.sh @@ -14,7 +14,7 @@ echo newtext > foo darcs record -am 'modify foo' -darcs diff --store --last=1 > out1 +darcs diff --store-in-mem --last=1 > out1 cat out1 grep text out1 grep foo out1 diff --git a/tests/issue1224_convert-darcs2-repository.sh b/tests/issue1224_convert-darcs2-repository.sh new file mode 100644 --- /dev/null +++ b/tests/issue1224_convert-darcs2-repository.sh @@ -0,0 +1,43 @@ +#!/usr/bin/env bash +## Test for issue1224 - Attempting to darcs convert a repository +## which is already in darcs-2 format leads to inconsistent result +## +## Copyright (C) 2009 Tomas Caithaml +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +# this test is not relevant for other than darcs 2 repositories +grep darcs-2 $HOME/.darcs/defaults || exit 200 + +. ../tests/lib + +rm -rf R +darcs init --repo R + +echo File contents > R/file.txt +darcs add R/file.txt --repodir R +darcs record --patch-name=add_file.txt --author=me --no-test -a --repodir R + +# This should fail with repository already in darcs-2 format. +echo "I understand the consequences of my action" > ack +not darcs convert temp/repo-2 temp/repo-2-converted < ack + +rm -rf R diff --git a/tests/issue1300_record_delete-file.sh b/tests/issue1300_record_delete-file.sh new file mode 100644 --- /dev/null +++ b/tests/issue1300_record_delete-file.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## Test for issue1300 - record --delete-file should only delete +## after a successful record +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. +cd R +touch f +darcs add f +# no test +touch log +echo 'no test' > f +darcs record -am f --logfile log --delete-logfile +test ! -e log +# passing test +touch log +darcs setpref test 'exit 0' +echo 'test pass' > f +darcs record -am f --test --logfile log --delete-logfile +test ! -e log +# failing test +touch log +darcs setpref test 'exit 1' +echo 'test fail' > f +not darcs record -am g --test --logfile log --delete-logfile +test -e log # should *not* be deleted +cd .. diff --git a/tests/issue1392_authorspelling.sh b/tests/issue1392_authorspelling.sh new file mode 100644 --- /dev/null +++ b/tests/issue1392_authorspelling.sh @@ -0,0 +1,43 @@ +#!/usr/bin/env bash +## Test for issue1392 - .authorspelling processing. +## +## Copyright (C) 2009 Tomas Caithaml +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. +cd R + +echo 'Bad\, Jr. , Foo' > .authorspellings +echo 'Example content.' > f +darcs record -lam 'Add f.' -A 'Foo' +darcs show authors | grep -q 'Bad, Jr\. ' + +echo 'Bad\, Jr. , ^Foo\, Jr\..*$' > .authorspellings +echo 'Ex. cont.' > f +darcs record -lam 'Change f.' -A 'Foo, Jr. ' +darcs show authors | tee output.txt | grep -q 'Bad, Jr\. ' + +cd .. + +#--rm -rf R diff --git a/tests/issue142_record-log.sh b/tests/issue142_record-log.sh new file mode 100644 --- /dev/null +++ b/tests/issue142_record-log.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash +## Test for issue142 - darcs record --logfile foo should not +## let you record a patch even when 'foo' is a missing file +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. +cd R +touch f g +touch log +darcs record -alm f --logfile log f +not darcs record -alm g --logfile missing g diff --git a/tests/issue1465_ortryrunning.sh b/tests/issue1465_ortryrunning.sh --- a/tests/issue1465_ortryrunning.sh +++ b/tests/issue1465_ortryrunning.sh @@ -32,11 +32,12 @@ # Set the editor to a program that just fails (VISUAL), make Darcs use # it (--edit), and then make sure when it brokenly launches a fallback # editor, that editor will exit because stdin isn't a tty (/dev/null). -not env -u TERM VISUAL=false R/log \ +not env -u TERM DARCS_EDITOR=false VISUAL=false R/log \ darcs record --repo R -lam 'Initial commit.' --edit # If Darcs did the right thing, the output won't make any mention of # the fallback editors. -not egrep -i 'not found|vi|emacs|nano|edit' R/log +# We skip ^\+ since the commandline is logged and matches "edit". +egrep -v '^\+' R/log | not egrep -i 'not found|vi|emacs|nano|edit' rm -rf R/ # Clean up after ourselves. diff --git a/tests/issue1472_read_too_much.sh b/tests/issue1472_read_too_much.sh new file mode 100644 --- /dev/null +++ b/tests/issue1472_read_too_much.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue1472 - running "darcs record ./foo" shouldn't even +## TRY to read ./bar. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repo. +mkdir R/d/ # Change the working tree. +echo 'Example content.' >R/f +echo 'Similar content.' >R/d/f +chmod 0 R/f # Make R/f unreadable, so that + # attempting to read it will result in + # an error. +darcs record --repo R -lam 'Only changes to R/d/.' d +rm -rf R/ # Clean up after ourselves. diff --git a/tests/issue1488_whatsnew-l.sh b/tests/issue1488_whatsnew-l.sh new file mode 100644 --- /dev/null +++ b/tests/issue1488_whatsnew-l.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash +## Test for issue1488 - whatsnew in non-added directory crashes on fromJust +## +## Copyright (C) 2009 Marnix Klooster +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R + +mkdir -p R/Foo/Bar # 2 directory levels needed +cd R +darcs init +cd Foo/Bar +# and now the real problem causer: +darcs whatsnew -l . # a "fromJust error" in Whatsnew.lhs diff --git a/tests/issue1584_optimize_upgrade.sh b/tests/issue1584_optimize_upgrade.sh new file mode 100644 --- /dev/null +++ b/tests/issue1584_optimize_upgrade.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +## Test for issue1584 - darcs optimize --upgrade +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R --old-fashioned # Create our test repos. +mkdir R/d/ R/e/ # Change the working tree. +echo 'Example content.' >R/d/f +darcs record --repo R -lam 'Add d/f and e.' +darcs mv --repo R d/f e/ # Unrecorded change +darcs whatsnew --repo R | grep 'move ./d/f' +darcs optimize --repo R --upgrade +darcs check --repo R +grep hashed R/_darcs/format +not grep darcs-2 R/_darcs/format +darcs whatsnew --repo R | grep 'move ./d/f' diff --git a/tests/issue1618-amend-preserve-logfile.sh b/tests/issue1618-amend-preserve-logfile.sh new file mode 100644 --- /dev/null +++ b/tests/issue1618-amend-preserve-logfile.sh @@ -0,0 +1,44 @@ +#!/usr/bin/env bash +## Test for issue1618 - amend should preserve the logfile +## in case of failure +## +## Copyright (C) 2009 Kamil Dworakowski +## +## 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. + +set -ev +. ../tests/lib +rm -rf R; mkdir R; cd R + +darcs init +darcs setpref test false +darcs record -am foo --no-test +export DARCS_EDITOR="echo 'new log' > " +echo y | not darcs amend -p foo --edit-long-comment 2> out + +# the msg has the format: "Logfile left in filenamehere." +LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//` + +echo $LOGFILE +test -e "$LOGFILE" +grep 'new log' $LOGFILE + +rm out; cd ..; rm -rf R/ diff --git a/tests/issue1620-record-lies-about-leaving-logfile.sh b/tests/issue1620-record-lies-about-leaving-logfile.sh new file mode 100644 --- /dev/null +++ b/tests/issue1620-record-lies-about-leaving-logfile.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash +## Test for issue1620 - record does not really leave logfile +## after a failure +## +## Copyright (C) 2009 Kamil Dworakowski +## +## 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. + +set -ev +. ../tests/lib +rm -rf R; mkdir R; cd R +export DARCS_EDITOR="echo 'a log' > " +darcs init +darcs setpref test false +echo yy | not darcs record -m foo -a --edit-long-comment 2> out + +# the msg has the format: "Logfile left in filenamehere." +LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//` +test -e "$LOGFILE" +grep 'a log' $LOGFILE + +rm out +cd .. +rm -rf R/ diff --git a/tests/issue1636-match-hunk.sh b/tests/issue1636-match-hunk.sh new file mode 100644 --- /dev/null +++ b/tests/issue1636-match-hunk.sh @@ -0,0 +1,56 @@ +#!/usr/bin/env bash +## Test for issue1636 - primitive match type: hunk +## +## Copyright (C) Kamil Dworakowski +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R +darcs init --repo R # Create our test repos. + +cd R +echo 'first line' > f +darcs record -lam 'one' +echo 'second line' >> f +darcs record -am 'two' + +darcs changes --match 'hunk first' > log +grep one log +not grep two log + +darcs changes --match 'hunk line' > log +grep one log +grep two log + +darcs changes --match 'hunk one' > log +not grep one log + +# test searching for lines in the remove part of the hunk +echo 'first line' > f + +darcs record -am 'three' +darcs changes --match 'hunk second' > log + +grep three log +grep two log +not grep first log + diff --git a/tests/issue27.sh b/tests/issue27.sh new file mode 100644 --- /dev/null +++ b/tests/issue27.sh @@ -0,0 +1,43 @@ +#!/bin/sh + +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +echo first > a +darcs add a +darcs record --pipe --all --patch-name=first < b +darcs add b +darcs record --pipe --all --patch-name=first <> a +darcs record --pipe --all --patch-name=second <> b +darcs record --pipe --all --patch-name=second < +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +echo 'apply prehook touch g' >R/_darcs/prefs/defaults +echo 'apply posthook touch h' >>R/_darcs/prefs/defaults +darcs get R S +cd S +touch f +darcs add f +darcs record -lam 'Add f' +test ! -e ../R/g +test ! -e ../R/h +darcs push -a +test -e ../R/g +test -e ../R/h diff --git a/tests/lib b/tests/lib --- a/tests/lib +++ b/tests/lib @@ -1,5 +1,5 @@ # This is a -*- sh -*- library. -set -ev +set -vex ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; } @@ -8,11 +8,30 @@ abort_windows () { if echo $OS | grep -i windows; then echo This test does not work on Windows - exit 0 + exit 200 fi } pwd() { ghc --make "$TESTS_WD/hspwd.hs" "$TESTS_WD/hspwd" +} + +# switch locale to latin9 if supported if there's a locale command, skip test +# otherwise +switch_to_latin9_locale () { + if ! which locale ; then + echo "no locale command" + exit 200 # skip test + fi + + latin9_locale=`locale -a | grep @euro | head -n 1` + if [ -z "$latin9_locale" ]; then + echo "no latin9 locale found" + exit 200 # skip, we can't switch away from UTF-8 + fi + + echo "Using locale $latin9_locale" + export LC_ALL=$latin9_locale + echo "character encoding is now `locale charmap`" } diff --git a/tests/nfs-failure.sh b/tests/nfs-failure.sh new file mode 100644 --- /dev/null +++ b/tests/nfs-failure.sh @@ -0,0 +1,35 @@ +#!/bin/sh + +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo first > a +darcs add a +darcs record --pipe --all --patch-name=first < b +darcs add b +darcs record --pipe --all --patch-name=first < out -cat out +not darcs whatsnew 2>&1 | tee out grep 'pending has conflicts' out echo pending should now be fixed but there are no changes @@ -31,8 +30,7 @@ write_buggy_pending -darcs revert -a &> out -cat out +darcs revert -a 2>&1 | tee out grep 'pending has conflicts' out echo pending should now be emptied @@ -40,22 +38,19 @@ write_buggy_pending -darcs record -a -m foo &> out -cat out +darcs record -a -m foo 2>&1 | tee out grep 'pending has conflicts' out darcs record -a -m foo darcs changes -v -darcs repair &> out -cat out +darcs repair 2>&1 | tee out grep 'The repository is already consistent' out write_buggy_pending -darcs repair &> out -cat out +darcs repair 2>&1 | tee out grep 'The repository is already consistent' out cd .. diff --git a/tests/pull_conflicts.sh b/tests/pull_conflicts.sh new file mode 100644 --- /dev/null +++ b/tests/pull_conflicts.sh @@ -0,0 +1,57 @@ +#!/usr/bin/env bash +## Test that pull --skip-conflicts filters the conflicts +## appropriately. +## +## Copyright (C) 2009 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. + +mkdir R +cd R +darcs init +echo 'foo' > foo +echo 'bar' > bar +darcs rec -lam 'Add foo and bar' +cd .. + +darcs get R S + +cd R +echo 'foo2' > foo +darcs rec -lam 'Change foo (2)' +echo 'bar2' > bar +darcs rec -lam 'Change bar (2)' +cd .. + +cd S +echo 'foo3' > foo +darcs rec -lam 'Change foo (3)' +darcs pull --skip-conflicts -a ../R +test `darcs changes --count` -eq 3 +cd .. + +cd S +darcs pull -a ../R +test `darcs changes --count` -eq 4 +cd .. diff --git a/tests/push-formerly-pl.sh b/tests/push-formerly-pl.sh --- a/tests/push-formerly-pl.sh +++ b/tests/push-formerly-pl.sh @@ -4,6 +4,14 @@ . lib +slash() { +if echo $OS | grep -q -i windows; then + echo -n \\ +else + echo -n / +fi +} + DIR="`pwd`" rm -rf temp1 temp2 @@ -40,7 +48,7 @@ # Before trying to pull from self, defaultrepo does not exist test ! -e _darcs/prefs/defaultrepo # return special message when you try to push to yourself -not darcs push -a "$DIR/temp1" 2> log +not darcs push -a "$DIR`slash`temp1" 2> log grep -i "cannot push from repository to itself" log # and don't update the default repo to be the current dir test ! -e _darcs/prefs/defaultrepo diff --git a/tests/push_conflicts.sh b/tests/push_conflicts.sh new file mode 100644 --- /dev/null +++ b/tests/push_conflicts.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash +## Test that apply --skip-conflicts filters the conflicts +## appropriately. +## +## Copyright (C) 2009 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. + +mkdir R +cd R +darcs init +echo 'foo' > foo +echo 'bar' > bar +darcs rec -lam 'Add foo and bar' +cd .. + +darcs get R S + +cd R +echo 'foo2' > foo +darcs rec -lam 'Change foo (2)' +echo 'bar2' > bar +darcs rec -lam 'Change bar (2)' +cd .. + +cd S +echo 'foo3' > foo +darcs rec -lam 'Change foo (3)' +cd .. + +cd R +darcs send -a ../S -o ../S/applyme.dpatch +cd .. + +cd S +darcs apply --skip-conflicts applyme.dpatch +test `darcs changes --count` -eq 3 +cd .. diff --git a/tests/remove.sh b/tests/remove.sh new file mode 100644 --- /dev/null +++ b/tests/remove.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## +## Copyright (C) 2009 Roman Plasil +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d e # Change the working tree. +mkdir d/f d/f/g +echo 'Example content.' > d/f/1.txt +echo 'Example content.' > d/f/g/2.txt +echo 'Example content.' > e/3.txt + +darcs add -r . +darcs wh -s > before.lst +grep -i d before.lst +grep -i e before.lst +grep -i d/f before.lst + +darcs remove -r d +darcs wh -s > after.lst +not grep -i d after.lst +not grep -i d/f after.lst +not grep -i d/f/g after.lst +not grep -i d/f/g/2.txt after.lst +not grep -i d/f/1.txt after.lst + +cd .. diff --git a/tests/repair-corrupt.sh b/tests/repair-corrupt.sh --- a/tests/repair-corrupt.sh +++ b/tests/repair-corrupt.sh @@ -15,6 +15,7 @@ hashed=false test -e _darcs/hashed_inventory && hashed=true +cp -R _darcs _clean_darcs # produce a corrupt patch echo 'rmfile foo' > _darcs/patches/pending @@ -22,6 +23,11 @@ darcs rec -a -m 'remove foo' not darcs check # unapplicable patch! +cp -R _darcs/ _backup_darcs +darcs repair # repairs the patch +darcs check +rm -rf _darcs +mv _backup_darcs _darcs # get the bad patch back # stash away contents of _darcs cp -R _darcs/ _backup_darcs @@ -30,15 +36,18 @@ darcs rec -a -m 'here' # corrupt pristine content -$hashed && inv=`grep ^pristine _darcs/hashed_inventory` -cp _backup_darcs/patches/* _darcs/patches/ -cp _backup_darcs/*inventory* _darcs/ -$hashed && { - cp _darcs/hashed_inventory hashed.tmp - sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory - rm hashed.tmp +corrupt_pristine() { + $hashed && inv=`grep ^pristine _darcs/hashed_inventory` + cp _backup_darcs/patches/* _darcs/patches/ + cp _backup_darcs/*inventory* _darcs/ + if $hashed; then + cp _darcs/hashed_inventory hashed.tmp + sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory + rm hashed.tmp + fi } +corrupt_pristine not darcs check # just a little paranoia darcs repair # repair succeeds @@ -49,5 +58,11 @@ echo foo > foobar1 diff foobar foobar1 +rm -rf _backup_darcs +mv _clean_darcs _backup_darcs +corrupt_pristine # without the unapplicable patch +not darcs check +darcs repair +darcs check + cd .. -rm -rf bad diff --git a/tests/repos/old-with-checkpoint.tgz b/tests/repos/old-with-checkpoint.tgz new file mode 100644 Binary files /dev/null and b/tests/repos/old-with-checkpoint.tgz differ diff --git a/tests/show_contents.sh b/tests/show_contents.sh --- a/tests/show_contents.sh +++ b/tests/show_contents.sh @@ -1,5 +1,5 @@ #!/usr/bin/env bash -set -ev +. lib rm -rf temp1 mkdir temp1 @@ -21,6 +21,8 @@ darcs show contents foo -p third | grep third darcs show contents foo --match="author author1" first | grep first darcs show contents foo --tag t1 | grep second +not darcs show contents foo --match "hash bla" 2>&1 | tee out +grep "Couldn't match pattern" out cd .. rm -rf temp1 diff --git a/tests/tentative_revert.sh b/tests/tentative_revert.sh new file mode 100644 --- /dev/null +++ b/tests/tentative_revert.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +## Test for clearing tentative state after a failed transaction +## +## Copyright (C) 2009 Kamil Dworakowski +## +## 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. + +set -ev +. ../tests/lib +rm -rf R +darcs init --repo R +touch R/foo +darcs record --repo R -lam 'foo' +touch R/bar +darcs record --repo R -lam 'bar' +echo "this change should stay uncommitted" >> R/foo +darcs setpref --repo R test false +echo 'y' | not darcs amend --repo R -am 'change everything' R/foo +darcs setpref --repo R test true + +# if tentative state was not cleared, the previous changes +# from failed transaction would piggy back on the next +echo "xx" >> R/bar +echo 'y' | darcs amend --repo R -am 'bar2' R/bar + +# should have uncommitted changes +darcs wh --repo R > changes +grep "this change should stay uncommitted" changes diff --git a/tests/trailing-newlines.sh b/tests/trailing-newlines.sh new file mode 100644 --- /dev/null +++ b/tests/trailing-newlines.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +. lib + +rm -rf temp && mkdir temp +cd temp +darcs init +echo -n > no_newline +echo -n > newline + +darcs rec -lam "empty" + +echo -n foo > no_newline +echo foo > newline + +wc -l no_newline | grep 0 +wc -l newline | grep 1 + +darcs wh > diff1 +darcs rec -am "add bits" +darcs revert -a | grep "no changes" + +echo -n > no_newline +echo -n > newline + +darcs wh > diff2 +darcs rec -lam "bar" + +darcs revert -a | grep "no changes" +darcs check + +cat > diff1.expected < diff2.expected <