diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,55 @@ +Darcs 2.14.0, 4 April 2018 + + * fix encoding business, make DARCS_DONT_ESCAPE_8BIT=1 default (Ben, Ganesh Sittampalam) + * show explicit dependencies in `darcs log -s` (Gian Piero Carrubba) + * improve bash/zsh completion (Ben, Gian Piero) + * no longer print an error message when ctrlc'ing pager (Guillaume Hoffmann) + * `darcs help markdown` mentions all files in `_darcs/prefs/` (Guillaume) + * add patch index status to `show repo` command (Ben) + * per-file conflict marking (Ben Franksen) + * make it possible to use DARCS_SCP=rsync (Ben) + * add --not-in-remote option to unrecord command (Ben) + * plug memory leak and improve efficiency in annotate (Ben) + * save unneeded FL/RL reverses in SelectChanges module (Ben) + * optimize token replace code and --look-for-replaces (Ben) + * no longer show conflicting files on `whatsnew -s`, will reintrodue this + feature when it is done efficiently (Guillaume) + * separate display and storage of patches (Ben) + * support GHC 8.2 and GHC 8.4 (Ganesh) + * many refactorings in Darcs.Repository modules and API (Ben, Guillaume) + * no longer track build dependencies in Setup.hs, nor use + alpha, beta, rc names (Guillaume) + * refactor `pull --reorder-patches` (Ben) + * refactor SelectChanges (Ben) + * remove Patchy typeclass and redundant constaints where possible (Guillaume) + * fix build with cabal new-build (Francesco Ariis) + * unit and quickcheck tests for inventories (Ben) + * throw out all access to bytestring internals from Darcs.Util.ByteString (Ben) + * refactor, simplify, and document hunk application (Ben) + * drop support of old cache location and SHA1-hashed repos (Guillaume) + * rely on GHC's own stack traces for bug reporting (Guillaume) + * fixed the following bugs: + * fix mail encoding with '.' or '=' as last character (Timo von Holtz) + * 2526: whatsnew -l --boring should list boring files (Ben) + * 2208: replace detects existing force hunks in working (Ben) + * 2512: author name is written to repository after multiple-choice + prompt (Stephan-A. Posselt) + * 2359: convert --export mishandles Unicode filenames (Ben) + * 2545: prevent argument smuggling in SSH repository URLs (Gian Piero) + * 2581: fix rebase pull --reorder (Ben) + * 2575: fix unrevert with rebase (Ben) + * 2579: allow darcs send to work even if no MTA is installed + * 2555: include explicit dependencies in the output of `log -v` (Gian Piero) + * 2569: decoding multibyte characters (Ben) + * 2563: create remote repo in correct format in ssh tests (Ben) + * 2565: create _darcs dir after searching for an existing one (Ben) + * 2567: darcs whatsnew --unified (Ben) + * 2566: avoid renaming across file systems (Ben) + * 2564: delete wrong and irrelevant propConcatPS (Guillaume) + * 2559: remove trailing empty lines in patch header edition (Guillaume) + * 2536: mask out internal matchers in `show files` routing logic (Gian Piero) + + Darcs 2.12.5, 11 January 2017 * Bump some dependency upper bounds (Ganesh Sittampalam) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,241 @@ +-- copyright (c) 2008 Duncan Coutts +-- portions copyright (c) 2008 David Roundy +-- portions copyright (c) 2007-2009 Judah Jacobson + +import Distribution.Simple + ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.ModuleName( toFilePath ) +import Distribution.PackageDescription + ( PackageDescription(executables, testSuites), Executable(exeName) + , emptyBuildInfo + , TestSuite(testBuildInfo) + , updatePackageDescription + , cppOptions, ccOptions + , library, libBuildInfo, otherModules ) +import Distribution.Package + ( packageVersion ) +import Distribution.Version( Version ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), absoluteInstallDirs ) +import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) +import Distribution.Simple.Setup + (buildVerbosity, copyDest, copyVerbosity, fromFlag, + haddockVerbosity, installVerbosity, sDistVerbosity, replVerbosity ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.System + ( OS(Windows), buildOS ) +import Distribution.Simple.Utils + (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout, + rewriteFile ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text + ( display ) +import Control.Monad ( unless, void ) + +import System.Directory + ( doesDirectoryExist, doesFileExist ) +import System.IO + ( openFile, IOMode(..) ) +import System.Process (runProcess) +import Data.List( isInfixOf, lines ) +import System.FilePath ( () ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( peek ) +import Foreign.Ptr ( castPtr ) +import Data.Monoid ( mappend ) +import Data.Word ( Word8, Word32 ) + +import qualified Control.Exception as Exception + +catchAny :: IO a -> (Exception.SomeException -> IO a) -> IO a +catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException)) + +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks { + + buildHook = \ pkg lbi hooks flags -> + let verb = fromFlag $ buildVerbosity flags + in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags), + + haddockHook = \ pkg lbi hooks flags -> + let verb = fromFlag $ haddockVerbosity flags + in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) , + replHook = \pkg lbi hooks flags args -> + let verb = fromFlag $ replVerbosity flags + in commonBuildHook replHook pkg lbi hooks verb >>= (\f -> f flags args) , + postBuild = \ _ _ _ lbi -> buildManpage lbi, + postCopy = \ _ flags pkg lbi -> + installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags), + postInst = \ _ flags pkg lbi -> + installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest, + + sDistHook = \ pkg lbi hooks flags -> do + let pkgVer = packageVersion pkg + verb = fromFlag $ sDistVerbosity flags + x <- versionPatches verb pkgVer + y <- context verb + 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 + , + postConf = \_ _ _ _ -> return () --- Usually this checked for external C + --- dependencies, but we already have performed such + --- check in the confHook +} + +-- | For @./Setup build@ and @./Setup haddock@, do some unusual +-- things, then invoke the base behaviour ("simple hook"). +commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a) + -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a +commonBuildHook runHook pkg lbi hooks verbosity = do + (version, state) <- determineVersion verbosity pkg + + -- Create our own context file. + generateVersionModule verbosity 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. + littleEndian <- testEndianness + let args = ("-DPACKAGE_VERSION=" ++ show' version) : + [arg | (arg, True) <- -- include fst iff snd. + [-- We have MAPI iff building on/for Windows. + ("-DHAVE_MAPI", buildOS == Windows), + ("-DLITTLEENDIAN", littleEndian), + ("-DBIGENDIAN", not littleEndian)]] + bi = emptyBuildInfo { cppOptions = args, ccOptions = args } + hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg]) + pkg' = updatePackageDescription hbi pkg + + -- updatePackageDescription doesn't handle test suites so we + -- need to do this manually + updateTestSuiteBI bi' testSuite + = testSuite { testBuildInfo = bi' `mappend` testBuildInfo testSuite } + pkg'' = pkg' { testSuites = map (updateTestSuiteBI bi) (testSuites pkg') } + + lbi' = lbi { localPkgDescr = pkg'' } + return $ runHook simpleUserHooks pkg'' lbi' hooks + + where + show' :: String -> String -- Petr was worried that we might + show' = show -- allow non-String arguments. + testEndianness :: IO Bool + testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p + return $ o == (1 :: Word8) + +-- --------------------------------------------------------------------- +-- man page +-- --------------------------------------------------------------------- + +buildManpage :: LocalBuildInfo -> IO () +buildManpage lbi = do + let darcs = buildDir lbi "darcs/darcs" + manpage = buildDir lbi "darcs/darcs.1" + manpageHandle <- openFile manpage WriteMode + void $ runProcess darcs ["help","manpage"] + Nothing Nothing Nothing (Just manpageHandle) Nothing + +installManpage :: PackageDescription -> LocalBuildInfo + -> Verbosity -> CopyDest -> IO () +installManpage pkg lbi verbosity copy = + copyFiles verbosity + (mandir (absoluteInstallDirs pkg lbi copy) "man1") + [(buildDir lbi "darcs", "darcs.1")] + +-- --------------------------------------------------------------------- +-- version module +-- --------------------------------------------------------------------- + +determineVersion :: Verbosity -> PackageDescription -> IO (String, String) +determineVersion verbosity pkg = do + let darcsVersion = packageVersion pkg + numPatches <- versionPatches verbosity darcsVersion + return (display darcsVersion, versionStateString numPatches) + + where + versionStateString :: Maybe Int -> String + versionStateString Nothing = "unknown" + versionStateString (Just 0) = "release" + versionStateString (Just 1) = "+ 1 patch" + versionStateString (Just n) = "+ " ++ show n ++ " patches" + +versionPatches :: Verbosity -> Version -> IO (Maybe Int) +versionPatches verbosity darcsVersion = do + numPatchesDarcs <- do + out <- rawSystemStdout verbosity "darcs" + ["log", "-a", "--from-tag", display darcsVersion, "--count"] + case reads out of + ((n,_):_) -> return $ Just ((n :: Int) - 1) + _ -> return Nothing + `catchAny` \_ -> return Nothing + + numPatchesDist <- parseFile versionFile + return $ case (numPatchesDarcs, numPatchesDist) of + (Just x, _) -> Just x + (Nothing, Just x) -> Just x + (Nothing, Nothing) -> Nothing + + where + versionFile = "release/distributed-version" + +generateVersionModule :: Verbosity -> LocalBuildInfo + -> String -> String -> IO () +generateVersionModule verbosity lbi version state = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + ctx <- context verbosity + hash <- weakhash verbosity + rewriteFile (dir "Version.hs") $ unlines + ["module Version where" + ,"version, weakhash, context :: String" + ,"version = \"" ++ version ++ " (" ++ state ++ ")\"" + ,"weakhash = " ++ case hash of + Just x -> show x + Nothing -> show "not available" + ,"context = " ++ case ctx of + Just x -> show x + Nothing -> show "context not available" + ] + +weakhash :: Verbosity -> IO (Maybe String) +weakhash verbosity = do + inrepo <- doesDirectoryExist "_darcs" + unless inrepo $ fail "Not a repository." + out <- rawSystemStdout verbosity "darcs" ["show", "repo"] + let line = filter ("Weak Hash:" `isInfixOf`) $ lines out + return $ case (length line) of + 0 -> Nothing + _ -> Just $ last $ words $ head line + `catchAny` \_ -> return Nothing + +context :: Verbosity -> IO (Maybe String) +context verbosity = do + contextDarcs <- do + inrepo <- doesDirectoryExist "_darcs" + unless inrepo $ fail "Not a repository." + out <- rawSystemStdout verbosity "darcs" ["log", "-a", "--context"] + return $ Just out + `catchAny` \_ -> return Nothing + + contextDist <- parseFile contextFile + return $ case (contextDarcs, contextDist) of + (Just x, _) -> Just x + (Nothing, Just x) -> Just x + (Nothing, Nothing) -> Nothing + where contextFile = "release/distributed-context" + +parseFile :: (Read a) => String -> IO (Maybe a) +parseFile f = do + exist <- doesFileExist f + if exist then do + content <- readFile f -- ^ ratify readFile: we don't care here. + case reads content of + ((s,_):_) -> return s + _ -> return Nothing + else return Nothing diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,382 +0,0 @@ -\begin{code} -{-# LANGUAGE TemplateHaskell #-} --- copyright (c) 2008 Duncan Coutts --- portions copyright (c) 2008 David Roundy --- portions copyright (c) 2007-2009 Judah Jacobson - -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple - ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Configure - ( checkForeignDeps ) -import Distribution.ModuleName( toFilePath ) -import Distribution.PackageDescription - ( PackageDescription(executables, testSuites), Executable(buildInfo, exeName) - , BuildInfo(customFieldsBI), emptyBuildInfo - , TestSuite(testBuildInfo) - , FlagName(FlagName) - , updatePackageDescription - , cppOptions, ccOptions, ldOptions - , library, libBuildInfo, otherModules - , extraLibs, extraLibDirs, includeDirs ) -import Distribution.Package - ( packageVersion, packageName, PackageName(..), Package ) -import Distribution.Version - ( Version(Version, versionBranch) ) -import Data.Version( showVersion ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), absoluteInstallDirs, externalPackageDeps ) -import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) -import Distribution.Simple.PackageIndex ( topologicalOrder ) -import Distribution.Simple.Program ( gccProgram, rawSystemProgramStdoutConf ) -import Distribution.Simple.Setup - (buildVerbosity, copyDest, copyVerbosity, fromFlag, - haddockVerbosity, installVerbosity, sDistVerbosity, - configVerbosity, ConfigFlags, configConfigurationsFlags) -import qualified Distribution.Simple.Setup as DSS -- to get replVerbosity in Cabal > 1.18 -import Distribution.Simple.BuildPaths - ( autogenModulesDir, exeExtension ) -import Distribution.System - ( OS(Windows), buildOS ) -import Distribution.Simple.Utils - (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout, - rewriteFile, withTempFile, cabalVersion) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Text - ( display ) -import Control.Monad ( zipWithM_, when, unless, filterM ) -import Control.Exception ( bracket, handle, IOException ) - -import Language.Haskell.TH ( mkName, newName, recUpdE, varE, appE, lamE, varP ) - -import System.Directory - (copyFile, createDirectory, createDirectoryIfMissing, - doesDirectoryExist, doesFileExist, - getCurrentDirectory, getDirectoryContents, - removeDirectoryRecursive, removeFile, setCurrentDirectory, - getTemporaryDirectory - ) -import System.Exit ( ExitCode(ExitSuccess) ) -import System.IO - ( openFile, IOMode (..), stdout - , hPutStr, hFlush, hClose - ) -import System.Process (runProcess) -import System.IO.Error ( isDoesNotExistError ) -import Data.List( isPrefixOf, isSuffixOf, sort ) -import System.Process( rawSystem ) -import System.FilePath ( (), (<.>), splitDirectories, isAbsolute ) -import Foreign.Marshal.Utils ( with ) -import Foreign.Storable ( peek ) -import Foreign.Ptr ( castPtr ) -import Data.Monoid ( mappend ) -import Data.Word ( Word8, Word32 ) - -import qualified Control.Exception as Exception - -catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException)) - -{- Template Haskell hackery for replHook while we want to support Cabal < 1.18 -} -replVerbosity = - $(if cabalVersion >= Version [1,18,0] [] - then varE (mkName "DSS.replVerbosity") - else [| error "This shouldn't be called" |] - ) - -replHookBody replHookSel = - \pkg lbi hooks flags args -> - let verb = fromFlag $ replVerbosity flags - in commonBuildHook replHookSel pkg lbi hooks verb >>= (\f -> f flags args) - -addReplHook = - $(if cabalVersion >= Version [1,18,0] [] - then - do hooks <- newName "hooks" - let replHook = mkName "replHook" - app <- appE (varE (mkName "replHookBody")) (varE replHook) - lamE [varP hooks] (recUpdE (varE hooks) [return (replHook, app)]) - else [| \hooks -> hooks |] - ) -{- End of Template Haskell hackery -} - -main :: IO () -main = defaultMainWithHooks $ addReplHook $ simpleUserHooks { - - buildHook = \ pkg lbi hooks flags -> - let verb = fromFlag $ buildVerbosity flags - in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags), - - haddockHook = \ pkg lbi hooks flags -> - let verb = fromFlag $ haddockVerbosity flags - in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) , -{- - -- this is the actual replHook code we want - replHook = \pkg lbi hooks flags args -> - let verb = fromFlag $ replVerbosity flags - in commonBuildHook replHook pkg lbi hooks verb >>= (\f -> f flags args) , --} - postBuild = \ _ _ _ lbi -> buildManpage lbi, - postCopy = \ _ flags pkg lbi -> - installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags), - postInst = \ _ flags pkg lbi -> - installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest, - - sDistHook = \ pkg lbi hooks flags -> do - let pkgVer = packageVersion pkg - verb = fromFlag $ sDistVerbosity flags - x <- versionPatches verb pkgVer - y <- context verb pkgVer - rewriteFile "release/distributed-version" $ show x - rewriteFile "release/distributed-context" $ show y - 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 - , - confHook = - if buildOS == Windows - then confHook simpleUserHooks - else - \genericDescript flags -> do - lbi <- confHook simpleUserHooks genericDescript flags - let pkgDescr = localPkgDescr lbi - let verb = fromFlag (configVerbosity flags) - checkForeignDeps pkgDescr lbi verb - let lib = maybe (error "darcs library was not configured - did it end up unbuildable?") id - (library pkgDescr) - let bi = libBuildInfo lib - bi' <- maybeSetLibiconv flags bi lbi - return lbi {localPkgDescr = pkgDescr { - library = Just lib { - libBuildInfo = bi'}}} - , - postConf = \_ _ _ _ -> return () --- Usually this checked for external C - --- dependencies, but we already have performed such - --- check in the confHook -} - --- | For @./Setup build@ and @./Setup haddock@, do some unusual --- things, then invoke the base behaviour ("simple hook"). -commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a) - -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a -commonBuildHook runHook pkg lbi hooks verbosity = do - (version, state) <- determineVersion verbosity pkg - - -- Create our own context file. - 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. - littleEndian <- testEndianness - let args = ("-DPACKAGE_VERSION=" ++ show' version) : - [arg | (arg, True) <- -- include fst iff snd. - [-- We have MAPI iff building on/for Windows. - ("-DHAVE_MAPI", buildOS == Windows), - ("-DLITTLEENDIAN", littleEndian), - ("-DBIGENDIAN", not littleEndian)]] - bi = emptyBuildInfo { cppOptions = args, ccOptions = args } - hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg]) - pkg' = updatePackageDescription hbi pkg - - -- updatePackageDescription doesn't handle test suites so we - -- need to do this manually - updateTestSuiteBI bi testSuite - = testSuite { testBuildInfo = bi `mappend` testBuildInfo testSuite } - pkg'' = pkg' { testSuites = map (updateTestSuiteBI bi) (testSuites pkg') } - - lbi' = lbi { localPkgDescr = pkg'' } - return $ runHook simpleUserHooks pkg'' lbi' hooks - - where - customFields = map fst . customFieldsBI . buildInfo $ darcsExe - darcsExe = head [e | e <- executables pkg, exeName e == "darcs"] - show' :: String -> String -- Petr was worried that we might - show' = show -- allow non-String arguments. - testEndianness :: IO Bool - testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p - return $ o == (1 :: Word8) - --- --------------------------------------------------------------------- --- man page --- --------------------------------------------------------------------- - -buildManpage :: LocalBuildInfo -> IO () -buildManpage lbi = do - let darcs = buildDir lbi "darcs/darcs" - manpage = buildDir lbi "darcs/darcs.1" - manpageHandle <- openFile manpage WriteMode - runProcess darcs ["help","manpage"] - Nothing Nothing Nothing (Just manpageHandle) Nothing - return () - -installManpage :: PackageDescription -> LocalBuildInfo - -> Verbosity -> CopyDest -> IO () -installManpage pkg lbi verbosity copy = - copyFiles verbosity - (mandir (absoluteInstallDirs pkg lbi copy) "man1") - [(buildDir lbi "darcs", "darcs.1")] - --- --------------------------------------------------------------------- --- version module --- --------------------------------------------------------------------- - -determineVersion :: Verbosity -> PackageDescription -> IO (String, String) -determineVersion verbosity pkg = do - let darcsVersion = packageVersion pkg - numPatches <- versionPatches verbosity darcsVersion - return (display darcsVersion, versionStateString numPatches darcsVersion) - - where - versionStateString :: Maybe Int -> Version -> String - versionStateString Nothing _ = "unknown" - versionStateString (Just 0) v = case versionBranch v of - x | 97 `elem` x -> "alpha " ++ show (after 97 x) - | 98 `elem` x -> "beta " ++ show (after 98 x) - | 99 `elem` x -> - "release candidate " ++ show (after 99 x) - _ -> "release" - versionStateString (Just 1) _ = "+ 1 patch" - versionStateString (Just n) _ = "+ " ++ show n ++ " patches" - after w (x:r) | w == x = head r - | otherwise = after w r - after _ [] = undefined - -versionPatches :: Verbosity -> Version -> IO (Maybe Int) -versionPatches verbosity darcsVersion = do - numPatchesDarcs <- do - out <- rawSystemStdout verbosity "darcs" - ["log", "-a", "--from-tag", display darcsVersion, "--count"] - case reads (out) of - ((n,_):_) -> return $ Just ((n :: Int) - 1) - _ -> return Nothing - `catchAny` \_ -> return Nothing - - numPatchesDist <- parseFile versionFile - return $ case (numPatchesDarcs, numPatchesDist) of - (Just x, _) -> Just x - (Nothing, Just x) -> Just x - (Nothing, Nothing) -> Nothing - - where - versionFile = "release/distributed-version" - -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 (dir "Version.hs") $ unlines - ["module Version where" - ,"builddeps, version, context :: String" - ,"version = \"" ++ version ++ " (" ++ state ++ ")\"" - ,"builddeps = " ++ show ( formatdeps (externalPackageDeps lbi)) - ,"context = " ++ case ctx of - Just x -> show x - Nothing -> show "context not available" - ] - where formatdeps = unlines . map (formatone . snd) - formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -context :: Verbosity -> Version -> IO (Maybe String) -context verbosity version = do - contextDarcs <- do - inrepo <- doesDirectoryExist "_darcs" - unless inrepo $ fail "Not a repository." - out <- rawSystemStdout verbosity "darcs" ["log", "-a", "--context"] - return $ Just out - `catchAny` \_ -> return Nothing - - contextDist <- parseFile contextFile - return $ case (contextDarcs, contextDist) of - (Just x, _) -> Just x - (Nothing, Just x) -> Just x - (Nothing, Nothing) -> Nothing - where contextFile = "release/distributed-context" - -parseFile :: (Read a) => String -> IO (Maybe a) -parseFile f = do - exist <- doesFileExist f - if exist then do - content <- readFile f -- ^ ratify readFile: we don't care here. - case reads content of - ((s,_):_) -> return s - _ -> return Nothing - else return Nothing - --- Test whether compiling a c program that links against libiconv needs -liconv. -maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo -maybeSetLibiconv flags bi lbi = do - let biWithIconv = addIconv bi - let verb = fromFlag (configVerbosity flags) - if hasFlagSet flags (FlagName "libiconv") - then do - putStrLn "Using -liconv." - return biWithIconv - else do - putStr "checking whether to use -liconv... " - hFlush stdout - worksWithout <- tryCompile iconv_prog bi lbi verb - if worksWithout - then do - putStrLn "not needed." - return bi - else do - worksWith <- tryCompile iconv_prog biWithIconv lbi verb - if worksWith - then do - putStrLn "using -liconv." - return biWithIconv - else error "Unable to link against the iconv library." - -hasFlagSet :: ConfigFlags -> FlagName -> Bool -hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags) - -tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool -tryCompile program bi lbi verb = handle processExit $ handle processException $ do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \fname cH -> - withTempFile tempDir "" $ \execName oH -> do - hPutStr cH program - hClose cH - hClose oH - -- TODO take verbosity from the args. - rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) - (fname : "-o" : execName : args) - return True - where - processException :: IOException -> IO Bool - processException e = return False - processExit = return . (==ExitSuccess) - -- Mimicing Distribution.Simple.Configure - deps = topologicalOrder (installedPkgs lbi) - args = concat - [ ccOptions bi - , cppOptions bi - , ldOptions bi - -- --extra-include-dirs and --extra-lib-dirs are included - -- in the below fields. - -- Also sometimes a dependency like rts points to a nonstandard - -- include/lib directory where iconv can be found. - , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps) - , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps) - , map ("-l" ++) (extraLibs bi) - ] - -addIconv :: BuildInfo -> BuildInfo -addIconv bi = bi {extraLibs = "iconv" : extraLibs bi} - -iconv_prog :: String -iconv_prog = unlines - [ "#include " - , "int main(void) {" - , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");" - , " return 0;" - , "}" - ] - -\end{code} diff --git a/contrib/_darcs.zsh b/contrib/_darcs.zsh --- a/contrib/_darcs.zsh +++ b/contrib/_darcs.zsh @@ -1,35 +1,38 @@ #compdef darcs -## Darcs completion snippet for zsh. +## Darcs completion for zsh. ## +## Originally derived from a version by ## Copyright (C) 2009 Nicolas Pouillard -## -## This program is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as published by -## the Free Software Foundation; either version 2 of the License, or -## (at your option) any later version. -## -## This program is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. +local -a darcs_options darcs_non_options darcs_arguments + if (($CURRENT == 2)); then - # We're completing the first word after "darcs" -- the command. - _wanted command expl 'darcs command' \ - compadd -- $( darcs --commands ) + compadd -- $(darcs --commands) else + case "${words[2]}"; in + get|clone) + _urls + ;; + esac case "${words[$CURRENT]}"; in - # If it looks like an URL... - ht*|ft*) - _arguments '*:URL:_urls' - ;; - # If it looks like an explicit path... /*|./*|\~*|../*) - _arguments '*:file:_files' - ;; - # Otherwise, let's ask darcs for all possible options + _files + ;; + -*) + # advanced zsh (array) parameter expansion fu: + # - ${(f)...} means split into array elements at line endings + # instead of white space + # - ${arr:#pat} drops elements matching pat from arr, whereas + # ${(M)arr:#pat} drops non-matching elements + # - ${arr/pat/repl} replaces pat with repl for all elements of arr + darcs_arguments=(${(f)"$(words[$CURRENT]=--list-options && $words 2>/dev/null)"}) + darcs_options=(${${(M)darcs_arguments:#-*}/;/:}) + _describe '' darcs_options + ;; *) - _arguments '*: :($(words[$CURRENT]="--list-options" && $words))' + darcs_arguments=(${(f)"$(words[$CURRENT]=--list-options && $words 2>/dev/null)"}) + darcs_non_options=(${darcs_arguments:#-*}) + _multi_parts -i -S ' ' / darcs_non_options ;; esac fi diff --git a/contrib/darcs_completion b/contrib/darcs_completion --- a/contrib/darcs_completion +++ b/contrib/darcs_completion @@ -16,9 +16,27 @@ return 0 fi - local IFS=$'\n' # So that the following "command-output to array" operation splits only at newlines, not at each space, tab or newline. - COMPREPLY=( $( darcs ${COMP_WORDS[1]} --list-option | command grep "^${cur//./\\.}") ) + # Store the whole command line substituting the (possibly empty) + # to-be-completed word with '--list-options'. + local -a words=("${COMP_WORDS[@]}") + words[$COMP_CWORD]="--list-options" + # Options are processed from left to right, so avoid to display the help + # page when trying to complete a command line that includes '--help'. It + # could be tricked by things like '--repodir --hell', but, come on... you + # don't deserve a working completion if you name a directory '--hell'. + for w in "${words[@]}"; do + case "$w" in + (--he*) return 0;; + esac + done + + # So that the following "command-output to array" operation splits only at + # newlines, not at each space, tab or newline. + local IFS=$'\n' + COMPREPLY=( $( "${words[@]}" 2>/dev/null |\ + command grep "^${cur//./\\.}" | cut -d ';' -f 1) ) + # Then, we adapt the resulting strings to be reusable by bash. If we don't # do this, in the case where we have two repositories named # ~/space in there-0.1 and ~/space in there-0.2, the first completion will @@ -42,11 +60,8 @@ local colonprefixes=${cur%"${cur##*:}"} while [ $((--i)) -ge 0 ]; do COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"` - COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} done return 0 - } complete -F _darcs -o default darcs - diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,6 +1,6 @@ Name: darcs -version: 2.12.5 -License: GPL +version: 2.14.0 +License: GPL-2 License-file: COPYING Author: David Roundy , Maintainer: @@ -33,7 +33,7 @@ Homepage: http://darcs.net/ Build-Type: Custom -Cabal-Version: >= 1.16 +Cabal-Version: >= 1.24 extra-source-files: -- C headers @@ -107,16 +107,16 @@ manual: True description: Build with warnings-as-errors --- Note that the Setup script checks whether -liconv is necessary. This flag --- lets us override that decision. When it is True, we use -liconv. When it --- is False, we run tests to decide. -flag libiconv - Description: Explicitly link against the libiconv library. - Default: False +-- ---------------------------------------------------------------------- +-- setup +-- ---------------------------------------------------------------------- -flag network-uri - description: Get Network.URI from the network-uri package - default: True +custom-setup + setup-depends: base >= 4.9 && < 4.12, + Cabal >= 1.24, + process >= 1.2.3.0 && < 1.7, + filepath >= 1.4.1 && < 1.5.0.0, + directory >= 1.2.6.2 && < 1.4 -- ---------------------------------------------------------------------- -- darcs library @@ -158,10 +158,7 @@ Darcs.Patch.MonadProgress Darcs.Patch.Named Darcs.Patch.Named.Wrapped - Darcs.Patch.OldDate Darcs.Patch.PatchInfoAnd - Darcs.Patch.Patchy - Darcs.Patch.Patchy.Instances Darcs.Patch.Permutations Darcs.Patch.Prim Darcs.Patch.Prim.Class @@ -208,11 +205,13 @@ Darcs.Patch.V1.Apply Darcs.Patch.V1.Commute Darcs.Patch.V1.Core + Darcs.Patch.V1.Prim Darcs.Patch.V1.Read Darcs.Patch.V1.Show Darcs.Patch.V1.Viewing Darcs.Patch.V2 Darcs.Patch.V2.Non + Darcs.Patch.V2.Prim Darcs.Patch.V2.RepoPatch Darcs.Patch.Witnesses.Eq Darcs.Patch.Witnesses.Ordered @@ -225,18 +224,19 @@ Darcs.Repository.ApplyPatches Darcs.Repository.Cache Darcs.Repository.Clone + Darcs.Repository.Create Darcs.Repository.PatchIndex Darcs.Repository.Diff Darcs.Repository.Flags Darcs.Repository.Format Darcs.Repository.HashedIO - Darcs.Repository.HashedRepo - Darcs.Repository.Internal + Darcs.Repository.Hashed + Darcs.Repository.Inventory + Darcs.Repository.Identify Darcs.Repository.Job Darcs.Repository.Merge Darcs.Repository.InternalTypes Darcs.Repository.Match - Darcs.Repository.Motd Darcs.Repository.Old Darcs.Repository.Packs Darcs.Repository.Pending @@ -246,6 +246,7 @@ Darcs.Repository.Resolution Darcs.Repository.State Darcs.Repository.Test + Darcs.Repository.Working Darcs.UI.ApplyPatches Darcs.UI.Commands Darcs.UI.Commands.Add @@ -277,7 +278,6 @@ Darcs.UI.Commands.SetPref Darcs.UI.Commands.Show Darcs.UI.Commands.ShowAuthors - Darcs.UI.Commands.ShowBug Darcs.UI.Commands.ShowContents Darcs.UI.Commands.ShowDependencies Darcs.UI.Commands.ShowFiles @@ -293,6 +293,7 @@ Darcs.UI.Commands.Unrecord Darcs.UI.Commands.Unrevert Darcs.UI.Commands.WhatsNew + Darcs.UI.Completion Darcs.UI.Email Darcs.UI.External Darcs.UI.Defaults @@ -311,14 +312,10 @@ Darcs.UI.SelectChanges Darcs.UI.TheCommands Darcs.UI.Usage - Darcs.UI.Message.Send Darcs.Util.AtExit - Darcs.Util.Bug Darcs.Util.ByteString Darcs.Util.CommandLine Darcs.Util.Compat - Darcs.Util.Crypt.SHA1 - Darcs.Util.Crypt.SHA256 Darcs.Util.DateMatcher Darcs.Util.DateTime Darcs.Util.Diff @@ -327,8 +324,8 @@ Darcs.Util.Download Darcs.Util.Download.Request Darcs.Util.Download.HTTP + Darcs.Util.Encoding Darcs.Util.English - Darcs.Util.Environment Darcs.Util.Exception Darcs.Util.Exec Darcs.Util.External @@ -354,14 +351,11 @@ Darcs.Util.Tree.Plain Darcs.Util.URL Darcs.Util.Workaround - Bundled.Posix other-modules: Version Darcs.Util.Download.Curl - Darcs.Util.Encoding c-sources: src/atomic_create.c - src/fpstring.c src/maybe_relink.c src/umask.c src/system_encoding.c @@ -382,98 +376,81 @@ System.Posix.IO cpp-options: -DWIN32 c-sources: src/win32/send_email.c - build-depends: Win32 >= 2.3 && < 2.4 + build-depends: Win32 >= 2.3.1 && < 2.4 else - other-modules: Darcs.Util.Encoding.IConv - c-sources: src/h_iconv.c - build-depends: unix >= 2.6.0.1 && < 2.8 + build-depends: unix >= 2.7.1.0 && < 2.8 - build-depends: base >= 4.8 && < 4.10, - binary >= 0.5 && < 0.9, - containers >= 0.5 && < 0.6, - regex-compat-tdfa >= 0.95.1 && < 0.96, - regex-applicative >= 0.2 && < 0.4, - mtl >= 2.1.2 && < 2.3, - transformers >= 0.3 && < 0.4.0.0 || > 0.4.0.0 && < 0.6, - -- for the Control.Monad.Error -> Control.Monad.Except - -- transition - transformers-compat >= 0.4 && < 0.6, - parsec >= 3.1 && < 3.2, - fgl >= 5.5.0.1 && < 5.6, - graphviz >= 2999.17.0.1 && < 2999.19, - html >= 1.0.1.2 && < 1.1, - filepath >= 1.3.0.1 && < 1.5.0.0, - haskeline >= 0.6.3 && < 0.8, - cryptohash >= 0.4 && < 0.12, - base16-bytestring >= 0.1 && < 0.2, - utf8-string >= 0.3.6 && < 1.1, - vector >= 0.10.0.1 && < 0.13, - tar >= 0.4 && < 0.6, - data-ordlist == 0.4.*, - attoparsec >= 0.11 && < 0.14, - zip-archive >= 0.2.3 && < 0.4, - async >= 2.0.1.4 && < 2.2, - sandi >= 0.4 && < 0.5, - unix-compat >= 0.1.2 && < 0.5, - bytestring >= 0.10.0.2 && < 0.11, - old-time >= 1.1 && < 1.2, - time >= 1.5 && < 1.8, - -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: - -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html - text >= 1.2.1.3 && < 1.3, - directory >= 1.2.0.1 && < 1.4.0.0, - process >= 1.1.0.2 && < 1.5.0.0, - array >= 0.4.0.1 && < 0.6, - random >= 1.0.1.1 && < 1.2, - hashable >= 1.1.2.5 && < 1.3, - mmap >= 0.5 && < 0.6, - zlib >= 0.5.4.1 && < 0.7.0.0 + build-depends: base >= 4.9 && < 4.12, + stm >= 2.1 && < 2.5, + binary >= 0.5 && < 0.9, + containers >= 0.5.6.2 && < 0.6, + regex-compat-tdfa >= 0.95.1 && < 0.96, + regex-applicative >= 0.2 && < 0.4, + mtl >= 2.2.1 && < 2.3, + transformers >= 0.4.2.0 && < 0.6, + parsec >= 3.1.9 && < 3.2, + fgl >= 5.5.2.3 && < 5.6, + graphviz >= 2999.18.1 && < 2999.20, + html >= 1.0.1.2 && < 1.1, + filepath >= 1.4.1 && < 1.5.0.0, + haskeline >= 0.7.2 && < 0.8, + cryptohash >= 0.11 && < 0.12, + base16-bytestring >= 0.1 && < 0.2, + utf8-string >= 1 && < 1.1, + vector >= 0.11 && < 0.13, + tar >= 0.5 && < 0.6, + data-ordlist == 0.4.*, + attoparsec >= 0.13.0.1 && < 0.14, + zip-archive >= 0.3 && < 0.4, + async >= 2.0.2 && < 2.2, + sandi >= 0.4 && < 0.5, + unix-compat >= 0.4.2 && < 0.6, + bytestring >= 0.10.6 && < 0.11, + old-time >= 1.1.0.3 && < 1.2, + time >= 1.5.0.1 && < 1.9, + text >= 1.2.1.3 && < 1.3, + directory >= 1.2.6.2 && < 1.4, + temporary >= 1.2.0.4 && < 1.3, + process >= 1.2.3.0 && < 1.7, + array >= 0.5.1.0 && < 0.6, + random >= 1.1 && < 1.2, + hashable >= 1.2.3.3 && < 1.3, + mmap >= 0.5.9 && < 0.6, + zlib >= 0.6.1.2 && < 0.7.0.0, + network-uri == 2.6.*, + network == 2.6.*, + HTTP >= 4000.2.20 && < 4000.4 if flag(optimize) - ghc-options: -O2 + ghc-options: -O2 else - ghc-options: -O0 + ghc-options: -O0 if flag(warn-as-error) - ghc-options: -Werror - - -- Note: "if true" works around a cabal bug with order of flag composition - -- fixed in Cabal 1.18 https://github.com/haskell/cabal/commit/cf0cf077ab6836584fc3bf51d867e63824811d4d - if true - ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-dodgy-imports + ghc-options: -Werror - if impl(ghc>=8.0) - -- This warning is new in GHC 8.0 and is not easy to fix - ghc-options: -fno-warn-redundant-constraints + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs if flag(curl) - cpp-options: -DHAVE_CURL - c-sources: src/hscurl.c - cc-options: -DHAVE_CURL + cpp-options: -DHAVE_CURL + c-sources: src/hscurl.c + cc-options: -DHAVE_CURL if flag(pkgconfig) - pkgconfig-depends: libcurl + pkgconfig-depends: libcurl else - extra-libraries: curl - includes: curl/curl.h - - if flag(network-uri) - build-depends: network-uri == 2.6.*, network == 2.6.* - else - build-depends: network >= 2.4.1.2 && < 2.6 - - build-depends: HTTP >= 4000.2.8 && < 4000.4 + extra-libraries: curl + includes: curl/curl.h -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) - build-depends: terminfo >= 0.3 && < 0.5 - cpp-options: -DHAVE_TERMINFO + build-depends: terminfo >= 0.4.0.2 && < 0.5 + cpp-options: -DHAVE_TERMINFO - -- if true to work around cabal bug with flag ordering - if true - default-extensions: + default-extensions: BangPatterns PatternGuards - GADTs + GADTSyntax + ExistentialQuantification TypeOperators FlexibleContexts FlexibleInstances @@ -501,50 +478,29 @@ hs-source-dirs: darcs if flag(optimize) - ghc-options: -O2 + ghc-options: -O2 else - ghc-options: -O0 + ghc-options: -O0 if flag(warn-as-error) - ghc-options: -Werror + ghc-options: -Werror - -- Note: "if true" works around a cabal bug with order of flag composition - if true - ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-dodgy-imports + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs if flag(threaded) ghc-options: -threaded if flag(static) - ghc-options: -static -optl-static -optl-pthread + ghc-options: -static -optl-static -optl-pthread if flag(rts) - ghc-options: -rtsopts - - if impl(ghc>=8.0) - -- This warning is new in GHC 8.0 and is not easy to fix - ghc-options: -fno-warn-redundant-constraints + ghc-options: -rtsopts -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT - build-depends: darcs, - base >= 4.8 && < 4.10 - - -- if true to work around cabal bug with flag ordering - if true - default-extensions: - BangPatterns - PatternGuards - GADTs - TypeOperators - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - KindSignatures - RankNTypes - TypeFamilies - NoMonoLocalBinds + build-depends: darcs, + base >= 4.9 && < 4.12 -- ---------------------------------------------------------------------- -- unit test driver @@ -558,32 +514,33 @@ hs-source-dirs: harness if os(windows) - cpp-options: -DWIN32 - build-depends: Win32 >= 2.2 && < 2.4 + cpp-options: -DWIN32 + build-depends: Win32 >= 2.3.1 && < 2.4 - build-depends: darcs, - base >= 4.8 && < 4.10, - array >= 0.4.0.1 && < 0.6, - bytestring >= 0.10.0.2 && < 0.11, - cmdargs >= 0.10 && < 0.11, - containers >= 0.1 && < 0.6, - filepath >= 1.3.0.1 && < 1.5.0.0, - mtl >= 2.1 && < 2.3, - shelly >= 1.6.2 && < 1.7, - split >= 0.2.2 && < 0.3, - text >= 1.2.1.3 && < 1.3, - directory >= 1.2.0.1 && < 1.4.0.0, - FindBin >= 0.0 && < 0.1, - QuickCheck >= 2.6 && < 2.10, - HUnit >= 1.2.5.2 && < 1.6, - test-framework >= 0.4.0 && < 0.9, - test-framework-hunit >= 0.2.2 && < 0.4, - test-framework-quickcheck2 >= 0.3 && < 0.4, - zip-archive >= 0.2.3 && < 0.4 + build-depends: darcs, + base >= 4.9 && < 4.12, + array >= 0.5.1.0 && < 0.6, + bytestring >= 0.10.6 && < 0.11, + cmdargs >= 0.10.10 && < 0.11, + containers >= 0.5.6.2 && < 0.6, + filepath >= 1.4.1 && < 1.5.0.0, + mtl >= 2.2.1 && < 2.3, + shelly >= 1.6.8 && < 1.7, + split >= 0.2.2 && < 0.3, + text >= 1.2.1.3 && < 1.3, + directory >= 1.2.6.2 && < 1.4, + FindBin >= 0.0.5 && < 0.1, + QuickCheck >= 2.8.2 && < 2.11, + HUnit >= 1.3 && < 1.7, + test-framework >= 0.8.1.1 && < 0.9, + test-framework-hunit >= 0.3.0.2 && < 0.4, + test-framework-quickcheck2 >= 0.3.0.3 && < 0.4, + zip-archive >= 0.3 && < 0.4 -- list all unit test modules not exported by libdarcs; otherwise Cabal won't -- include them in the tarball other-modules: Darcs.Test.Email + Darcs.Test.HashedStorage Darcs.Test.Patch.Check Darcs.Test.Patch.Examples.Set1 Darcs.Test.Patch.Examples.Set2Unwitnessed @@ -609,37 +566,34 @@ Darcs.Test.Patch.WithState Darcs.Test.Patch Darcs.Test.Misc + Darcs.Test.Misc.CommandLine + Darcs.Test.Misc.Encoding + Darcs.Test.Repository.Inventory Darcs.Test.Util.TestResult Darcs.Test.Util.QuickCheck - Storage.Hashed.Test if flag(optimize) - ghc-options: -O2 + ghc-options: -O2 else - ghc-options: -O0 + ghc-options: -O0 if flag(warn-as-error) - ghc-options: -Werror + ghc-options: -Werror - -- Note: "if true" works around a cabal bug with order of flag composition - if true - ghc-options: -Wall -funbox-strict-fields -fwarn-tabs + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-orphans if flag(threaded) ghc-options: -threaded if flag(rts) - ghc-options: -rtsopts + ghc-options: -rtsopts -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT - -- if true to work around cabal bug with flag ordering - if true - default-extensions: - BangPatterns - PatternGuards - GADTs + default-extensions: + GADTSyntax + ExistentialQuantification TypeOperators FlexibleContexts FlexibleInstances @@ -650,5 +604,3 @@ RankNTypes TypeFamilies NoMonoLocalBinds - - diff --git a/darcs/darcs.hs b/darcs/darcs.hs --- a/darcs/darcs.hs +++ b/darcs/darcs.hs @@ -27,27 +27,24 @@ module Main ( main ) where +import Prelude () +import Darcs.Prelude + import Control.Exception ( AssertionFailed(..), handle ) -import Control.Monad ( forM_ ) -import System.IO ( stdin, stdout, stderr, hSetBinaryMode ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs ) import Darcs.UI.RunCommand ( runTheCommand ) import Darcs.UI.Commands.Help ( helpCmd, listAvailableCommands, printVersion, commandControlList ) -import Darcs.UI.Flags ( DarcsFlag(Verbose) ) import Darcs.Util.AtExit ( withAtexit, atexit ) import Darcs.Repository( reportBadSources ) import Darcs.Util.SignalHandler ( withSignalsHandled ) -import Darcs.Util.ByteString ( decodeString ) import Darcs.UI.External ( setDarcsEncodings ) import Darcs.Util.Exec ( ExecException(..) ) import Darcs.Util.Path ( getCurrentDirectory ) -import Version ( version, context, builddeps ) - -#include "impossible.h" +import Version ( version, context, weakhash ) execExceptionHandler :: ExecException -> IO a execExceptionHandler (ExecException cmd args redirects reason) = do @@ -62,7 +59,7 @@ main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do atexit reportBadSources setDarcsEncodings - argv <- getArgs >>= mapM decodeString + argv <- getArgs here <- getCurrentDirectory let runHelpCmd = helpCmd (here, here) [] [] -- Explicitly handle no-args and special "help" arguments. @@ -70,20 +67,17 @@ [] -> printVersion >> runHelpCmd ["-h"] -> runHelpCmd ["--help"] -> runHelpCmd - ["--overview"] -> helpCmd (here, here) [Verbose] [] ["--commands"] -> listAvailableCommands ["-v"] -> putStrLn version + ["-V"] -> putStrLn version ["--version"] -> putStrLn version ["--exact-version"] -> printExactVersion - _ -> do - forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True - runTheCommand commandControlList (head argv) (tail argv) + _ -> runTheCommand commandControlList (head argv) (tail argv) where handleExecFail = handle execExceptionHandler handleAssertFail = handle $ \(AssertionFailed e) -> bug e printExactVersion = do - putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ + putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ ++ "\n" + putStrLn $ "Weak Hash: " ++ weakhash putStrLn context - putStrLn "Compiled with:\n" - putStr builddeps diff --git a/harness/Darcs/Test/Email.hs b/harness/Darcs/Test/Email.hs --- a/harness/Darcs/Test/Email.hs +++ b/harness/Darcs/Test/Email.hs @@ -21,15 +21,17 @@ -- 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. + module Darcs.Test.Email ( testSuite ) where import Data.Char ( isPrint ) -import qualified Data.ByteString as B ( length, unpack, null, head, +import qualified Data.ByteString as B ( length, unpack, null, head, pack, cons, empty, foldr, ByteString ) -import qualified Data.ByteString.Char8 as BC ( unpack ) +import qualified Data.ByteString.Char8 as BC ( unlines ) import Test.Framework ( Test, testGroup ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) -import Darcs.Util.Printer ( text, renderPS, RenderMode(..) ) -import Darcs.UI.Email ( makeEmail, readEmail, formatHeader ) +import Test.QuickCheck ( Arbitrary(..) ) +import Darcs.Util.Printer ( text, renderPS, packedString ) +import Darcs.UI.Email ( makeEmail, readEmail, formatHeader, prop_qp_roundtrip ) testSuite :: Test testSuite = testGroup "Darcs.Email" @@ -38,16 +40,17 @@ , emailHeaderAsciiChars , emailHeaderLinesStart , emailHeaderNoEmptyLines + , emailCodecRoundtrip ] -- | Checks that darcs can read the emails it generates emailParsing :: Test -emailParsing = testProperty "Checking that email can be parsed" $ \s -> - unlines ("":s++["", ""]) == - BC.unpack (readEmail (renderPS Standard +emailParsing = testProperty "Checking that email can be parsed" $ \bs -> + BC.unlines (B.empty:bs++[B.empty,B.empty]) == + readEmail (renderPS $ makeEmail "reponame" [] (Just (text "contents\n")) Nothing - (text $ unlines s) (Just "filename"))) + (packedString $ BC.unlines bs) (Just "filename")) -- | Check that formatHeader never creates lines longer than 78 characters -- (excluding the carriage return and line feed) @@ -81,6 +84,13 @@ let headerLines = bsLines (formatHeader cleanField value) cleanField = cleanFieldString field in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines + +instance Arbitrary B.ByteString where + arbitrary = fmap B.pack arbitrary + +emailCodecRoundtrip :: Test +emailCodecRoundtrip = + testProperty "Checking that quoted printable en- then decoding is id" $ prop_qp_roundtrip bsLines :: B.ByteString -> [B.ByteString] bsLines = finalizeFold . B.foldr splitAtLines (B.empty, []) diff --git a/harness/Darcs/Test/HashedStorage.hs b/harness/Darcs/Test/HashedStorage.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/HashedStorage.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} +module Darcs.Test.HashedStorage( tests ) where + +import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) ) +import qualified Prelude +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString.Char8 as BC +import System.Directory( doesFileExist, removeFile, doesDirectoryExist ) +import System.FilePath( () ) +import Control.Monad.Identity +import Control.Monad.Trans( lift ) +import Control.Applicative( (<$>) ) +import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) + +import Data.Maybe +import Data.Word +import Data.List( sort, intercalate, intersperse ) + +import Darcs.Util.Path hiding ( setCurrentDirectory ) +import Darcs.Util.Lock ( withTempDir ) +import Darcs.Util.Tree hiding ( lookup ) +import Darcs.Util.Index +import Darcs.Util.Tree.Hashed +import Darcs.Util.Hash +import Darcs.Util.Tree.Monad hiding ( tree, createDirectory ) +import Darcs.Util.Tree.Plain + +import System.Mem( performGC ) + +import qualified Data.Set as S + +import Test.HUnit hiding ( path ) +import Test.Framework( testGroup ) +import qualified Test.Framework as TF ( Test ) +import Test.QuickCheck + +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +------------------------ +-- Test Data +-- + +blobs :: [(AnchoredPath, BLC.ByteString)] +blobs = [ (floatPath "foo_a", BLC.pack "a\n") + , (floatPath "foo_dir/foo_a", BLC.pack "a\n") + , (floatPath "foo_dir/foo_b", BLC.pack "b\n") + , (floatPath "foo_dir/foo_subdir/foo_a", BLC.pack "a\n") + , (floatPath "foo space/foo\nnewline", BLC.pack "newline\n") + , (floatPath "foo space/foo\\backslash", BLC.pack "backslash\n") + , (floatPath "foo space/foo_a", BLC.pack "a\n") ] + +files :: [AnchoredPath] +files = map fst blobs + +dirs :: [AnchoredPath] +dirs = [ floatPath "foo_dir" + , floatPath "foo_dir/foo_subdir" + , floatPath "foo space" ] + +emptyStub :: TreeItem IO +emptyStub = Stub (return emptyTree) NoHash + +testTree :: Tree IO +testTree = + makeTree [ (makeName "foo", emptyStub) + , (makeName "subtree", SubTree sub) + , (makeName "substub", Stub getsub NoHash) ] + where sub = makeTree [ (makeName "stub", emptyStub) + , (makeName "substub", Stub getsub2 NoHash) + , (makeName "x", SubTree emptyTree) ] + getsub = return sub + getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) + , (makeName "file2", + File $ Blob (return $ BLC.pack "foo") NoHash) ] + +equals_testdata :: Tree IO -> IO () +equals_testdata t = sequence_ [ + do isJust (findFile t p) @? show p ++ " in tree" + ours <- readBlob (fromJust $ findFile t p) + ours @?= stored + | (p, stored) <- blobs ] >> + sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree" + | (p, File _) <- list t ] + +--------------------------- +-- Test list +-- + +tests :: [TF.Test] +tests = [ testGroup "Darcs.Util.Hash" hash + , testGroup "Darcs.Util.Tree" tree + , testGroup "Darcs.Util.Index" index + , testGroup "Darcs.Util.Tree.Monad" monad + , testGroup "Hashed Storage" hashed ] + +-------------------------- +-- Tests +-- + +hashed :: [TF.Test] +hashed = [ testCase "plain has all files" have_files + , testCase "pristine has all files" have_pristine_files + , testCase "pristine has no extras" pristine_no_extra + , testCase "pristine file contents match" pristine_contents + , testCase "plain file contents match" plain_contents + , testCase "writePlainTree works" write_plain ] + where + check_file t f = assertBool + ("path " ++ show f ++ " is missing in tree " ++ show t) + (isJust $ find t f) + check_files = forM_ files . check_file + + pristine_no_extra = extractRepoAndRun $ + do + t <- readDarcsPristine "." >>= expand + forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") + (path `elem` (dirs ++ files)) + have_files = extractRepoAndRun ( readPlainTree "." >>= expand >>= check_files ) + have_pristine_files = extractRepoAndRun ( readDarcsPristine "." >>= expand >>= check_files ) + + pristine_contents = extractRepoAndRun $ + do + t <- readDarcsPristine "." >>= expand + equals_testdata t + + plain_contents = extractRepoAndRun $ + do + t <- expand =<< filter nondarcs `fmap` readPlainTree "." + equals_testdata t + + write_plain = extractRepoAndRun $ + do + orig <- readDarcsPristine "." >>= expand + writePlainTree orig "_darcs/plain" + t <- expand =<< readPlainTree "_darcs/plain" + equals_testdata t + +index :: [TF.Test] +index = [ testCase "index versioning" check_index_versions + , testCase "index listing" check_index + , testCase "index content" check_index_content + , testProperty "xlate32" prop_xlate32 + , testProperty "xlate64" prop_xlate64 + , testProperty "align bounded" prop_align_bounded + , testProperty "align aligned" prop_align_aligned ] + where pristine = readDarcsPristine "." >>= expand + build_index = + do x <- pristine + exist <- doesFileExist "_darcs/index" + performGC -- required in win32 to trigger file close + when exist $ removeFile "_darcs/index" + idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x + return (x, idx) + check_index = extractRepoAndRun $ + do (pris, idx) <- build_index + (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) + check_blob_pair p x y = + do a <- readBlob x + b <- readBlob y + assertEqual ("content match on " ++ show p) a b + check_index_content = extractRepoAndRun $ + do (_, idx) <- build_index + plain <- readPlainTree "." + x <- sequence $ zipCommonFiles check_blob_pair plain idx + assertBool "files match" (length x > 0) + check_index_versions = extractRepoAndRun $ + do performGC -- required in win32 to trigger file close + Prelude.writeFile "_darcs/index" "nonsense index... do not crash!" + valid <- indexFormatValid "_darcs/index" + assertBool "index format invalid" $ not valid + prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32 + prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64 + prop_align_bounded (bound, x) = + bound > 0 && bound < 1024 && x >= 0 ==> + align bound x >= x && align bound x < x + bound + where _types = (bound, x) :: (Int, Int) + prop_align_aligned (bound, x) = + bound > 0 && bound < 1024 && x >= 0 ==> + align bound x `rem` bound == 0 + where _types = (bound, x) :: (Int, Int) + +tree :: [TF.Test] +tree = [ testCase "modifyTree" check_modify + , testCase "complex modifyTree" check_modify_complex + , testCase "modifyTree removal" check_modify_remove + , testCase "expand" check_expand + , testCase "expandPath" check_expand_path + , testCase "expandPath of sub" check_expand_path_sub + , testCase "diffTrees" check_diffTrees + , testCase "diffTrees identical" check_diffTrees_ident + , testProperty "expandPath" prop_expandPath + , testProperty "shapeEq" prop_shape_eq + , testProperty "expandedShapeEq" prop_expanded_shape_eq + , testProperty "expand is identity" prop_expand_id + , testProperty "filter True is identity" prop_filter_id + , testProperty "filter False is empty" prop_filter_empty + , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative + , testProperty "restrict is a subtree of both" prop_restrict_subtree + , testProperty "overlay keeps shape" prop_overlay_shape + , testProperty "overlay is superset of over" prop_overlay_super ] + where blob x = File $ Blob (return (BLC.pack x)) (sha256 $ BLC.pack x) + name = makeName + check_modify = + let t = makeTree [(name "foo", blob "bar")] + modify = modifyTree t (floatPath "foo") (Just $ blob "bla") + in do x <- readBlob $ fromJust $ findFile t (floatPath "foo") + y <- readBlob $ fromJust $ findFile modify (floatPath "foo") + assertEqual "old version" x (BLC.pack "bar") + assertEqual "new version" y (BLC.pack "bla") + assertBool "list has foo" $ + isJust (Prelude.lookup (floatPath "foo") $ list modify) + length (list modify) @?= 1 + check_modify_complex = + let t = makeTree [ (name "foo", blob "bar") + , (name "bar", SubTree t1) ] + t1 = makeTree [ (name "foo", blob "bar") ] + modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") + in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo") + foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo") + bar_foo <- readBlob $ fromJust $ + findFile t (floatPath "bar/foo") + bar_foo' <- readBlob $ fromJust $ + findFile modify (floatPath "bar/foo") + assertEqual "old foo" foo (BLC.pack "bar") + assertEqual "old bar/foo" bar_foo (BLC.pack "bar") + assertEqual "new foo" foo' (BLC.pack "bar") + assertEqual "new bar/foo" bar_foo' (BLC.pack "bla") + assertBool "list has bar/foo" $ + isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) + assertBool "list has foo" $ + isJust (Prelude.lookup (floatPath "foo") $ list modify) + length (list modify) @?= length (list t) + check_modify_remove = + let t1 = makeTree [(name "foo", blob "bar")] + t2 :: Tree Identity = makeTree [ (name "foo", blob "bar") + , (name "bar", SubTree t1) ] + modify1 = modifyTree t1 (floatPath "foo") Nothing + modify2 = modifyTree t2 (floatPath "bar") Nothing + file = findFile modify1 (floatPath "foo") + subtree = findTree modify2 (floatPath "bar") + in do assertBool "file is gone" (isNothing file) + assertBool "subtree is gone" (isNothing subtree) + + no_stubs t = null [ () | (_, Stub _ _) <- list t ] + path = floatPath "substub/substub/file" + badpath = floatPath "substub/substub/foo" + check_expand = do + x <- expand testTree + assertBool "no stubs in testTree" $ not (no_stubs testTree) + assertBool "stubs in expanded tree" $ no_stubs x + assertBool "path reachable" $ path `elem` (map fst $ list x) + assertBool "badpath not reachable" $ + badpath `notElem` (map fst $ list x) + check_expand_path = do + test_exp <- expand testTree + t <- expandPath testTree path + t' <- expandPath test_exp path + t'' <- expandPath testTree $ floatPath "substub/x" + assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) + assertBool "path reachable in t" $ path `elem` (map fst $ list t) + assertBool "path reachable in t'" $ path `elem` (map fst $ list t') + assertBool "path reachable in t (with findFile)" $ + isJust $ findFile t path + assertBool "path reachable in t' (with findFile)" $ + isJust $ findFile t' path + assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') + assertBool "badpath not reachable in t" $ + badpath `notElem` (map fst $ list t) + assertBool "badpath not reachable in t'" $ + badpath `notElem` (map fst $ list t') + + check_expand_path_sub = do + t <- expandPath testTree $ floatPath "substub" + t' <- expandPath testTree $ floatPath "substub/stub" + t'' <- expandPath testTree $ floatPath "subtree/stub" + assertBool "leaf is not a Stub" $ + isNothing (findTree testTree $ floatPath "substub") + assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") + assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") + assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") + + check_diffTrees = extractRepoAndRun $ + do Prelude.writeFile "foo_dir/foo_a" "b\n" + working_plain <- filter nondarcs `fmap` readPlainTree "." + working <- updateIndex =<< + updateIndexFrom "_darcs/index" darcsTreeHash working_plain + pristine <- readDarcsPristine "." + (working', pristine') <- diffTrees working pristine + let foo_work = findFile working' (floatPath "foo_dir/foo_a") + foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") + working' `shapeEq` pristine' + @? show working' ++ " `shapeEq` " ++ show pristine' + assertBool "foo_dir/foo_a is in working'" $ isJust foo_work + assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris + foo_work_c <- readBlob (fromJust foo_work) + foo_pris_c <- readBlob (fromJust foo_pris) + BLC.unpack foo_work_c @?= "b\n" + BLC.unpack foo_pris_c @?= "a\n" + assertEqual "working' tree is minimal" 2 (length $ list working') + assertEqual "pristine' tree is minimal" 2 (length $ list pristine') + + check_diffTrees_ident = do + pristine <- readDarcsPristine "." + (t1, t2) <- diffTrees pristine pristine + assertBool "t1 is empty" $ null (list t1) + assertBool "t2 is empty" $ null (list t2) + + prop_shape_eq x = no_stubs x ==> x `shapeEq` x + where _types = x :: Tree Identity + prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x + where _types = x :: Tree Identity + prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x + where _types = x :: Tree Identity + prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x + where _types = x :: Tree Identity + prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x + where _types = x :: Tree Identity + prop_restrict_shape_commutative (t1, t2) = + no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> + restrict t1 t2 `shapeEq` restrict t2 t1 + where _types = (t1 :: Tree Identity, t2 :: Tree Identity) + prop_restrict_subtree (t1, t2) = + no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==> + let restricted = S.fromList (map fst $ list $ restrict t1 t2) + orig1 = S.fromList (map fst $ list t1) + orig2 = S.fromList (map fst $ list t2) + in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] + where _types = (t1 :: Tree Identity, t2 :: Tree Identity) + prop_overlay_shape (t1 :: Tree Identity, t2) = + (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> + runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 + prop_overlay_super (t1 :: Tree Identity, t2) = + (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==> + Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) + prop_expandPath (TreeWithPath t p) = + notStub $ find (runIdentity $ expandPath t p) p + where notStub (Just (Stub _ _)) = False + notStub Nothing = error "Did not exist." + notStub _ = True + +hash :: [TF.Test] +hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 ] + where prop_base16 x = (decodeBase16 . encodeBase16) x == x + +monad :: [TF.Test] +monad = [ testCase "path expansion" check_virtual + , testCase "rename" check_rename ] + where check_virtual = virtualTreeMonad run testTree >> return () + where run = do file <- readFile (floatPath "substub/substub/file") + file2 <- readFile (floatPath "substub/substub/file2") + lift $ BLC.unpack file @?= "" + lift $ BLC.unpack file2 @?= "foo" + check_rename = do (_, t) <- virtualTreeMonad run testTree + t' <- darcsAddMissingHashes =<< expand t + forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> + assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash + where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") + +---------------------------------- +-- Arbitrary instances +-- + +instance Arbitrary BLC.ByteString where + arbitrary = BLC.pack `fmap` arbitrary + +instance Arbitrary Hash where + arbitrary = sized hash' + where hash' 0 = return NoHash + hash' _ = SHA256 . BC.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ] + +instance (Monad m) => Arbitrary (TreeItem m) where + arbitrary = sized tree' + where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] + tree' n = oneof [ file n, subtree n ] + file 0 = return (File emptyBlob) + file _ = do content <- arbitrary + return (File $ Blob (return content) NoHash) + subtree n = do branches <- choose (1, n) + let sub name = do t <- tree' ((n - 1) `div` branches) + return (makeName $ show name, t) + sublist <- mapM sub [0..branches] + oneof [ tree' 0 + , return (SubTree $ makeTree sublist) + , return $ (Stub $ return (makeTree sublist)) NoHash ] + +instance (Monad m) => Arbitrary (Tree m) where + arbitrary = do item <- arbitrary + case item of + File _ -> arbitrary + Stub _ _ -> arbitrary + SubTree t -> return t + +data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show) + +instance Arbitrary TreeWithPath where + arbitrary = do t <- arbitrary + p <- oneof $ return (AnchoredPath []) : + (map (return . fst) $ list (runIdentity $ expand t)) + return $ TreeWithPath t p + +--------------------------- +-- Other instances +-- + +instance Show (Blob m) where + show (Blob _ h) = "Blob " ++ show h + +instance Show (TreeItem m) where + show (File f) = "File (" ++ show f ++ ")" + show (Stub _ h) = "Stub _ " ++ show h + show (SubTree s) = "SubTree (" ++ show s ++ ")" + +instance Show (Tree m) where + show t = "Tree " ++ show (treeHash t) ++ " { " ++ + (concat . intersperse ", " $ itemstrs) ++ " }" + where itemstrs = map show $ listImmediate t + +instance Show (Int -> Int) where + show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" + where val x = show x ++ " -> " ++ show (f x) + +----------------------- +-- Test utilities +-- + +shapeEq :: Tree m -> Tree m -> Bool +shapeEq a b = Just EQ == cmpShape a b + +expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool +expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b + +cmpcat :: [Maybe Ordering] -> Maybe Ordering +cmpcat (x:y:rest) | x == y = cmpcat (x:rest) + | x == Just EQ = cmpcat (y:rest) + | y == Just EQ = cmpcat (x:rest) + | otherwise = Nothing +cmpcat [x] = x +cmpcat [] = Just EQ -- empty things are equal + +cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering) +cmpTree x y = do x' <- expand x + y' <- expand y + con <- contentsEq x' y' + return $ cmpcat [cmpShape x' y', con] + where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) + cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a + b' <- readBlob b + return $ Just (compare a' b') + cmp _ _ _ = return (Just EQ) -- neutral + +cmpShape :: Tree m -> Tree m -> Maybe Ordering +cmpShape t r = cmpcat $ zipTrees cmp t r + where cmp _ (Just a) (Just b) = a `item` b + cmp _ Nothing (Just _) = Just LT + cmp _ (Just _) Nothing = Just GT + cmp _ Nothing Nothing = Just EQ + item (File _) (File _) = Just EQ + item (SubTree s) (SubTree p) = s `cmpShape` p + item _ _ = Nothing + +cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) +cmpExpandedShape a b = do x <- expand a + y <- expand b + return $ x `cmpShape` y + +nondarcs :: AnchoredPath -> TreeItem m -> Bool +nondarcs (AnchoredPath (x:_)) _ | x == makeName "_darcs" = False + | otherwise = True +nondarcs (AnchoredPath []) _ = True + +readDarcsPristine :: FilePath -> IO (Tree IO) +readDarcsPristine dir = do + let darcs = dir "_darcs" + h_inventory = darcs "hashed_inventory" + repo <- doesDirectoryExist darcs + unless repo $ fail $ "Not a darcs repository: " ++ dir + isHashed <- doesFileExist h_inventory + if isHashed + then do inv <- BC.readFile h_inventory + let thelines = BC.split '\n' inv + case thelines of + [] -> return emptyTree + (pris_line:_) -> do + let thehash = decodeDarcsHash $ BC.drop 9 pris_line + thesize = decodeDarcsSize $ BC.drop 9 pris_line + when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line + readDarcsHashed (darcs "pristine.hashed") (thesize, thehash) + 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!" + +extractRepoAndRun :: IO a -> IO a +extractRepoAndRun action = do + zipFile <- toArchive . BLC.fromStrict <$> BC.readFile "harness/hstestdata.zip" + withTempDir "_test_playground" $ \_ -> do + extractFilesFromArchive [] zipFile + action diff --git a/harness/Darcs/Test/Misc.hs b/harness/Darcs/Test/Misc.hs --- a/harness/Darcs/Test/Misc.hs +++ b/harness/Darcs/Test/Misc.hs @@ -15,33 +15,45 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Test.Misc ( testSuite ) where -import Darcs.Util.ByteString ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex ) +import Darcs.Util.ByteString + ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex + , propHexConversion + , prop_unlinesPS_linesPS_left_inverse + , prop_linesPS_length + , prop_unlinesPS_length + , spec_betweenLinesPS + , betweenLinesPS + ) import Darcs.Util.Diff.Myers ( shiftBoundaries ) -import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -import qualified Data.ByteString as B ( concat, empty ) +import Darcs.Test.Misc.CommandLine ( commandLineTestSuite ) +import qualified Darcs.Test.Misc.Encoding as Encoding + +import qualified Data.ByteString.Char8 as BC ( unpack, pack, last ) +import qualified Data.ByteString as B ( ByteString, pack, empty, null ) +import Data.Char ( ord ) import Data.Array.Base import Control.Monad.ST import Test.HUnit ( assertBool, assertEqual, assertFailure ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework.Providers.HUnit ( testCase ) import Test.Framework ( Test, testGroup ) +import Test.QuickCheck testSuite :: Test testSuite = testGroup "" [ byteStringUtilsTestSuite , lcsTestSuite + , commandLineTestSuite + , Encoding.testSuite ] -- ---------------------------------------------------------------------- -- * Darcs.Util.ByteString --- Here are a few quick tests of the shiftBoundaries function. -- ---------------------------------------------------------------------- byteStringUtilsTestSuite :: Test @@ -51,16 +63,27 @@ , testCase "Checking that hex packing and unpacking preserves 'hello world'" (assertEqual "" (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")) "hello world") - , testProperty "Checking that B.concat works" propConcatPS , testProperty "Checking that hex conversion works" propHexConversion + , testProperty "unlinesPS is left inverse of linesPS" prop_unlinesPS_linesPS_left_inverse + , testProperty "linesPS length property" prop_linesPS_length + , testProperty "unlinesPS length property" prop_unlinesPS_length + , testProperty "betweenLinesPS behaves like its spec" prop_betweenLinesPS ] -propHexConversion :: String -> Bool -propHexConversion s = - fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s +-- tweak the probabilities in favor of newline characters +instance Arbitrary B.ByteString where + arbitrary = fmap B.pack $ listOf $ frequency + [ (1, return (fromIntegral (ord '\n'))) + , (4, arbitrary) + ] -propConcatPS :: [String] -> Bool -propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) +-- betweenLinesPS and spec_betweenLinesPS are equivalent only +-- if certain conditions are met +prop_betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString -> Property +prop_betweenLinesPS start end ps = + not (B.null start) && not (B.null end) && + (B.null ps || BC.last ps == '\n') ==> + betweenLinesPS start end ps == spec_betweenLinesPS start end ps -- ---------------------------------------------------------------------- -- * LCS diff --git a/harness/Darcs/Test/Misc/CommandLine.hs b/harness/Darcs/Test/Misc/CommandLine.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Misc/CommandLine.hs @@ -0,0 +1,41 @@ +module Darcs.Test.Misc.CommandLine + ( + commandLineTestSuite + ) where + +import Test.HUnit ( assertEqual, assertFailure ) +import Test.Framework.Providers.HUnit ( testCase ) +import Test.Framework ( Test, testGroup ) + +import Darcs.Util.CommandLine ( parseCmd ) + +formatTable :: [(Char, String)] +formatTable = [('s',""), + ('a',""), + ('d',"date") + ] + +testParser :: (String, ([String], Bool)) -> Test +testParser (s, ok) = + testCase ("Parse: " ++ show s) $ + case parseCmd formatTable s of + Left e -> assertFailure $ "Parser failed with: " ++ show e + Right res -> assertEqual ("Parsing: " ++ show s) ok res + +testCases :: [(String, ([String], Bool))] +testCases = [("a b",(["a","b"], False)), + ("a b %<",(["a","b"], True)), + ("a b %< ",(["a","b"], True)), + ("\"arg0 contains spaces \\\"quotes\\\"\" b", + (["arg0 contains spaces \"quotes\"","b"],False)), + ("a %s %<",(["a",""], True)), + ("\"%d\"", (["date"], False)), + ("\"d %d\"", (["d date"], False)), + ("\\\a", (["\\\a"], False)), + ("\"\\\a\"", (["\a"], False)), + ("\"/foo:%d\"", (["/foo:date"], False)) + ] + +commandLineTestSuite :: Test +commandLineTestSuite = + testGroup "Darcs.Util.CommandLine" $ map testParser testCases diff --git a/harness/Darcs/Test/Misc/Encoding.hs b/harness/Darcs/Test/Misc/Encoding.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Misc/Encoding.hs @@ -0,0 +1,36 @@ +module Darcs.Test.Misc.Encoding ( testSuite ) where + +import qualified Data.ByteString as B +import Control.Monad +import Data.Word +import System.IO.Unsafe + +import Darcs.Util.Encoding + +import Test.Framework ( Test, testGroup ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.QuickCheck + +decodeThenEncode :: B.ByteString -> B.ByteString +decodeThenEncode = unsafePerformIO . (decode >=> encode) + +testSuite :: Test +testSuite = testGroup "Darcs.Util.Encoding" + [ testProperty "decode then encode roundtrips" propDecodeThenEncodeRoundTrip + ] + +-- could use the bytestring-arbitrary package, +-- but the shrinking isn't as effective as 'shrinkList shrink' +newtype MyByteString = MBS { _mbsBytes :: [Word8] } + deriving Show + +instance Arbitrary MyByteString where + arbitrary = MBS <$> sized (\n -> vectorOf (100*n) arbitrary) + shrink (MBS ws) = MBS <$> shrinkList shrink ws + +toBS :: MyByteString -> B.ByteString +toBS (MBS ws) = B.pack ws + +propDecodeThenEncodeRoundTrip :: MyByteString -> Bool +propDecodeThenEncodeRoundTrip mbs = + let bstr = toBS mbs in decodeThenEncode bstr == bstr diff --git a/harness/Darcs/Test/Patch.hs b/harness/Darcs/Test/Patch.hs --- a/harness/Darcs/Test/Patch.hs +++ b/harness/Darcs/Test/Patch.hs @@ -1,8 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, ImpredicativeTypes #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AllowAmbiguousTypes #-} -#endif +{-# LANGUAGE AllowAmbiguousTypes #-} -- Copyright (C) 2002-2005,2007 David Roundy -- -- This program is free software; you can redistribute it and/or modify @@ -35,19 +31,21 @@ import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed -import Darcs.Patch.Witnesses.Eq ( MyEq, unsafeCompare ) +import Darcs.Patch.Witnesses.Eq ( Eq2, unsafeCompare ) import Darcs.Patch.Witnesses.Show -import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf, PrimPatchBase ) -import qualified Darcs.Patch.Prim.V1 as V1 ( Prim ) +import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf ) import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Patch.V1 as V1 ( RepoPatchV1 ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim ) import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 ) -import Darcs.Patch.Patchy ( Commute(..), Patchy ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Merge( Merge ) import Darcs.Patch.Show ( ShowPatchBasic ) -import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.Apply( Apply, ApplyState ) import Darcs.Test.Patch.Arbitrary.Generic import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1 @@ -76,15 +74,16 @@ import qualified Darcs.Test.Patch.WSub as WSub -type instance ModelOf (FL prim) = ModelOf prim +type Prim1 = V1.Prim +type Prim2 = V2.Prim -type TestGenerator thing gen = (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t))) -type TestCondition thing = (forall wYy wZz . thing wYy wZz -> Bool) -type TestCheck thing t = (forall wYy wZz . thing wYy wZz -> t) +newtype TestGenerator thing gen = TestGenerator (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t))) +newtype TestCondition thing = TestCondition (forall wYy wZz . thing wYy wZz -> Bool) +newtype TestCheck thing t = TestCheck (forall wYy wZz . thing wYy wZz -> t) -- arbitraryThing :: (forall wXx wYy . thing wXx wYy -> t) -> (thing wA wB -> t) arbitraryThing :: x -> TestGenerator thing (thing x) -arbitraryThing _ f p = f p +arbitraryThing _ = TestGenerator (\f p -> f p) -- | Run a test function on a set of data, using HUnit. The test function should -- return @Nothing@ upon success and a @Just x@ upon failure. @@ -123,7 +122,7 @@ , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL , testCases "FL prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutablesFL , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL - , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(V1.Prim WSub.:> V1.Prim) wX wY]) + , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(Prim2 WSub.:> Prim2) wX wY]) , testCases "read and show work on Prim" PropU.show_read ExU.primPatches , testCases "read and show work on RepoPatchV2" PropU.show_read ExU.repov2Patches , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.repov2PatchLoopExamples @@ -140,27 +139,16 @@ , testCases "V2 partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.repov2NonduplicateTriples ] -instance PrimPatch prim => Check (RepoPatchV2 prim) where - checkPatch p = return $ isNothing $ isConsistent p - -instance Check FileUUID.Prim where - checkPatch _ = return True -- XXX - -commuteRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY) -commuteRepoPatchV2s = commute - qc_prim :: forall prim wX wY wA model. (PrimPatch prim, ArbitraryPrim prim, Show2 prim , model ~ ModelOf prim, RepoModel model , RepoState model ~ ApplyState (PrimOf prim) , Show1 (ModelOf prim) - , Check prim, PrimPatchBase prim, PrimOf prim ~ prim + , Check prim, PrimOf prim ~ prim , FromPrim prim , MightBeEmptyHunk prim , MightHaveDuplicate prim , Show1 (prim wA) - , Show1 ((prim :> prim) wA) - , Show1 (WithState model prim wA) , Arbitrary (Sealed ((prim :> prim) wA)) , Arbitrary (Sealed ((prim :> prim :> prim) wA)) , Arbitrary (Sealed (prim wA)) @@ -195,12 +183,18 @@ ] where arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator +consistentV2 :: RepoPatchV2 Prim2 wX wY -> TestResult +consistentV2 = fromMaybe . isConsistent + +commuteRepoPatchV2s :: (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY -> Maybe ((RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY) +commuteRepoPatchV2s = commute + qc_V2P1 :: [Test] qc_V2P1 = [ testProperty "tree flattenings are consistent... " - (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf V1.Prim) (Tree V1.Prim)) -> Bool) + (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf Prim2) (Tree Prim2)) -> Bool) , testProperty "with quickcheck that RepoPatchV2 patches are consistent... " - (unseal $ P1.patchFromTree $ fromMaybe . isConsistent) + (unseal $ P1.patchFromTree $ consistentV2) -- permutivity ---------------------------------------------------------------------------- , testConditional "permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) @@ -214,7 +208,7 @@ ] qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim), - Check (RepoPatchV2 prim), ArbitraryPrim prim, Show2 prim, + ArbitraryPrim prim, Show2 prim, RepoState (ModelOf prim) ~ ApplyState prim) => prim wXx wYy -> [Test] qc_V2 _ = @@ -228,11 +222,11 @@ -> Maybe (Tree (RepoPatchV2 prim) wX))) ] ++ concat - [ merge_properties (undefined :: RepoPatchV2 prim wX wY) "tree" mergePairFromTree - , merge_properties (undefined :: RepoPatchV2 prim wX wY) "twfp" mergePairFromTWFP - , pair_properties (undefined :: RepoPatchV2 prim wX wY) "tree" commutePairFromTree - , pair_properties (undefined :: RepoPatchV2 prim wX wY) "twfp" commutePairFromTWFP - , patch_properties (undefined :: RepoPatchV2 prim wX wY) "tree" patchFromTree + [ merge_properties (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator mergePairFromTree) + , merge_properties (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator mergePairFromTWFP) + , pair_properties (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator commutePairFromTree) + , pair_properties (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator commutePairFromTWFP) + , patch_properties (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator patchFromTree) ] properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) => @@ -241,86 +235,98 @@ -> String -> String -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)] -> [Test] -properties gen prefix genname tests = +properties (TestGenerator gen) prefix genname tests = [ cond name condition check | (name, condition, check) <- tests ] where cond :: forall testable. Testable testable => String -> TestCondition thing -> TestCheck thing testable -> Test - cond t c p = + cond t (TestCondition c) (TestCheck p) = testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ gen c) (unseal $ gen p) type PropList what gen = String -> TestGenerator what gen -> [Test] pair_properties :: forall p gen x y - . ( Show1 gen, Arbitrary (Sealed gen), Patchy p, MightHaveDuplicate p - , ShowPatchBasic p, MyEq p + . ( Show1 gen, Arbitrary (Sealed gen), MightHaveDuplicate p + , Commute p, Invert p, ShowPatchBasic p, Eq2 p ) => p x y -> PropList (p :> p) gen pair_properties _ genname gen = properties gen "commute" genname - [ ("recommute" , const True , PropG.recommute commute ) - , ("nontrivial recommute" , nontrivialCommute, PropG.recommute commute ) - , ("inverses commute" , const True , PropG.commuteInverses commute ) - , ("nontrivial inverses" , nontrivialCommute, PropG.commuteInverses commute ) - , ("inverse composition" , const True , PropG.inverseComposition ) + [ ("recommute" , TestCondition (const True) , TestCheck (PropG.recommute commute) ) + , ("nontrivial recommute" , TestCondition nontrivialCommute, TestCheck (PropG.recommute commute) ) + , ("inverses commute" , TestCondition (const True) , TestCheck (PropG.commuteInverses commute) ) + , ("nontrivial inverses" , TestCondition nontrivialCommute, TestCheck (PropG.commuteInverses commute) ) + , ("inverse composition" , TestCondition (const True) , TestCheck PropG.inverseComposition ) ] coalesce_properties :: forall p gen x y - . ( Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p + . ( Show1 gen, Arbitrary (Sealed gen), PrimPatch p , ArbitraryPrim p, MightBeEmptyHunk p ) => p x y -> PropList (p :> p :> p) gen coalesce_properties p genname gen = properties gen "commute" genname - (if runCoalesceTests p then [ ("coalesce commutes with commute", const True, PropG.coalesceCommute coalesce) ] else []) + (if runCoalesceTests p then [ ("coalesce commutes with commute", TestCondition (const True), TestCheck (PropG.coalesceCommute coalesce)) ] else []) -- The following properties do not hold for "RepoPatchV2" patches (conflictors and -- duplicates, specifically) . nonrpv2_commute_properties :: forall p gen x y - . (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic p, MyEq p) + . (Show1 gen, Arbitrary (Sealed gen), Commute p, Invert p, ShowPatchBasic p, Eq2 p) => p x y -> PropList (p :> p) gen nonrpv2_commute_properties _ genname gen = properties gen "commute" genname - [ ("patch & inverse commute", const True , PropG.patchAndInverseCommute commute) - , ("patch & inverse commute", nontrivialCommute, PropG.patchAndInverseCommute commute) + [ ("patch & inverse commute", TestCondition (const True) , TestCheck (PropG.patchAndInverseCommute commute)) + , ("patch & inverse commute", TestCondition nontrivialCommute, TestCheck (PropG.patchAndInverseCommute commute)) ] -patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, MyEq p) +patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Invert p, Apply p, Eq2 p) => p x y -> PropList p gen patch_properties _ genname gen = properties gen "patch" genname - [ ("inverse . inverse is id" , const True , PropG.invertSymmetry) + [ ("inverse . inverse is id" , TestCondition (const True) , TestCheck PropG.invertSymmetry) ] patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), - Patchy p, ShowPatchBasic p, + Invert p, Apply p, ShowPatchBasic p, RepoModel (ModelOf (PrimOf p)), RepoState (ModelOf (PrimOf p)) ~ ApplyState p) => p x y -> PropList (WithState (ModelOf (PrimOf p)) p) gen patch_repo_properties _ genname gen = properties gen "patch/repo" genname - [ ("invert rollback" , const True , PropG.invertRollback) + [ ("invert rollback" , TestCondition (const True) , TestCheck PropG.invertRollback) ] -pair_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, - MightBeEmptyHunk p, - RepoModel (ModelOf p), - RepoState (ModelOf p) ~ ApplyState p) - => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen +pair_repo_properties + :: forall p gen x y. + ( Show1 gen + , Arbitrary (Sealed gen) + , Commute p + , Apply p + , ShowPatchBasic p + , MightBeEmptyHunk p + , RepoModel (ModelOf p) + , RepoState (ModelOf p) ~ ApplyState p + ) + => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen pair_repo_properties _ genname gen = - properties gen "patch/repo" genname - [ ("commute is effect preserving" , const True , PropG.effectPreserving commute ) - ] + properties + gen + "patch/repo" + genname + [ ( "commute is effect preserving" + , TestCondition (const True) + , TestCheck (PropG.effectPreserving commute)) + ] merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen) - , Patchy p, MyEq p, Merge p, ShowPatchBasic p + , Invert p, Eq2 p, Merge p, ShowPatchBasic p , MightHaveDuplicate p, Show2 p, Check p) => p x y -> PropList (p :\/: p) gen merge_properties _ genname gen = properties gen "merge" genname - [ ("merge either way" , const True , PropG.mergeEitherWay ) - , ("merge either way valid" , const True , Prop1.tMergeEitherWayValid) - , ("nontrivial merge either way", nontrivialMerge, PropG.mergeEitherWay ) - , ("merge commute" , const True , PropG.mergeCommute ) + [ ("merge either way" , TestCondition (const True) , TestCheck PropG.mergeEitherWay ) + , ("merge either way valid" , TestCondition (const True) , TestCheck Prop1.tMergeEitherWayValid) + , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay ) + , ("merge commute" , TestCondition (const True) , TestCheck PropG.mergeCommute ) ] qc_V1P1 :: [Test] @@ -357,10 +363,10 @@ ] -- the following properties are disabled, because they routinely lead to -- exponential cases, making the tests run for ever and ever; nevertheless, -- we would expect them to hold - {- ++ merge_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "tree" mergePairFromTree - ++ merge_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "twfp" mergePairFromTWFP - ++ commute_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "tree" commutePairFromTree - ++ commute_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "twfp" commutePairFromTWFP -} + {- ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" mergePairFromTree + ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" mergePairFromTWFP + ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" commutePairFromTree + ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" commutePairFromTWFP -} -- tests (either QuickCheck or Unit) that should be run on any type of patch general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType rt p -> [Test] @@ -370,16 +376,22 @@ -- | This is the big list of tests that will be run using testrunner. testSuite :: [Test] -testSuite = [ testGroup "Darcs.Patch.Prim.V1" $ qc_prim (undefined :: V1.Prim wX wY) - , testGroup "Darcs.Patch.V1 (using Prim.V1)" $ - unit_V1P1 ++ qc_V1P1 ++ general_patchTests (PatchType :: PatchType rt (V1.RepoPatchV1 V1.Prim)) - , testGroup "Darcs.Patch.V2 (using Prim.V1)" $ - unit_V2P1 ++ qc_V2 (undefined :: V1.Prim wX wY) ++ qc_V2P1 ++ - general_patchTests (PatchType :: PatchType rt (RepoPatchV2 V1.Prim)) - -- , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY) - , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $ - qc_V2 (undefined :: FileUUID.Prim wX wY) ++ - general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim)) - , Darcs.Test.Patch.Info.testSuite - , Darcs.Test.Patch.Selection.testSuite - ] +testSuite = + [ testGroup "Darcs.Patch.Prim.V1 for V1" $ qc_prim (undefined :: Prim1 wX wY) + -- testing both Prim1 and Prim2 here is redundant, since they differ + -- only in their read/show behavior, which is not tested in qc_prim; + -- we still include them because such tests might be added in the future + , testGroup "Darcs.Patch.Prim.V1 for V2" $ qc_prim (undefined :: Prim2 wX wY) + , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY) + , testGroup "Darcs.Patch.V1 (using Prim.V1)" $ + unit_V1P1 ++ qc_V1P1 ++ + general_patchTests (PatchType :: PatchType rt (V1.RepoPatchV1 Prim1)) + , testGroup "Darcs.Patch.V2 (using Prim.V1)" $ + unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) ++ qc_V2P1 ++ + general_patchTests (PatchType :: PatchType rt (RepoPatchV2 Prim2)) + , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $ + qc_V2 (undefined :: FileUUID.Prim wX wY) ++ + general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim)) + , Darcs.Test.Patch.Info.testSuite + , Darcs.Test.Patch.Selection.testSuite + ] diff --git a/harness/Darcs/Test/Patch/Arbitrary/Generic.hs b/harness/Darcs/Test/Patch/Arbitrary/Generic.hs --- a/harness/Darcs/Test/Patch/Arbitrary/Generic.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/Generic.hs @@ -1,7 +1,5 @@ -{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-} -{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, +{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, ViewPatterns #-} - module Darcs.Test.Patch.Arbitrary.Generic ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim(..), NullPatch(..), RepoModel(..) , MightBeEmptyHunk(..), MightHaveDuplicate(..) @@ -24,9 +22,9 @@ import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Patchy ( Invert(..), Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) ) -import Darcs.Patch.Prim.V1 () import Darcs.Patch.V2 ( RepoPatchV2 ) -- XXX this is more or less a hack --import Darcs.ColorPrinter ( errorDoc ) --import Darcs.ColorPrinter ( traceDoc ) diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs @@ -1,8 +1,9 @@ --- TODO: Remove these warning disabling flags... -{-# OPTIONS_GHC -w #-} -{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} module Darcs.Test.Patch.Arbitrary.PrimFileUUID where +import Prelude () +import Darcs.Prelude + import qualified Darcs.Test.Patch.Arbitrary.Generic as T ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP , mergePairFromTree, mergePairFromTWFP @@ -18,24 +19,20 @@ import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Prim.FileUUID () -import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location, Hunk(..), UUID(..) ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location(..), Hunk(..), UUID(..) ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Test.Patch.FileUUIDModel -import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf ) +import Darcs.Test.Util.QuickCheck ( notIn, maybeOf ) -import Darcs.UI.Commands.Replace ( defaultToks ) import Darcs.Patch.Prim import Control.Applicative ( (<$>) ) -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString as BS +import qualified Data.ByteString as B import Data.Maybe ( isJust ) import qualified Data.Map as M import Darcs.Util.Hash( Hash(..) ) -#include "impossible.h" - patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t patchFromTree = T.patchFromTree @@ -59,18 +56,15 @@ runCoalesceTests _ = False hasPrimConstruct _ = False -hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq -hunkIdentity _ = NotEq +instance MightBeEmptyHunk Prim +instance MightHaveDuplicate Prim instance NullPatch Prim where - nullPatch (BinaryHunk _ x) = hunkIdentity x - nullPatch (TextHunk _ x) = hunkIdentity x + nullPatch Identity = IsEq + nullPatch (Hunk _ (H _ old new)) + | old == new = unsafeCoerceP IsEq nullPatch _ = NotEq -instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where - arbitrary = do repo <- ourSmallRepo - liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo - -- instance Show1 (TreeWithFlattenPos Prim) where -- showDict1 = ShowDictClass @@ -81,93 +75,83 @@ ---------------------------------------------------------------------- -- * QuickCheck generators -aHunk :: forall wX wY . BS.ByteString -> Gen (Hunk wX wY) -aHunk content - = sized $ \n -> - do pos <- choose (0, BS.length content) - let prefixLen = pos - restLen = BS.length content - prefixLen - oldLen <- frequency - [ (75, choose (0, min restLen n)) - , (25, choose (0, min 10 restLen)) - ] - let nonempty x = if oldLen /= 0 then x else 0 - newLen <- frequency - [ ( 54, choose (1,min 1 n) ) - , ( nonempty 42, choose (1,min 1 oldLen) ) - , ( nonempty 2, return oldLen ) - , ( nonempty 2, return 0 ) - ] - new <- BS.concat <$> vectorOf newLen aLine - let old = BS.take oldLen $ BS.drop prefixLen $ content - return $ Hunk pos old new +aHunk :: B.ByteString -> Gen (Hunk wX wY) +aHunk content = do + pos <- choose (0, B.length content) + oldLen <- choose (0, B.length content - pos) + new <- scale (`div` 8) aContent + let old = B.take oldLen $ B.drop pos $ content + return $ H pos old new -aTextHunk :: forall wX wY . (UUID, Object Fail) -> Gen (Prim wX wY) +aTextHunk :: (UUID, Object Fail) -> Gen (Prim wX wY) aTextHunk (uuid, (Blob text _)) = - do hunk <- aHunk (unFail text) - return $ TextHunk uuid hunk + do h <- aHunk (unFail text) + return $ Hunk uuid h +aTextHunk _ = impossible -aManifest :: forall wX wY . UUID -> Location -> Object Fail -> Gen (Prim wX wY) -aManifest uuid loc (Directory dir) = - do newFilename <- aFilename `notIn` (M.keys dir) - return $ Manifest uuid loc +aManifest :: UUID -> (UUID, Object Fail) -> Gen (Prim wX wY) +aManifest uuid (dirId, Directory dir) = + do filename <- aFilename `notIn` (M.keys dir) + return $ Manifest uuid (L dirId filename) +aManifest _ _ = impossible -aDemanifest :: forall wX wY . UUID -> Location -> Gen (Prim wX wY) +aDemanifest :: UUID -> Location -> Gen (Prim wX wY) aDemanifest uuid loc = return $ Demanifest uuid loc -- | Generates any type of 'Prim' patch, except binary and setpref patches. -aPrim :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY) +aPrim :: FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY) aPrim repo - = do mbFile <- maybeOf repoFiles - mbDir <- maybeOf repoDirs - mbExisting <- maybeOf $ repoObjects repo - mbManifested <- maybeOf manifested - fresh <- anUUID - filename <- aFilename - dir <- elements (rootDir:repoDirs) - mbOtherDir <- maybeOf repoDirs - let whenfile x = if isJust mbFile then x else 0 - whendir x = if isJust mbDir then x else 0 - whenexisting x = if isJust mbExisting then x else 0 - whenmanifested x = if isJust mbManifested then x else 0 + = do mbFile <- maybeOf repoFiles -- some file, not necessarily manifested + dir <- elements repoDirs -- some directory, not necessarily manifested + -- note, the root directory always exists and is never manifested nor demanifested + mbDemanifested <- maybeOf notManifested -- something manifested + mbManifested <- maybeOf manifested -- something not manifested + fresh <- anUUID `notIn` repoIds repo -- a fresh uuid + let whenjust m x = if isJust m then x else 0 + whenfile = whenjust mbFile + whendemanifested = whenjust mbDemanifested + whenmanifested = whenjust mbManifested patch <- frequency - [ ( whenfile 12, aTextHunk $ fromJust mbFile ) - , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing - , ( whenexisting (whendir 2), -- manifest an existing object - aManifest (fst $ fromJust mbExisting) - (fst $ fromJust mbDir, filename) - (snd $ fromJust mbDir)) - , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested ) - -- TODO: demanifest + [ ( whenfile 12, aTextHunk $ fromJust mbFile ) -- edit an existing file + , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- edit a new file + , ( whendemanifested 2 -- manifest an existing object + , aManifest (fromJust mbDemanifested) dir + ) + , ( whenmanifested 2 + , uncurry aDemanifest $ fromJust mbManifested + ) ] let repo' = unFail $ repoApply repo patch return $ WithEndState patch repo' where - manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs - , (name, id) <- M.toList dir ] - repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ] - repoDirs = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ] - rootDir = (UUID "ROOT", root repo) + manifested = [ (uuid, (L dirid name)) | (dirid, Directory dir) <- repoDirs + , (name, uuid) <- M.toList dir ] + notManifested = [ uuid | (uuid, _) <- nonRootObjects + , not (uuid `elem` map fst manifested) ] + repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ] + repoDirs = [ (uuid, Directory x) | (uuid, Directory x) <- repoObjects repo ] + nonRootObjects = filter notRoot $ repoObjects repo where + notRoot (uuid, _) = uuid == rootId ---------------------------------------------------------------------- -- *** Pairs of primitive patches -- Try to generate commutable pairs of hunks -hunkPair :: forall wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY) +hunkPair :: (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY) hunkPair (uuid, (Blob file _)) = - do h1@(Hunk l1 old1 new1) <- aHunk (unFail file) + do h1@(H off1 old1 new1) <- aHunk (unFail file) (delta, content') <- selectChunk h1 (unFail file) - Hunk l2' old2 new2 <- aHunk content' - let l2 = l2'+delta - return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2)) + H off2' old2 new2 <- aHunk content' + let off2 = off2' + delta + return (Hunk uuid (H off1 old1 new1) :> Hunk uuid (H off2 old2 new2)) where - selectChunk (Hunk l old new) content = elements [prefix, suffix] - where start = l - 1 - prefix = (0, BS.take start content) - suffix = (start + BS.length new, BS.drop (start + BS.length old) content) - selectChunk _ _ = impossible + selectChunk (H off old new) content = elements [prefix, suffix] + where prefix = (0, B.take off content) + suffix = (off + B.length new, B.drop (off + B.length old) content) +hunkPair _ = impossible -aPrimPair :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY) +aPrimPair :: FileUUIDModel wX + -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY) aPrimPair repo = do mbFile <- maybeOf repoFiles frequency @@ -183,7 +167,7 @@ ) ] where - repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ] + repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ] ---------------------------------------------------------------------- -- Arbitrary instances @@ -193,6 +177,11 @@ instance ArbitraryState FileUUIDModel Prim where arbitraryState s = seal <$> aPrim s + + +instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where + arbitrary = do repo <- ourSmallRepo + liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo instance Arbitrary (Sealed2 Prim) where diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Darcs.Test.Patch.Arbitrary.PrimV1 where import qualified Darcs.Test.Patch.Arbitrary.Generic as T @@ -20,39 +19,44 @@ import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered -import Darcs.Patch.Prim.V1 () -import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), Prim( FP ), isIdentity ) +import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), isIdentity ) +import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) ) import Darcs.Test.Patch.V1Model import Darcs.Util.Path +import qualified Darcs.Util.Tree as UT ( Tree ) import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf ) import Darcs.UI.Commands.Replace ( defaultToks ) import Darcs.Patch.Prim +import Darcs.Patch.Apply ( ApplyState ) import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isJust ) -#include "impossible.h" +type Prim1 = V1.Prim +type Prim2 = V2.Prim -patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t +patchFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t patchFromTree = T.patchFromTree -mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t +mergePairFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t mergePairFromTree = T.mergePairFromTree -mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) wX -> t +mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos prim) wX -> t mergePairFromTWFP = T.mergePairFromTWFP -commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) wX -> t +commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos prim) wX -> t commutePairFromTWFP = T.commutePairFromTWFP -commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t +commutePairFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t commutePairFromTree = T.commutePairFromTree -commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t +commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t commuteTripleFromTree = T.commuteTripleFromTree nonEmptyHunk :: (IsHunk p) => p wX wY -> Bool @@ -69,33 +73,49 @@ nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) wX wY -> Bool nonEmptyHunksFLPair (ps :> qs) = allFL nonEmptyHunk ps && allFL nonEmptyHunk qs -type instance ModelOf Prim = V1Model -instance ArbitraryPrim Prim +type instance ModelOf Prim1 = V1Model +type instance ModelOf Prim2 = V1Model +instance ArbitraryPrim Prim1 +instance ArbitraryPrim Prim2 -instance NullPatch Prim where - nullPatch (FP _ fp) = nullPatch fp - nullPatch p | IsEq <- isIdentity p = IsEq +instance NullPatch Prim2 where + nullPatch (V2.Prim (Prim.FP _ fp)) = nullPatch fp + nullPatch p | IsEq <- isIdentity (V2.unPrim p) = IsEq nullPatch _ = NotEq +instance NullPatch Prim1 where + nullPatch (V1.Prim (Prim.FP _ fp)) = nullPatch fp + nullPatch p | IsEq <- isIdentity (V1.unPrim p) = IsEq + nullPatch _ = NotEq + instance NullPatch FilePatchType where nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe? nullPatch _ = NotEq -instance MightBeEmptyHunk Prim where - isEmptyHunk (FP _ (Hunk _ [] [])) = True +instance MightBeEmptyHunk Prim1 where + isEmptyHunk (V1.Prim (Prim.FP _ (Hunk _ [] []))) = True isEmptyHunk _ = False -instance MightHaveDuplicate Prim +instance MightBeEmptyHunk Prim2 where + isEmptyHunk (V2.Prim (Prim.FP _ (Hunk _ [] []))) = True + isEmptyHunk _ = False -instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where +instance MightHaveDuplicate Prim1 +instance MightHaveDuplicate Prim2 + +instance Arbitrary (Sealed2 (FL (WithState V1Model Prim1))) where arbitrary = do repo <- ourSmallRepo liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo +instance Arbitrary (Sealed2 (FL (WithState V1Model Prim2))) where + arbitrary = do repo <- ourSmallRepo + liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo + -- instance Show1 (TreeWithFlattenPos Prim) where -- showDict1 = ShowDictClass -- WithState and propFail are handy for debugging arbitrary code -propFail :: Int -> Tree Prim wX -> Bool +propFail :: Int -> Tree prim wX -> Bool propFail n xs = sizeTree xs < n ---------------------------------------------------------------------- @@ -153,21 +173,21 @@ ---------------------------------------------------------------------- -- ** Prim generators -aHunkP :: forall wX wY . (AnchoredPath,File) -> Gen (Prim wX wY) +aHunkP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY) aHunkP (path,file) = do Hunk pos old new <- aHunk content return $ hunk (ap2fp path) pos old new where content = fileContent file -aTokReplaceP :: forall wX wY . (AnchoredPath,File) -> Gen (Prim wX wY) +aTokReplaceP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY) aTokReplaceP (path,file) = do TokReplace tokchars old new <- aTokReplace content return $ tokreplace (ap2fp path) tokchars old new where content = fileContent file -anAddFileP :: forall wX wY . (AnchoredPath,Dir) -> Gen (Prim wX wY) +anAddFileP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY) anAddFileP (path,dir) = do newFilename <- aFilename `notIn` existing let newPath = path `appendPath` newFilename @@ -175,11 +195,11 @@ where existing = map fst $ filterFiles $ dirContent dir -aRmFileP :: forall wX wY . AnchoredPath -- ^ Path of an empty file - -> Prim wX wY +aRmFileP :: forall prim wX wY . PrimPatch prim => AnchoredPath -- ^ Path of an empty file + -> prim wX wY aRmFileP path = rmfile (ap2fp path) -anAddDirP :: forall wX wY . (AnchoredPath,Dir) -> Gen (Prim wX wY) +anAddDirP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY) anAddDirP (path,dir) = do newDirname <- aDirname `notIn` existing let newPath = path `appendPath` newDirname @@ -187,11 +207,11 @@ where existing = map fst $ filterDirs $ dirContent dir -aRmDirP :: forall wX wY . AnchoredPath -- ^ Path of an empty directory - -> Prim wX wY +aRmDirP :: forall prim wX wY . PrimPatch prim => AnchoredPath -- ^ Path of an empty directory + -> prim wX wY aRmDirP path = rmdir (ap2fp path) -aMoveP :: forall wX wY . Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (Prim wX wY) +aMoveP :: forall prim wX wY . PrimPatch prim => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY) aMoveP nameGen oldPath (dirPath,dir) = do newName <- nameGen `notIn` existing let newPath = dirPath `appendPath` newName @@ -199,8 +219,9 @@ where existing = map fst $ dirContent dir --- | Generates any type of 'Prim' patch, except binary and setpref patches. -aPrim :: forall wX wY . V1Model wX -> Gen (WithEndState V1Model (Prim wX) wY) +-- | Generates any type of 'prim' patch, except binary and setpref patches. +aPrim :: forall prim wX wY . (PrimPatch prim, ApplyState prim ~ RepoState V1Model) + => V1Model wX -> Gen (WithEndState V1Model (prim wX) wY) aPrim repo = do mbFile <- maybeOf repoFiles mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles @@ -266,7 +287,7 @@ -- *** Pairs of primitive patches -- Try to generate commutable pairs of hunks -hunkPairP :: forall wX wY . (AnchoredPath,File) -> Gen ((Prim :> Prim) wX wY) +hunkPairP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen ((prim :> prim) wX wY) hunkPairP (path,file) = do h1@(Hunk l1 old1 new1) <- aHunk content (delta, content') <- selectChunk h1 content @@ -284,7 +305,7 @@ suffix = (start + length new, drop (start + length old) content_) selectChunk _ _ = impossible -aPrimPair :: forall wX wY . V1Model wX -> Gen (WithEndState V1Model ((Prim :> Prim) wX) wY) +aPrimPair :: forall prim wX wY . (PrimPatch prim, ArbitraryState V1Model prim, ApplyState prim ~ RepoState V1Model) => V1Model wX -> Gen (WithEndState V1Model ((prim :> prim) wX) wY) aPrimPair repo = do mbFile <- maybeOf repoFiles frequency @@ -337,66 +358,143 @@ ourSmallRepo :: Gen (V1Model wX) ourSmallRepo = aSmallRepo -instance ArbitraryState V1Model Prim where +instance ArbitraryState V1Model Prim1 where arbitraryState s = seal <$> aPrim s +instance ArbitraryState V1Model Prim2 where + arbitraryState s = seal <$> aPrim s -instance Arbitrary (Sealed2 Prim) where + +instance Arbitrary (Sealed (Prim1 wA)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed (Prim2 wA)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 Prim1) where arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed2 (Prim :> Prim)) where +instance Arbitrary (Sealed2 Prim2) where + arbitrary = makeS2Gen ourSmallRepo + +arbitrarySeal2 :: (PrimPatch prim, ApplyState prim ~ UT.Tree, + ArbitraryState V1Model prim) + => Gen (Sealed2 (prim :> prim)) +arbitrarySeal2 = do + repo <- ourSmallRepo + WithEndState pp _ <- aPrimPair repo + return $ seal2 pp + +arbitrarySeal :: (PrimPatch prim, ApplyState prim ~ UT.Tree, + ArbitraryState V1Model prim) + => Gen (Sealed ((:>) prim prim wX)) +arbitrarySeal = do + repo <- ourSmallRepo + WithEndState pp _ <- aPrimPair repo + return $ seal pp + +instance Arbitrary (Sealed2 (Prim1 :> Prim1)) where + arbitrary = arbitrarySeal2 + +instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where + arbitrary = arbitrarySeal2 + +instance Arbitrary (Sealed ((Prim1 :> Prim1) wA)) where + arbitrary = arbitrarySeal + +instance Arbitrary (Sealed ((Prim2 :> Prim2) wA)) where + arbitrary = arbitrarySeal + +instance Arbitrary (Sealed2 (Prim1 :> Prim1 :> Prim1)) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed ((Prim1 :> Prim1 :> Prim1) a)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (FL Prim1)) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed ((FL Prim1) wA)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (FL Prim1 :> FL Prim1)) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed ((FL Prim1 :> FL Prim1) wA)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (WithState V1Model Prim1)) where + arbitrary = makeWS2Gen ourSmallRepo + +instance Arbitrary (Sealed (WithState V1Model Prim1 wA)) where + arbitrary = makeWSGen ourSmallRepo + +instance Arbitrary (Sealed (WithState V1Model (FL Prim1) wA)) where + arbitrary = makeWSGen ourSmallRepo + +instance Arbitrary (Sealed2 (WithState V1Model (Prim1 :> Prim1))) where arbitrary = do repo <- ourSmallRepo - WithEndState pp _ <- aPrimPair repo - return $ seal2 pp + WithEndState pp repo' <- aPrimPair repo + return $ seal2 $ WithState repo pp repo' -instance Arbitrary (Sealed ((Prim :> Prim) wA)) where +instance Arbitrary (Sealed (WithState V1Model (Prim1 :> Prim1) a)) where arbitrary = do repo <- ourSmallRepo - WithEndState pp _ <- aPrimPair repo - return $ seal pp + WithEndState pp repo' <- aPrimPair repo + return $ seal $ WithState repo pp repo' -instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where + +instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1))) where + arbitrary = makeWS2Gen ourSmallRepo + +instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1 :> FL Prim1))) where + arbitrary = makeWS2Gen ourSmallRepo + +instance Arbitrary (Sealed (WithState V1Model (FL Prim1 :> FL Prim1) a)) where + arbitrary = makeWSGen ourSmallRepo + +instance Arbitrary (Sealed2 (Prim2 :> Prim2 :> Prim2)) where arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where +instance Arbitrary (Sealed ((Prim2 :> Prim2 :> Prim2) a)) where arbitrary = makeSGen ourSmallRepo -instance Arbitrary (Sealed2 (FL Prim)) where +instance Arbitrary (Sealed2 (FL Prim2)) where arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed ((FL Prim) wA)) where +instance Arbitrary (Sealed ((FL Prim2) wA)) where arbitrary = makeSGen ourSmallRepo -instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where +instance Arbitrary (Sealed2 (FL Prim2 :> FL Prim2)) where arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where +instance Arbitrary (Sealed ((FL Prim2 :> FL Prim2) wA)) where arbitrary = makeSGen ourSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model Prim)) where +instance Arbitrary (Sealed2 (WithState V1Model Prim2)) where arbitrary = makeWS2Gen ourSmallRepo -instance Arbitrary (Sealed (WithState V1Model Prim wA)) where +instance Arbitrary (Sealed (WithState V1Model Prim2 wA)) where arbitrary = makeWSGen ourSmallRepo -instance Arbitrary (Sealed (WithState V1Model (FL Prim) wA)) where +instance Arbitrary (Sealed (WithState V1Model (FL Prim2) wA)) where arbitrary = makeWSGen ourSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model (Prim :> Prim))) where +instance Arbitrary (Sealed2 (WithState V1Model (Prim2 :> Prim2))) where arbitrary = do repo <- ourSmallRepo WithEndState pp repo' <- aPrimPair repo return $ seal2 $ WithState repo pp repo' -instance Arbitrary (Sealed (WithState V1Model (Prim :> Prim) a)) where +instance Arbitrary (Sealed (WithState V1Model (Prim2 :> Prim2) a)) where arbitrary = do repo <- ourSmallRepo WithEndState pp repo' <- aPrimPair repo return $ seal $ WithState repo pp repo' -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim))) where +instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2))) where arbitrary = makeWS2Gen ourSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim :> FL Prim))) where +instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2 :> FL Prim2))) where arbitrary = makeWS2Gen ourSmallRepo -instance Arbitrary (Sealed (WithState V1Model (FL Prim :> FL Prim) a)) where +instance Arbitrary (Sealed (WithState V1Model (FL Prim2 :> FL Prim2) a)) where arbitrary = makeWSGen ourSmallRepo diff --git a/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs --- a/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs @@ -15,20 +15,16 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} - +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Darcs.Test.Patch.Arbitrary.RepoPatchV1 () where import Prelude () import Darcs.Prelude -import System.IO.Unsafe ( unsafePerformIO ) import Test.QuickCheck import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM ) -import Darcs.Patch.Info ( PatchInfo, patchinfo ) import qualified Data.ByteString as B ( ByteString ) import qualified Data.ByteString.Char8 as BC ( pack ) @@ -36,8 +32,8 @@ hunk, tokreplace, binary, changepref, invert, merge ) import Darcs.Patch.V1 () -import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(..) ) -import Darcs.Patch.Prim.V1 () +import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..) ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) ) @@ -49,9 +45,10 @@ import Darcs.Test.Patch.Properties.Check( checkAPatch ) import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) -#include "impossible.h" +type Patch = RepoPatchV1 V1.Prim -type Patch = V1.RepoPatchV1 Prim +pp :: Prim wX wY -> Patch wX wY +pp = PP . V1.Prim class ArbitraryP p where arbitraryP :: Gen (Sealed (p wX)) @@ -112,7 +109,7 @@ instance ArbitraryP Prim where arbitraryP = onepatchgen -instance MightHaveDuplicate (V1.RepoPatchV1 prim) +instance MightHaveDuplicate (RepoPatchV1 prim) hunkgen :: Gen (Sealed (Prim wX)) hunkgen = do @@ -165,25 +162,18 @@ onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen] norecursgen :: Int -> Gen (Sealed (FL Patch wX)) -norecursgen 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen -norecursgen n = oneof [mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen,flatcompgen n] +norecursgen 0 = mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen +norecursgen n = oneof [mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen,flatcompgen n] arbpatch :: Int -> Gen (Sealed (FL Patch wX)) -arbpatch 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen -arbpatch n = frequency [(3,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen), +arbpatch 0 = mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen +arbpatch n = frequency [(3,mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen), (2,flatcompgen n), (0,rawMergeGen n), (0,mergegen n), - (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen) + (1,mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen) ] --- | Generate an arbitrary list of at least one element -unempty :: Arbitrary a => Gen [a] -unempty = do - a <- arbitrary - as <- arbitrary - return (a:as) - rawMergeGen :: Int -> Gen (Sealed (FL Patch wX)) rawMergeGen n = do Sealed p1 <- arbpatch len Sealed p2 <- arbpatch len @@ -208,16 +198,6 @@ else mergegen n where len = if n < 15 then n`div`3 else 3 -arbpi :: Gen PatchInfo -arbpi = do n <- unempty - a <- unempty - l <- unempty - d <- unempty - return $ unsafePerformIO $ patchinfo n d a l - -instance Arbitrary PatchInfo where - arbitrary = arbpi - instance Arbitrary B.ByteString where arbitrary = liftM BC.pack arbitrary @@ -225,7 +205,7 @@ flatlistgen 0 = return $ Sealed NilFL flatlistgen n = do Sealed x <- onepatchgen Sealed xs <- flatlistgen (n-1) - return (Sealed (V1.PP x :>: xs)) + return (Sealed (pp x :>: xs)) flatcompgen :: Int -> Gen (Sealed (FL Patch wX)) flatcompgen n = do diff --git a/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs --- a/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.RepoPatchV2 where import Darcs.Test.Patch.Arbitrary.Generic @@ -7,7 +6,7 @@ import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Patchy ( Patchy, Commute(..) ) +import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Prim ( PrimPatch, anIdentity ) import Darcs.Patch.V2 ( RepoPatchV2 ) import Darcs.Patch.V2.RepoPatch ( isDuplicate ) @@ -22,7 +21,7 @@ nontrivialRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool nontrivialRepoPatchV2s = nontrivialCommute -nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> Bool +nontrivialCommute :: (Commute p, Eq2 p) => (p :> p) wX wY -> Bool nontrivialCommute (x :> y) = case commute (x :> y) of Just (y' :> x') -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x) @@ -31,7 +30,7 @@ nontrivialMergerepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY -> Bool nontrivialMergerepoPatchV2s = nontrivialMerge -nontrivialMerge :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> Bool +nontrivialMerge :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool nontrivialMerge (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x) diff --git a/harness/Darcs/Test/Patch/Check.hs b/harness/Darcs/Test/Patch/Check.hs --- a/harness/Darcs/Test/Patch/Check.hs +++ b/harness/Darcs/Test/Patch/Check.hs @@ -15,7 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} module Darcs.Test.Patch.Check ( PatchCheck(), doCheck, fileExists, dirExists, removeFile, removeDir, createFile, createDir, insertLine, deleteLine, isValid, doVerboseCheck, @@ -23,6 +22,9 @@ checkMove, modifyFile, FileContents(..) ) where +import Prelude () +import Darcs.Prelude + import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString as B (ByteString) import Data.List ( isPrefixOf, inits ) @@ -32,8 +34,6 @@ import Data.Map ( Map ) import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null ) import System.FilePath ( joinPath, splitDirectories ) - -#include "impossible.h" -- | 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 diff --git a/harness/Darcs/Test/Patch/Examples/Set1.hs b/harness/Darcs/Test/Patch/Examples/Set1.hs --- a/harness/Darcs/Test/Patch/Examples/Set1.hs +++ b/harness/Darcs/Test/Patch/Examples/Set1.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} -{-# LANGUAGE CPP #-} - module Darcs.Test.Patch.Examples.Set1 ( knownCommutes, knownCantCommutes, knownMerges , knownMergeEquivs, knownCanons, mergePairs2 @@ -25,6 +22,8 @@ , primitiveTestPatches, testPatches, testPatchesNamed , primitiveCommutePairs ) where +import Prelude () +import Darcs.Prelude import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString.Char8 as BC ( pack ) import qualified Data.ByteString as B ( empty ) @@ -34,16 +33,14 @@ , readPatch, fromPrim , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace ) import Darcs.Patch.Prim ( PrimOf, FromPrim ) -import Darcs.Patch.Prim.V1 ( Prim ) import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Test.Patch.Properties.Check( checkAPatch ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( unsafeUnseal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) -#include "impossible.h" - -type Patch = V1.RepoPatchV1 Prim +type Patch = V1.RepoPatchV1 V1.Prim -- The unit tester function is really just a glorified map for functions that -- return lists, in which the lists get concatenated (where map would end up @@ -86,7 +83,7 @@ (quickhunk 1 "abcde" "cde" :>: NilFL, quickhunk 1 "ab" "" :>: NilFL), (quickhunk 1 "abcde" "acde" :>: NilFL, quickhunk 2 "b" "" :>: NilFL)] -quickhunk :: (FromPrim p, PrimOf p ~ Prim) => Int -> String -> String -> p wX wY +quickhunk :: (FromPrim p, PrimOf p ~ V1.Prim) => Int -> String -> String -> p wX wY quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o) (map (\c -> BC.pack [c]) n) diff --git a/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs b/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs --- a/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs +++ b/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs @@ -15,10 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} - - module Darcs.Test.Patch.Examples.Set2Unwitnessed ( primPermutables, primPatches , commutables, commutablesFL @@ -30,11 +26,9 @@ import qualified Data.ByteString.Char8 as BC ( pack ) import Darcs.Patch.Witnesses.Sealed import Darcs.Patch ( invert, hunk ) -import Darcs.Patch.Patchy ( Invert(..) ) -import Darcs.Patch.Prim ( PrimPatch ) -import Darcs.Patch.Prim.V1 ( Prim ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Prim ( PrimPatch, fromPrim ) import Darcs.Patch.V2 ( RepoPatchV2 ) -import Darcs.Patch.V2.RepoPatch ( prim2repopatchV2 ) -- import Darcs.Test.Patch.Test () -- for instance Eq Patch -- import Darcs.Test.Patch.Examples.Set2Unwitnessed import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) @@ -45,14 +39,14 @@ import Darcs.Util.Printer.Color () -- for instance Show Doc import Darcs.Test.Patch.WSub + import qualified Darcs.Patch.Witnesses.Ordered as W ( (:>), (:\/:) ) import qualified Data.ByteString as B ( ByteString ) import Darcs.Test.Patch.V1Model ( V1Model, Content , makeRepo, makeFile) import Darcs.Test.Patch.WithState ( WithStartState(..) ) -import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) ) -import Darcs.Util.Path ( FileName, fp2fn, makeName ) -import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim ) +import Darcs.Util.Path ( makeName ) +import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim, PrimConstruct(..) ) import Darcs.Patch.Merge ( Merge ) import Darcs.Test.Patch.Arbitrary.Generic ( Tree(..) @@ -63,209 +57,210 @@ ) -- import Debug.Trace --- #include "impossible.h" +type Patch = RepoPatchV2 Prim2 + makeSimpleRepo :: String -> Content -> V1Model wX makeSimpleRepo filename content = makeRepo [(makeName filename, makeFile content)] -w_tripleExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p W.:> p)] +w_tripleExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [Sealed2 (p W.:> p W.:> p)] w_tripleExamples = [commuteTripleFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "g"])) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "j"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"])) NilTree))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "e"])) NilTree)) + (SeqTree (hunk "file" 1 [] [BC.pack "g"]) + (SeqTree (hunk "file" 2 [] [BC.pack "j"]) + (SeqTree (hunk "file" 1 [] [BC.pack "s"]) NilTree))) + (SeqTree (hunk "file" 1 [] [BC.pack "e"]) NilTree)) ,commuteTripleFromTree seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "j"]) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"])) + (SeqTree (hunk "file" 1 [] [BC.pack "s"]) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)) + (SeqTree (hunk "file" 2 [BC.pack "j"] []) NilTree) + (SeqTree (hunk "file" 2 [BC.pack "j"] []) NilTree))) + (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree)) ] -w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:\/: p)] +w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [Sealed2 (p W.:\/: p)] w_mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) w_commuteExamples -w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p)] +w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [Sealed2 (p W.:> p)] w_commuteExamples = [ commutePairFromTWFP seal2 $ WithStartState (makeSimpleRepo "file" []) (TWFP 3 (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "b"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "f"] [])) NilTree)))))), + (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "b"]) + (SeqTree (hunk "file" 1 [] [BC.pack "f"]) + (SeqTree (hunk "file" 1 [] [BC.pack "v"]) + (SeqTree (hunk "file" 2 [BC.pack "f"] []) NilTree)))))), commutePairFromTWFP seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"]) (TWFP 3 (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree) + (SeqTree (hunk "file" 3 [BC.pack "d"] []) NilTree) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "s",BC.pack "d"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)))))), + (SeqTree (hunk "file" 1 [BC.pack "f"] []) NilTree) + (SeqTree (hunk "file" 1 [BC.pack "f"] []) + (SeqTree (hunk "file" 1 [BC.pack "s",BC.pack "d"] []) + (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)))))), {- commutePairFromTWFP seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack "u", BC.pack "s",BC.pack "d"]) (TWFP 5 (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 5 [] [BC.pack "x"])) - (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "d"] [])) NilTree)) + (SeqTree (hunk "file" 5 [] [BC.pack "x"]) + (SeqTree (hunk "file" 4 [BC.pack "d"] []) NilTree)) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "u"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) - (SeqTree (FP(fp2fn "./file") (Hunk 1 [BC.pack "u",BC.pack "s",BC.pack "d"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "a"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "a"] [])) NilTree))))))),-} + (SeqTree (hunk "file" 1 [BC.pack "f",BC.pack "u"] []) NilTree) + (SeqTree (hunk "file" 1 [BC.pack "f"] []) + (SeqTree (hunk "file" 1 [BC.pack "u",BC.pack "s",BC.pack "d"] []) + (SeqTree (hunk "file" 1 [] [BC.pack "a"]) + (SeqTree (hunk "file" 1 [BC.pack "a"] []) NilTree))))))),-} commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"]) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n",BC.pack "t",BC.pack "h"] [])) + (SeqTree (hunk "file" 1 [BC.pack "n",BC.pack "t",BC.pack "h"] []) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "h"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] [])) NilTree)))), + (SeqTree (hunk "file" 3 [BC.pack "h"] []) + (SeqTree (hunk "file" 1 [BC.pack "n"] []) + (SeqTree (hunk "file" 1 [BC.pack "t"] []) NilTree)))), commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "n"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"])) NilTree))), + (SeqTree (hunk "file" 1 [] [BC.pack "n"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "i"]) + (SeqTree (hunk "file" 1 [] [BC.pack "i"]) NilTree))), commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"])) + (SeqTree (hunk "file" 1 [] [BC.pack "c"]) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "c"] [BC.pack "r"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree)))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)), + (SeqTree (hunk "file" 1 [BC.pack "c"] [BC.pack "r"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "h"]) + (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree)))) + (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree)), commutePairFromTWFP seal2 $ WithStartState (makeSimpleRepo "file" []) (TWFP 1 (ParTree (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree))), + (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree)) + (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree))), commutePairFromTWFP seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r", BC.pack "c",BC.pack "v"]) (TWFP 4 (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c",BC.pack "v"] [])) + (SeqTree (hunk "file" 3 [BC.pack "c",BC.pack "v"] []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "r"] [])) - (SeqTree (FP (fp2fn "fi le") (Hunk 1 [BC.pack "f"] [])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "r"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"])) NilTree)))) - (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "v"] [])) NilTree))), + (SeqTree (hunk "file" 2 [BC.pack "r"] []) + (SeqTree (hunk "fi le" 1 [BC.pack "f"] []) NilTree)) + (SeqTree (hunk "file" 1 [BC.pack "f",BC.pack "r"] []) + (SeqTree (hunk "file" 1 [] [BC.pack "y"]) NilTree)))) + (SeqTree (hunk "file" 4 [BC.pack "v"] []) NilTree))), commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "r"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree)))) + (SeqTree (hunk "file" 1 [] [BC.pack "r"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree)))) , commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"]) (ParTree (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t",BC.pack "r",BC.pack "h"] [])) + (SeqTree (hunk "file" 1 [BC.pack "t",BC.pack "r",BC.pack "h"] []) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "o"])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] [])) NilTree))) + (SeqTree (hunk "file" 1 [] [BC.pack "o"]) NilTree)) + (SeqTree (hunk "file" 1 [BC.pack "t"] []) + (SeqTree (hunk "file" 2 [BC.pack "h"] []) NilTree))) , commutePairFromTWFP seal2 $ WithStartState (makeSimpleRepo "file" []) $ TWFP 2 (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"])) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "m"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)))) + (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "y"]) + (SeqTree (hunk "file" 2 [] [BC.pack "m"]) + (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)))) , commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "p"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "p"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"])) NilTree))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree)) + (SeqTree (hunk "file" 1 [] [BC.pack "p"]) + (SeqTree (hunk "file" 1 [BC.pack "p"] []) + (SeqTree (hunk "file" 1 [] [BC.pack "c"]) NilTree))) + (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree)) , commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)) + (SeqTree (hunk "file" 1 [] [BC.pack "j" ]) + (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree)) + (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)) , commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))) + (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree) + (SeqTree (hunk "file" 1 [] [BC.pack "j" ]) + (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree))) , commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"]) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) + (SeqTree (hunk "file" 1 [] [BC.pack "h"]) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "x"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"])) NilTree)))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "l"])) NilTree)) + (SeqTree (hunk "file" 3 [BC.pack "c"] []) NilTree) + (SeqTree (hunk "file" 2 [BC.pack "x"] []) + (SeqTree (hunk "file" 1 [] [BC.pack "j"]) NilTree)))) + (SeqTree (hunk "file" 1 [] [BC.pack "l"]) NilTree)) , commutePairFromTree seal2 $ WithStartState (makeSimpleRepo "file" []) (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "s"))) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "k"))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "k") [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "m"))) - (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "m") [])) NilTree))))) + (SeqTree (hunk "file" 1 [] (packStringLetters "s")) NilTree) + (SeqTree (hunk "file" 1 [] (packStringLetters "k")) + (SeqTree (hunk "file" 1 (packStringLetters "k") []) + (SeqTree (hunk "file" 1 [] (packStringLetters "m")) + (SeqTree (hunk "file" 1 (packStringLetters "m") []) NilTree))))) ] packStringLetters :: String -> [B.ByteString] packStringLetters = map (BC.pack . (:[])) -w_repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))] +w_repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim2))] w_repov2PatchLoopExamples = - [Sealed (WithStartState (makeSimpleRepo fx_name []) + [Sealed (WithStartState (makeSimpleRepo fx []) $ canonizeTree (ParTree - (SeqTree (FP fx (Hunk 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd"))) + (SeqTree (hunk fx 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")) (ParTree - (SeqTree (FP fx (Hunk 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh"))) + (SeqTree (hunk fx 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")) (ParTree (ParTree NilTree (ParTree (ParTree (ParTree - (SeqTree (FP fx (Hunk 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps"))) + (SeqTree (hunk fx 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")) (ParTree NilTree (ParTree - (SeqTree (FP fx (Hunk 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro"))) + (SeqTree (hunk fx 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")) (ParTree (ParTree - (SeqTree (FP fx (Hunk 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree) + (SeqTree (hunk fx 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg")) NilTree) NilTree) NilTree)) - (SeqTree (FP fx (Hunk 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree)))) - (SeqTree (FP fx (Hunk 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree)) - (SeqTree (FP fx (Hunk 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx"))) - (SeqTree (FP fx (Hunk 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe"))) - (SeqTree (FP fx (Hunk 39 [] (packStringLetters "ji"))) + (SeqTree (hunk fx 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe")) NilTree)))) + (SeqTree (hunk fx 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq")) NilTree)) + (SeqTree (hunk fx 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx")) + (SeqTree (hunk fx 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe")) + (SeqTree (hunk fx 39 [] (packStringLetters "ji")) (ParTree NilTree (ParTree @@ -273,14 +268,14 @@ (ParTree (ParTree NilTree - (SeqTree (FP fx (Hunk 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj"))) - (SeqTree (FP fx (Hunk 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree))) + (SeqTree (hunk fx 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")) + (SeqTree (hunk fx 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp")) NilTree))) (ParTree NilTree - (SeqTree (FP fx (Hunk 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy"))) + (SeqTree (hunk fx 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")) (ParTree NilTree - (SeqTree (FP fx (Hunk 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree))))))))))) + (SeqTree (hunk fx 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp")) NilTree))))))))))) (ParTree NilTree NilTree))) @@ -288,46 +283,42 @@ NilTree)) (ParTree NilTree - (SeqTree (FP fx (Hunk 1 [] (packStringLetters "ti"))) - (SeqTree (FP fx (Hunk 1 (packStringLetters "t") (packStringLetters "ybcop"))) - (SeqTree (FP fx (Hunk 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf"))) - (SeqTree (FP fx (Hunk 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc"))) - (SeqTree (FP fx (Hunk 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw"))) + (SeqTree (hunk fx 1 [] (packStringLetters "ti")) + (SeqTree (hunk fx 1 (packStringLetters "t") (packStringLetters "ybcop")) + (SeqTree (hunk fx 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf")) + (SeqTree (hunk fx 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc")) + (SeqTree (hunk fx 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw")) (ParTree NilTree NilTree)))))))))] where - fx_name :: String - fx_name = "F" - - fx :: FileName - fx = fp2fn "./F" - + fx :: String + fx = "F" -mergeExamples :: [Sealed2 (RepoPatchV2 Prim :\/: RepoPatchV2 Prim)] +mergeExamples :: [Sealed2 (Patch :\/: Patch)] mergeExamples = map (mapSeal2 fromW) w_mergeExamples -repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))] +repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim2))] repov2PatchLoopExamples = w_repov2PatchLoopExamples -commuteExamples :: [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim)] +commuteExamples :: [Sealed2 (Patch :> Patch)] commuteExamples = map (mapSeal2 fromW) w_commuteExamples -tripleExamples :: [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim)] +tripleExamples :: [Sealed2 (Patch :> Patch :> Patch)] tripleExamples = map (mapSeal2 fromW) w_tripleExamples -notDuplicatestriple :: (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY -> Bool +notDuplicatestriple :: (Patch :> Patch :> Patch) wX wY -> Bool notDuplicatestriple = W.notDuplicatestriple . toW quickhunk :: PrimPatch prim => Int -> String -> String -> prim wX wY quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o) (map (\c -> BC.pack [c]) n) -primPermutables :: [(Prim :> Prim :> Prim) wX wY] +primPermutables :: [(Prim2 :> Prim2 :> Prim2) wX wY] primPermutables = [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"] -mergeables :: [(Prim :\/: Prim) wX wY] +mergeables :: [(Prim2 :\/: Prim2) wX wY] mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c", quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c", quickhunk 0 "" "a" :\/: quickhunk 1 "" "b", @@ -336,7 +327,7 @@ quickhunk 0 "" "a" :\/: quickhunk 1 "b" "" ] -mergeablesFL :: [(FL Prim :\/: FL Prim) wX wY] +mergeablesFL :: [(FL Prim2 :\/: FL Prim2) wX wY] mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++ [] -- [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL) -- :\/: (quickhunk 1 "a" "z" :>: NilFL), @@ -346,50 +337,50 @@ mergeable2commutable :: Invert p => (p :\/: p) wX wY -> (p :> p) wX wY mergeable2commutable (x :\/: y) = unsafeCoerceP (invert x) :> y -commutablesFL :: [(FL Prim :> FL Prim) wX wY] +commutablesFL :: [(FL Prim2 :> FL Prim2) wX wY] commutablesFL = map mergeable2commutable mergeablesFL -commutables :: [(Prim :> Prim) wX wY] +commutables :: [(Prim2 :> Prim2) wX wY] commutables = map mergeable2commutable mergeables -primPatches :: [Prim wX wY] +primPatches :: [Prim2 wX wY] primPatches = concatMap mergeable2patches mergeables where mergeable2patches (x:\/:y) = [x,y] -repov2Patches :: [RepoPatchV2 Prim wX wY] +repov2Patches :: [Patch wX wY] repov2Patches = concatMap commutable2patches repov2Commutables where commutable2patches (x:>y) = [x,y] -repov2Triples :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY] +repov2Triples :: [(Patch :> Patch :> Patch) wX wY] repov2Triples = [ob' :> oa2 :> a2'', oa' :> oa2 :> a2''] ++ map unsafeUnseal2 tripleExamples ++ map unsafeUnseal2 (concatMap getTriples repov2FLs) - where oa = prim2repopatchV2 $ quickhunk 1 "o" "aa" + where oa = fromPrim $ quickhunk 1 "o" "aa" oa2 = oa - a2 = prim2repopatchV2 $ quickhunk 2 "a34" "2xx" - ob = prim2repopatchV2 $ quickhunk 1 "o" "bb" + a2 = fromPrim $ quickhunk 2 "a34" "2xx" + ob = fromPrim $ quickhunk 1 "o" "bb" ob' :/\: oa' = merge (oa :\/: ob) a2' :/\: _ = merge (ob' :\/: a2) a2'' :/\: _ = merge (oa2 :\/: a2') -repov2NonduplicateTriples :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY] +repov2NonduplicateTriples :: [(Patch :> Patch :> Patch) wX wY] repov2NonduplicateTriples = filter (notDuplicatestriple) repov2Triples -repov2FLs :: [FL (RepoPatchV2 Prim) wX wY] +repov2FLs :: [FL (Patch) wX wY] repov2FLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL] - where oa = prim2repopatchV2 $ quickhunk 1 "o" "a" + where oa = fromPrim $ quickhunk 1 "o" "a" ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL) -repov2Commutables :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY] +repov2Commutables :: [(Patch :> Patch) wX wY] repov2Commutables = map unsafeUnseal2 commuteExamples++ map mergeable2commutable repov2Mergeables++ [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs repov2FLs) - where oa = prim2repopatchV2 $ quickhunk 1 "o" "a" - ob = prim2repopatchV2 $ quickhunk 1 "o" "b" + where oa = fromPrim $ quickhunk 1 "o" "a" + ob = fromPrim $ quickhunk 1 "o" "b" _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL) -repov2Mergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY] -repov2Mergeables = map (\ (x :\/: y) -> prim2repopatchV2 x :\/: prim2repopatchV2 y) mergeables +repov2Mergeables :: [(Patch :\/: Patch) wX wY] +repov2Mergeables = map (\ (x :\/: y) -> fromPrim x :\/: fromPrim y) mergeables ++ repov2IglooMergeables ++ repov2QuickcheckMergeables ++ map unsafeUnseal2 mergeExamples @@ -410,16 +401,16 @@ (ob'' :\/: og''), (ob'' :\/: oc''), (oc' :\/: od'')] - where oa = prim2repopatchV2 $ quickhunk 1 "o" "aa" - a2 = prim2repopatchV2 $ quickhunk 2 "a34" "2xx" - og = prim2repopatchV2 $ quickhunk 3 "4" "g" - ob = prim2repopatchV2 $ quickhunk 1 "o" "bb" - b2 = prim2repopatchV2 $ quickhunk 2 "b" "2" - oc = prim2repopatchV2 $ quickhunk 1 "o" "cc" - od = prim2repopatchV2 $ quickhunk 7 "x" "d" - oe = prim2repopatchV2 $ quickhunk 7 "x" "e" - pf = prim2repopatchV2 $ quickhunk 7 "x" "f" - od'' = prim2repopatchV2 $ quickhunk 8 "x" "d" + where oa = fromPrim $ quickhunk 1 "o" "aa" + a2 = fromPrim $ quickhunk 2 "a34" "2xx" + og = fromPrim $ quickhunk 3 "4" "g" + ob = fromPrim $ quickhunk 1 "o" "bb" + b2 = fromPrim $ quickhunk 2 "b" "2" + oc = fromPrim $ quickhunk 1 "o" "cc" + od = fromPrim $ quickhunk 7 "x" "d" + oe = fromPrim $ quickhunk 7 "x" "e" + pf = fromPrim $ quickhunk 7 "x" "f" + od'' = fromPrim $ quickhunk 8 "x" "d" ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL) a2' :/\: _ = merge (ob' :\/: a2) ob'' :/\: _ = merge (a2 :\/: ob') @@ -431,12 +422,12 @@ oc''' :/\: _ = merge (ob' :\/: oc') oe' :/\: _ = merge (od :\/: oe) of' :/\: _ = merge (od :\/: pf) - pair2m :: Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim) - -> Maybe ((RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY) + pair2m :: Sealed2 (Patch :> Patch) + -> Maybe ((Patch :\/: Patch) wX wY) pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) return $ unsafeCoerceP (xx :\/: y') -repov2IglooMergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY] +repov2IglooMergeables :: [(Patch :\/: Patch) wX wY] repov2IglooMergeables = [(a :\/: b), (b :\/: c), (a :\/: c), @@ -447,17 +438,17 @@ (z' :\/: y'), (x' :\/: z'), (a :\/: a)] - where a = prim2repopatchV2 $ quickhunk 1 "1" "A" - b = prim2repopatchV2 $ quickhunk 2 "2" "B" - c = prim2repopatchV2 $ quickhunk 3 "3" "C" - x = prim2repopatchV2 $ quickhunk 1 "1BC" "xbc" - y = prim2repopatchV2 $ quickhunk 1 "A2C" "ayc" - z = prim2repopatchV2 $ quickhunk 1 "AB3" "abz" + where a = fromPrim $ quickhunk 1 "1" "A" + b = fromPrim $ quickhunk 2 "2" "B" + c = fromPrim $ quickhunk 3 "3" "C" + x = fromPrim $ quickhunk 1 "1BC" "xbc" + y = fromPrim $ quickhunk 1 "A2C" "ayc" + z = fromPrim $ quickhunk 1 "AB3" "abz" x' :/\: _ = merge (a :\/: x) y' :/\: _ = merge (b :\/: y) z' :/\: _ = merge (c :\/: z) -repov2QuickcheckMergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY] +repov2QuickcheckMergeables :: [(Patch :\/: Patch) wX wY] repov2QuickcheckMergeables = [-- invert k1 :\/: n1 --, invert k2 :\/: n2 hb :\/: k @@ -467,25 +458,25 @@ , k' :\/: k' , k3 :\/: k3 ] ++ catMaybes (map pair2m pairs) - where hb = prim2repopatchV2 $ quickhunk 0 "" "hb" - k = prim2repopatchV2 $ quickhunk 0 "" "k" - n = prim2repopatchV2 $ quickhunk 0 "" "n" - b = prim2repopatchV2 $ quickhunk 1 "b" "" - d = prim2repopatchV2 $ quickhunk 2 "" "d" + where hb = fromPrim $ quickhunk 0 "" "hb" + k = fromPrim $ quickhunk 0 "" "k" + n = fromPrim $ quickhunk 0 "" "n" + b = fromPrim $ quickhunk 1 "b" "" + d = fromPrim $ quickhunk 2 "" "d" d':/\:_ = merge (b :\/: d) --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL) --k2 :>: n2 :>: NilFL :/\: _ = -- merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL) k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL) pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL) - pair2m :: Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim) - -> Maybe ((RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY) + pair2m :: Sealed2 (Patch :> Patch) + -> Maybe ((Patch :\/: Patch) wX wY) pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) return $ unsafeCoerceP (xx :\/: y') - i = prim2repopatchV2 $ quickhunk 0 "" "i" - x = prim2repopatchV2 $ quickhunk 0 "" "x" - xi = prim2repopatchV2 $ quickhunk 0 "xi" "" + i = fromPrim $ quickhunk 0 "" "i" + x = fromPrim $ quickhunk 0 "" "x" + xi = fromPrim $ quickhunk 0 "xi" "" d3 :/\: _ = merge (xi :\/: d) _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL) diff --git a/harness/Darcs/Test/Patch/FileUUIDModel.hs b/harness/Darcs/Test/Patch/FileUUIDModel.hs --- a/harness/Darcs/Test/Patch/FileUUIDModel.hs +++ b/harness/Darcs/Test/Patch/FileUUIDModel.hs @@ -1,6 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-} -{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-} - +{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-} -- | Repository model module Darcs.Test.Patch.FileUUIDModel @@ -10,8 +8,8 @@ , emptyFile , emptyDir , nullRepo - , isEmpty - , root, repoObjects + , root, rootId + , repoObjects, repoIds , aFilename, aDirname , aLine, aContent , aFile, aDir @@ -20,41 +18,34 @@ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized ) import Darcs.Test.Patch.RepoModel -import Darcs.Patch.Apply( Apply(..), applyToState ) -import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) -import Darcs.Patch.Prim.FileUUID.Core( UUID(..), Hunk(..), Prim(..), Object(..) ) +import Darcs.Patch.Apply( applyToState ) +import Darcs.Patch.Prim.FileUUID.Core( UUID(..), Object(..) ) import Darcs.Patch.Prim.FileUUID.Apply( ObjectMap(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) import Darcs.Patch.Witnesses.Show -import Darcs.Util.Path -import Darcs.Util.Tree( Tree, TreeItem ) -import qualified Darcs.Util.Tree as T +import Darcs.Util.Path ( Name, unsafeMakeName ) import Darcs.Util.Hash( Hash(..) ) -import Darcs.Util.Tree.Hashed ( darcsUpdateHashes ) import Control.Applicative ( (<$>) ) -import Control.Arrow ( second ) -import qualified Data.ByteString as BS +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import Data.List ( intercalate, sort ) import qualified Data.Map as M import Test.QuickCheck ( Arbitrary(..) , Gen, choose, vectorOf, frequency, oneof ) - -#include "impossible.h" - +-- import Text.Show.Pretty ( ppShow ) ---------------------------------------------------------------------- -- * Model definition -newtype FileUUIDModel wX = FileUUIDModel { repoMap :: ObjectMap Fail } +newtype FileUUIDModel wX = FileUUIDModel { _repoMap :: ObjectMap Fail } ---------------------------------------- -- Instances @@ -65,8 +56,8 @@ deriving instance Eq (Object Fail) -instance Show (FileUUIDModel x) where - show = showModel +instance Show (FileUUIDModel wX) where + show repo = "FileUUIDModel " ++ show (repoObjects repo) instance Show1 FileUUIDModel where showDict1 = ShowDictClass @@ -75,16 +66,18 @@ -- * Constructors objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m -objectMap map = ObjectMap { getObject = get, putObject = put, listObjects = list } - where list = return $ M.keys map - put k o = return $ objectMap (M.insert k o map) - get k = return $ M.lookup k map +objectMap m = ObjectMap { getObject = get, putObject = put, listObjects = list } + where list = return $ M.keys m + put k o = return $ objectMap (M.insert k o m) + get k = return $ M.lookup k m +{- emptyRepo :: FileUUIDModel wX -emptyRepo = FileUUIDModel (objectMap M.empty) +emptyRepo = FileUUIDModel (objectMap $ M.singleton rootId emptyDir) +-} emptyFile :: (Monad m) => Object m -emptyFile = Blob (return BS.empty) NoHash +emptyFile = Blob (return B.empty) NoHash emptyDir :: Object m emptyDir = Directory M.empty @@ -93,22 +86,32 @@ -- * Queries nullRepo :: FileUUIDModel wX -> Bool -nullRepo = null . repoObjects +nullRepo repo = repoIds repo == [rootId] +rootId :: UUID +rootId = UUID "ROOT" + +-- | The root directory of a repository. +root :: FileUUIDModel wX -> (UUID, Object Fail) +root (FileUUIDModel repo) = (rootId, fromJust $ unFail $ getObject repo rootId) + +repoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)] +repoObjects (FileUUIDModel repo) = + [(uuid, obj uuid) | uuid <- unFail $ listObjects repo] + where + obj uuid = fromJust $ unFail $ getObject repo uuid + +repoIds :: FileUUIDModel wX -> [UUID] +repoIds = map fst . repoObjects + -- | @isEmpty file@ <=> file content is empty -- @isEmpty dir@ <=> dir has no child isEmpty :: Object Fail -> Bool isEmpty (Directory d) = M.null d -isEmpty (Blob f _) = BS.null $ unFail f - --- | The root directory of a repository. -root :: FileUUIDModel wX -> Object Fail -root (FileUUIDModel repo) = fromJust $ unFail $ getObject repo (UUID "ROOT") +isEmpty (Blob f _) = B.null $ unFail f -repoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)] -repoObjects (FileUUIDModel repo) = [ (id, obj id) | - id <- unFail $ listObjects repo, not $ isEmpty $ obj id ] - where obj id = fromJust $ unFail $ getObject repo id +nonEmptyRepoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)] +nonEmptyRepoObjects = filter (not . isEmpty . snd) . repoObjects ---------------------------------------------------------------------- -- * Comparing repositories @@ -125,29 +128,28 @@ -- | Files are distinguish by ending their names with ".txt". -aFilename :: Gen BS.ByteString -aFilename = do len <- choose (1,maxLength) - name <- vectorOf len alpha - return $ BC.pack $ name ++ ".txt" - where - maxLength = 3 +aFilename :: Gen Name +aFilename = do + len <- choose (1,3) + name <- vectorOf len alpha + return $ unsafeMakeName . BC.pack $ name ++ ".txt" -aDirname :: Gen BS.ByteString -aDirname = do len <- choose (1,maxLength) - BC.pack <$> vectorOf len alpha - where - maxLength = 3 +aDirname :: Gen Name +aDirname = do + len <- choose (1,3) + name <- vectorOf len alpha + return $ unsafeMakeName . BC.pack $ name -aWord :: Gen BS.ByteString +aWord :: Gen B.ByteString aWord = do c <- alpha return $ BC.pack[c] -aLine :: Gen BS.ByteString +aLine :: Gen B.ByteString aLine = do wordsNo <- choose (1,2) ws <- vectorOf wordsNo aWord return $ BC.unwords ws -aContent :: Gen BS.ByteString +aContent :: Gen B.ByteString aContent = bSized 0 0.5 80 $ \k -> do n <- choose (0,k) BC.intercalate "\n" <$> vectorOf n aLine @@ -161,7 +163,6 @@ do dirsplit <- choose (1, length dirids) filesplit <- choose (1, length fileids) let ids = take filesplit fileids - rem = drop filesplit fileids files <- vectorOf filesplit aFile names <- vectorOf filesplit aFilename dirnames <- vectorOf dirsplit aDirname @@ -175,28 +176,29 @@ dirsplit <- choose (1, length dirs) filesplit <- choose (1, length files) dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files) - rem <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files) - return $ dir ++ rem + remaining <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files) + return $ dir ++ remaining anUUID :: Gen UUID -anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789") +anUUID = UUID . BC.pack <$> vectorOf 4 (oneof $ map return "0123456789") -- | @aRepo filesNo dirsNo@ produces repositories with *at most* -- @filesNo@ files and @dirsNo@ directories. -- The structure of the repository is aleatory. -aRepo :: Int -- ^ Maximum number of files - -> Int -- ^ Maximum number of directories - -> Gen (FileUUIDModel wX) -aRepo maxFiles maxDirs - = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0 - filesNo <- choose (minFiles,maxFiles) - let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0 - dirsNo <- choose (minDirs,maxDirs) - dirids <- (UUID "ROOT":) <$> uniques dirsNo anUUID - fileids <- uniques filesNo anUUID - objectmap <- aDir dirids fileids - return $ FileUUIDModel $ objectMap $ M.fromList objectmap +aRepo :: Int -- ^ Maximum number of files + -> Int -- ^ Maximum number of directories + -> Gen (FileUUIDModel wX) +aRepo maxFiles maxDirs = do + ids <- uniques (maxFiles+maxDirs) anUUID + let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0 + filesNo <- choose (minFiles,maxFiles) + let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0 + dirsNo <- choose (minDirs,maxDirs) + let (dirids, ids') = splitAt dirsNo ids + fileids = take filesNo ids' + objectmap <- aDir (rootId : dirids) fileids + return $ FileUUIDModel $ objectMap $ M.fromList objectmap -- | Generate small repositories. -- Small repositories help generating (potentially) conflicting patches. @@ -206,9 +208,8 @@ dirsNo <- frequency [(3, return 1), (1, return 0)] aRepo filesNo dirsNo repoApply (FileUUIDModel state) patch = FileUUIDModel <$> applyToState patch state - showModel model = "FileUUIDModel{\n" ++ unlines (map entry $ repoObjects model) ++ "}" - where entry (id, obj) = show id ++ " -> " ++ show obj - eqModel r1 r2 = repoObjects r1 == repoObjects r2 + showModel = show -- ppShow + eqModel r1 r2 = nonEmptyRepoObjects r1 == nonEmptyRepoObjects r2 instance Arbitrary (Sealed FileUUIDModel) where arbitrary = seal <$> aSmallRepo diff --git a/harness/Darcs/Test/Patch/Info.hs b/harness/Darcs/Test/Patch/Info.hs --- a/harness/Darcs/Test/Patch/Info.hs +++ b/harness/Darcs/Test/Patch/Info.hs @@ -20,30 +20,36 @@ module Darcs.Test.Patch.Info ( testSuite ) where import Prelude hiding ( pi ) -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as B ( split, pack ) +import qualified Data.ByteString as B ( ByteString, pack ) import qualified Data.ByteString.Char8 as BC ( unpack ) -import Data.List ( sort ) +import Data.List ( sort , isPrefixOf ) import Data.Maybe ( isNothing ) import Data.Text as T ( find, any ) import Data.Text.Encoding ( decodeUtf8With ) import Data.Text.Encoding.Error ( lenientDecode ) -import System.IO.Unsafe ( unsafePerformIO ) import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink - , Gen ) + , Gen, suchThat, scale ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework (Test, testGroup) -import Data.List ( isPrefixOf ) +-- import Text.Show.Pretty ( ppShow ) -import Darcs.Patch.Info ( PatchInfo(..), patchinfo, - piLog, piAuthor, piName ) -import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8, unpackPSFromUTF8 ) +import Darcs.Patch.Info + ( PatchInfo(..), rawPatchInfo, showPatchInfo, readPatchInfo + , piLog, piAuthor, piName, validDate, validLog, validAuthor + , validDatePS, validLogPS, validAuthorPS + ) +import Darcs.Patch.ReadMonads ( parseStrictly ) +import Darcs.Patch.Show ( ShowPatchFor(..) ) +import Darcs.Util.ByteString + ( decodeLocale, packStringToUTF8, unpackPSFromUTF8, linesPS ) +import Darcs.Util.Printer ( renderPS ) testSuite :: Test testSuite = testGroup "Darcs.Patch.Info" [ metadataDecodingTest , metadataEncodingTest , packUnpackTest + , parseUnparseTest ] -- | A newtype wrapping String so we can make our own random generator for it. @@ -58,6 +64,9 @@ -- only UTF-8-encoded PatchInfo's. newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord) +-- Note that this instance only creates valid unicode strings. It does not +-- generate lone surrogates, for instance, as these would fail the +-- packUnpackTest below. instance Arbitrary UnicodeString where -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are -- surrogates. '\xfffd' is excluded because it is used as a marker @@ -67,80 +76,82 @@ ,choose ('\xfffe', '\x10ffff')]) instance Show UTF8PatchInfo where - showsPrec _ = withUTF8PatchInfo rawPatchInfoShow + show = withUTF8PatchInfo rawPatchInfoShow instance Show UTF8OrNotPatchInfo where - showsPrec _ = withUTF8OrNotPatchInfo rawPatchInfoShow + show = withUTF8OrNotPatchInfo rawPatchInfoShow -- | Shows a PatchInfo, outputting every byte and clearly marking what is what -rawPatchInfoShow :: PatchInfo -> String -> String -rawPatchInfoShow pi = ("PatchInfo: \n"++) - . ("date: "++) . shows (_piDate pi) . ('\n':) - . ("author: "++) . shows (_piAuthor pi) . ('\n':) - . ("name: "++) . shows (_piName pi) . ('\n':) - . ("log: "++) . shows (_piLog pi) . ('\n':) +rawPatchInfoShow :: PatchInfo -> String +rawPatchInfoShow = {- ppShow -} show instance Arbitrary UTF8PatchInfo where - arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8Patch + arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8PatchInfo shrink upi = flip withUTF8PatchInfo upi $ \pi -> do sn <- shrink (piName pi) sa <- shrink (piAuthor pi) sl <- shrink (filter (not . isPrefixOf "Ignore-this:") (piLog pi)) - return (UTF8PatchInfo - (unsafePerformIO $ patchinfo sn - (BC.unpack (_piDate pi)) sa sl)) + i <- shrink (isInverted pi) + return (UTF8PatchInfo (rawPatchInfo sn (BC.unpack (_piDate pi)) sa sl i)) instance Arbitrary UTF8OrNotPatchInfo where - arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8Patch, - arbitraryUnencodedPatch]) + arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8PatchInfo, + arbitraryUnencodedPatchInfo]) --- | Generate arbitrary patch metadata that uses the metadata creation function --- 'patchinfo' from Darcs.Patch.Info. -arbitraryUTF8Patch :: Gen PatchInfo -arbitraryUTF8Patch = - do n <- asString `fmap` arbitrary - d <- arbitrary - a <- asString `fmap` arbitrary - l <- (lines . asString) `fmap` arbitrary - return $ unsafePerformIO $ patchinfo n d a l +-- | Generate arbitrary patch metadata. +-- Note : We must NOT use 'patchinfo' from Darcs.Patch.Info +-- with unsafePerformIO here because this breaks the parse/unparse test +-- (the added junk will be different on each call). +arbitraryUTF8PatchInfo :: Gen PatchInfo +arbitraryUTF8PatchInfo = do + d <- arbitrary `suchThat` validDate + n <- (asString `fmap` arbitrary) `suchThat` validLog + a <- (asString `fmap` arbitrary) `suchThat` validAuthor + l <- lines `fmap` scale (* 2) arbitrary + i <- return False + return $ rawPatchInfo d n a l i -- | Generate arbitrary patch metadata that has totally arbitrary byte strings -- as its name, date, author and log. -arbitraryUnencodedPatch :: Gen PatchInfo -arbitraryUnencodedPatch = do - n <- arbitraryByteString - d <- arbitraryByteString - a <- arbitraryByteString - -- split 10 is the ByteString equivalent of 'lines' - l <- B.split 10 `fmap` arbitraryByteString - i <- arbitrary +arbitraryUnencodedPatchInfo :: Gen PatchInfo +arbitraryUnencodedPatchInfo = do + d <- arbitraryByteString `suchThat` validDatePS + n <- arbitraryByteString `suchThat` validLogPS + a <- arbitraryByteString `suchThat` validAuthorPS + l <- linesPS `fmap` scale (* 2) arbitraryByteString + i <- return False return (PatchInfo d n a l i) -arbitraryByteString :: Gen ByteString -arbitraryByteString = (B.pack . map fromIntegral) - `fmap` listOf (choose (0, 255) :: Gen Int) +arbitraryByteString :: Gen B.ByteString +arbitraryByteString = B.pack <$> listOf arbitrary -- | Test that anything produced by the 'patchinfo' function is valid UTF-8 metadataEncodingTest :: Test -metadataEncodingTest = testProperty "Testing patch metadata encoding" $ - withUTF8PatchInfo $ - \patchInfo -> encodingOK (_piAuthor patchInfo) - && encodingOK (_piName patchInfo) - && all encodingOK (_piLog patchInfo) - where encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode +metadataEncodingTest = + testProperty "Testing patch metadata encoding" propMetadataEncoding +propMetadataEncoding :: UTF8PatchInfo -> Bool +propMetadataEncoding (UTF8PatchInfo patchInfo) = + encodingOK (_piAuthor patchInfo) + && encodingOK (_piName patchInfo) + && all encodingOK (_piLog patchInfo) + where + encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode + -- | Test that metadata in patches are decoded as UTF-8 or locale depending on -- whether they're valid UTF-8. metadataDecodingTest :: Test -metadataDecodingTest = testProperty "Testing patch metadata decoding" $ - withUTF8OrNotPatchInfo $ - \patchInfo -> utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo - && utf8OrLocale (_piName patchInfo) == piName patchInfo - && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo - where utf8OrLocale bs = if isValidUTF8 bs - then unpackPSFromUTF8 bs - else decodeLocale bs +metadataDecodingTest = testProperty "Testing patch metadata decoding" propMetadataDecoding -isValidUTF8 :: ByteString -> Bool +propMetadataDecoding :: UTF8OrNotPatchInfo -> Bool +propMetadataDecoding (UTF8OrNotPatchInfo patchInfo) = + utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo + && utf8OrLocale (_piName patchInfo) == piName patchInfo + && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo + where + utf8OrLocale bs = + if isValidUTF8 bs then unpackPSFromUTF8 bs else decodeLocale bs + +isValidUTF8 :: B.ByteString -> Bool isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode packUnpackTest :: Test @@ -161,3 +172,18 @@ withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a withUTF8OrNotPatchInfo f mpi = case mpi of UTF8OrNotPatchInfo pinf -> f pinf + +parseUnparseTest :: Test +parseUnparseTest = testProperty "parse . show == id" propParseUnparse + +parsePatchInfo :: B.ByteString -> Maybe PatchInfo +parsePatchInfo = fmap fst . parseStrictly readPatchInfo + +unparsePatchInfo :: PatchInfo -> B.ByteString +unparsePatchInfo = renderPS . showPatchInfo ForStorage + +instance Arbitrary PatchInfo where + arbitrary = arbitraryUnencodedPatchInfo + +propParseUnparse :: PatchInfo -> Bool +propParseUnparse pi = Just pi == parsePatchInfo (unparsePatchInfo pi) diff --git a/harness/Darcs/Test/Patch/Properties/Check.hs b/harness/Darcs/Test/Patch/Properties/Check.hs --- a/harness/Darcs/Test/Patch/Properties/Check.hs +++ b/harness/Darcs/Test/Patch/Properties/Check.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where +import Prelude () +import Darcs.Prelude import Control.Monad ( liftM ) +import Data.Maybe ( isNothing ) import Darcs.Test.Patch.Check ( PatchCheck, checkMove, removeDir, createDir, @@ -16,17 +19,20 @@ import Darcs.Util.Path ( fn2fp ) import qualified Data.Map as M ( mapMaybe ) -import Darcs.Patch ( invert, - effect ) +import Darcs.Patch ( invert, effect, PrimPatch ) import Darcs.Patch.Invert ( Invert ) -import Darcs.Patch.V1 () -import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(..) ) +import Darcs.Patch.V1 ( ) +import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) +import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, isConsistent ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import Darcs.Patch.V1.Core ( isMerger ) -import Darcs.Patch.Prim.V1 () +import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim ) import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Witnesses.Ordered -#include "impossible.h" +type Prim1 = V1.Prim +type Prim2 = V2.Prim class Check p where checkPatch :: p wX wY -> PatchCheck Bool @@ -35,16 +41,27 @@ checkPatch NilFL = isValid checkPatch (p :>: ps) = checkPatch p >> checkPatch ps +instance Check p => Check (p:>p) where + checkPatch (p1 :> p2) = checkPatch p1 >> checkPatch p2 + checkAPatch :: (Invert p, Check p) => p wX wY -> Bool checkAPatch p = doCheck $ do _ <- checkPatch p checkPatch $ invert p -instance Check (V1.RepoPatchV1 Prim) where - checkPatch p | isMerger p = do - checkPatch $ effect p - checkPatch (V1.Merger _ _ _ _) = impossible - checkPatch (V1.Regrem _ _ _ _) = impossible - checkPatch (V1.PP p) = checkPatch p +instance PrimPatch prim => Check (RepoPatchV2 prim) where + checkPatch p = return $ isNothing $ isConsistent p + +instance Check (RepoPatchV1 Prim1) where + checkPatch p | isMerger p = checkPatch $ effect p + checkPatch (Merger _ _ _ _) = impossible + checkPatch (Regrem _ _ _ _) = impossible + checkPatch (PP p) = checkPatch p + +deriving instance Check Prim1 +deriving instance Check Prim2 + +instance Check FileUUID.Prim where + checkPatch _ = return True -- XXX instance Check Prim where diff --git a/harness/Darcs/Test/Patch/Properties/Generic.hs b/harness/Darcs/Test/Patch/Properties/Generic.hs --- a/harness/Darcs/Test/Patch/Properties/Generic.hs +++ b/harness/Darcs/Test/Patch/Properties/Generic.hs @@ -15,10 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-} - - module Darcs.Test.Patch.Properties.Generic ( invertSymmetry, inverseComposition, invertRollback, recommute, commuteInverses, effectPreserving, @@ -37,21 +33,22 @@ import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne, MightBeEmptyHunk(..), MightHaveDuplicate(..) ) import Control.Monad ( msum ) + import Darcs.Patch.Witnesses.Show ( Show2(..), show2 ) -import Darcs.Patch.Patchy ( Patchy, showPatch, commute, invert ) import Darcs.Patch.Read ( ReadPatch ) -import Darcs.Patch.Show ( ShowPatchBasic ) +import Darcs.Patch.Show + ( ShowPatchBasic, displayPatch, showPatch, ShowPatchFor(ForStorage) ) import Darcs.Patch.Prim.Class ( PrimPatch, PrimOf, FromPrim ) import Darcs.Patch () -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Commute ( commuteFLorComplain ) +import Darcs.Patch.Apply ( Apply, ApplyState ) +import Darcs.Patch.Commute ( commute, commuteFL ) import Darcs.Patch.Merge ( Merge(merge) ) import Darcs.Patch.Read ( readPatch ) -import Darcs.Patch.Invert ( invertFL ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Invert ( Invert, invert, invertFL ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 ) -import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text, RenderMode(..) ) +import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text ) --import Darcs.ColorPrinter ( traceDoc ) propIsMergeable :: forall model p wX . (FromPrim p, Merge p, RepoModel model) @@ -64,19 +61,19 @@ _ -> Nothing -- | invert symmetry inv(inv(p)) = p -invertSymmetry :: (Patchy p, MyEq p) => p wA wB -> TestResult +invertSymmetry :: (Invert p, Eq2 p) => p wA wB -> TestResult invertSymmetry p = case invert (invert p) =\/= p of IsEq -> succeeded NotEq -> failed $ redText "p /= inv(inv(p))" -inverseComposition :: (Patchy p, MyEq p) => (p :> p) wX wY -> TestResult +inverseComposition :: (Invert p, Eq2 p) => (p :> p) wX wY -> TestResult inverseComposition (a :> b) = case eqFL (reverseRL (invertFL (a:>:b:>:NilFL))) (invert b:>:invert a:>:NilFL) of IsEq -> succeeded NotEq -> failed $ redText "inv(a :>: b :>: NilFL) /= inv(b) :>: inv(a) :>: NilFL" -- | invert rollback if b = A(a) then a = A'(b) -invertRollback :: (ApplyState p ~ RepoState model, Patchy p, ShowPatchBasic p, RepoModel model) +invertRollback :: (Invert p, Apply p, ApplyState p ~ RepoState model, ShowPatchBasic p, RepoModel model) => WithState model p wA wB -> TestResult invertRollback (WithState a x b) = case maybeFail $ repoApply b (invert x) of @@ -86,10 +83,10 @@ else failed $ redText "a1: " $$ text (showModel a1) $$ redText " ---- is not equals to a:" $$ text (showModel a) $$ redText "where a was" $$ text (showModel b) - $$ redText "with (invert x) on top:" $$ showPatch (invert x) + $$ redText "with (invert x) on top:" $$ displayPatch (invert x) -- | recommute AB ↔ B′A′ if and only if B′A′ ↔ AB -recommute :: (Patchy p, ShowPatchBasic p, MyEq p, MightHaveDuplicate p) +recommute :: (ShowPatchBasic p, Eq2 p, MightHaveDuplicate p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) -> (p :> p) wA wB -> TestResult recommute c (x :> y) = @@ -103,99 +100,150 @@ | hasDuplicate y' || hasDuplicate x' -> rejected | otherwise -> case c (y' :> x') of - Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x') + Nothing -> failed (redText "failed, where x" $$ displayPatch x $$ + redText ":> y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText ":> x'" $$ displayPatch x') Just (x'' :> y'') -> case y'' =/\= y of - NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ showPatch x $$ - redText ":> y" $$ showPatch y $$ - redText "y'" $$ showPatch y' $$ - redText ":> x'" $$ showPatch x' $$ - redText "x''" $$ showPatch x'' $$ - redText ":> y''" $$ showPatch y'') + NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ displayPatch x $$ + redText ":> y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText ":> x'" $$ displayPatch x' $$ + redText "x''" $$ displayPatch x'' $$ + redText ":> y''" $$ displayPatch y'') IsEq -> case x'' =/\= x of - NotEq -> failed (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'') + NotEq -> failed ( + redText "x'' /= x, where x" $$ displayPatch x $$ + redText ":> y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText ":> x'" $$ displayPatch x' $$ + redText "x''" $$ displayPatch x'' $$ + redText ":> y''" $$ displayPatch y'') IsEq -> succeeded -- | commuteInverses AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹ -commuteInverses :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) - -> (p :> p) wA wB -> TestResult +commuteInverses :: (Invert p, ShowPatchBasic p, Eq2 p) + => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) + -> (p :> p) wA wB -> TestResult commuteInverses c (x :> y) = case c (x :> y) of Nothing -> rejected Just (y' :> x') -> case c (invert y :> invert x) of Nothing -> failed $ redText "second commute failed" $$ - redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$ - redText "y'" $$ showPatch y' $$ redText "x'" $$ showPatch x' + redText "x" $$ displayPatch x $$ redText "y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ redText "x'" $$ displayPatch x' Just (ix' :> iy') -> case invert ix' =/\= x' of NotEq -> failed $ redText "invert ix' /= x'" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "y'" $$ showPatch y' $$ - redText "x'" $$ showPatch x' $$ - redText "ix'" $$ showPatch ix' $$ - redText "iy'" $$ showPatch iy' $$ - redText "invert ix'" $$ showPatch (invert ix') $$ - redText "invert iy'" $$ showPatch (invert iy') + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText "x'" $$ displayPatch x' $$ + redText "ix'" $$ displayPatch ix' $$ + redText "iy'" $$ displayPatch iy' $$ + redText "invert ix'" $$ displayPatch (invert ix') $$ + redText "invert iy'" $$ displayPatch (invert iy') IsEq -> case y' =\/= invert iy' of - NotEq -> failed $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y' + NotEq -> failed $ redText "y' /= invert iy'" $$ displayPatch iy' $$ displayPatch y' IsEq -> succeeded -- | effect preserving AB <--> B'A' then effect(AB) = effect(B'A') -effectPreserving :: (Patchy p, MightBeEmptyHunk p, RepoModel model, ApplyState p ~ RepoState model) => - (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) - -> WithState model (p :> p) wA wB -> TestResult -effectPreserving _ (WithState _ (x :> _) _) | isEmptyHunk x = rejected -effectPreserving c (WithState r (x :> y) r') - = case c (x :> y) of - Nothing -> rejected +effectPreserving + :: ( Apply p + , MightBeEmptyHunk p + , RepoModel model + , ApplyState p ~ RepoState model + , ShowPatchBasic p + ) + => (forall wX wY. (p :> p) wX wY -> Maybe ((p :> p) wX wY)) + -> WithState model (p :> p) wA wB + -> TestResult +effectPreserving _ (WithState _ (x :> _) _) + | isEmptyHunk x = rejected +effectPreserving c (WithState r (x :> y) r') = + case c (x :> y) of + Nothing -> rejected Just (y' :> x') -> case maybeFail $ repoApply r y' of - Nothing -> failed $ redText "y' is not applicable to r." - Just r_y' -> - case maybeFail $ repoApply r_y' x' of - Nothing -> failed $ redText "x' is not applicable to r_y'." - Just r_y'x' -> if r_y'x' `eqModel` r' - then succeeded - else failed $ redText "r_y'x' is not equal to r'." + Nothing -> + failed + $ redText "##x" $$ displayPatch x + $$ redText "##y" $$ displayPatch y + $$ redText "##y'" $$ displayPatch y' + $$ redText "##x'" $$ displayPatch x' + $$ redText "##y' is not applicable to r" + $$ displayModel r + Just r_y' -> + case maybeFail $ repoApply r_y' x' of + Nothing -> + failed + $ redText "##x" $$ displayPatch x + $$ redText "##y" $$ displayPatch y + $$ redText "##y'" $$ displayPatch y' + $$ redText "##x'" $$ displayPatch x' + $$ redText "##x' is not applicable to r_y'" + $$ displayModel r_y' + Just r_y'x' -> + if r_y'x' `eqModel` r' + then succeeded + else + failed + $ redText "##x" $$ displayPatch x + $$ redText "##y" $$ displayPatch y + $$ redText "##y'" $$ displayPatch y' + $$ redText "##x'" $$ displayPatch x' + $$ redText "##r_y'x'" + $$ displayModel r_y'x' + $$ redText "##is not equal to r'" + $$ displayModel r' + where + displayModel = text . showModel -- | patchAndInverseCommute If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹ -patchAndInverseCommute :: (Patchy p, ShowPatchBasic p, MyEq p) => - (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) - -> (p :> p) wA wB -> TestResult +patchAndInverseCommute + :: (Invert p, ShowPatchBasic p, Eq2 p) + => (forall wX wY. (p :> p) wX wY -> Maybe ((p :> p) wX wY)) + -> (p :> p) wA wB + -> TestResult patchAndInverseCommute c (x :> y) = case c (x :> y) of - Nothing -> rejected - Just (y' :> x') -> - case c (invert x :> y') of - Nothing -> failed (redText "" - $$ redText "-------- original commute (x :> y):" - $$ showPatch x $$ redText ":>" $$ showPatch y - $$ redText "-------- result (y' :> x'):" - $$ showPatch y' $$ redText ":>" $$ showPatch x' - $$ redText "-------- bad commute (invert x :> y'):" - $$ showPatch (invert x) $$ redText ":>" $$ showPatch y') - Just (y'' :> ix') -> - case y'' =\/= y of - NotEq -> failed (redText "y'' /= y" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "x'" $$ showPatch x' $$ - redText "y'" $$ showPatch y' $$ - redText "y''" $$ showPatch y'' $$ - redText ":> x'" $$ showPatch x') - IsEq -> case x' =\/= invert ix' of - NotEq -> failed (redText "x' /= invert ix'" $$ - redText "y''" $$ showPatch y'' $$ - redText ":> x'" $$ showPatch x' $$ - redText "invert x" $$ showPatch (invert x) $$ - redText ":> y" $$ showPatch y $$ - redText "y'" $$ showPatch y' $$ - redText "ix'" $$ showPatch ix') - IsEq -> succeeded + Nothing -> rejected + Just (y' :> x') -> + case c (invert x :> y') of + Nothing -> + failed $ + redText "-------- original (x :> y)" $$ + displayPatch x $$ redText ":>" $$ displayPatch y $$ + redText "-------- result (y' :> x')" $$ + displayPatch y' $$ redText ":>" $$ displayPatch x' $$ + redText "-------- failed commute (invert x :> y')" $$ + displayPatch (invert x) $$ redText ":>" $$ displayPatch y' + Just (y'' :> ix') -> + case y'' =\/= y of + NotEq -> + failed $ redText "y'' /= y" $$ + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText "x'" $$ displayPatch x' $$ + redText "y''" $$ displayPatch y'' $$ + redText "ix'" $$ displayPatch ix' + IsEq -> + case x' =\/= invert ix' of + NotEq -> + failed $ redText "x' /= invert ix'" $$ + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText "x'" $$ displayPatch x' $$ + redText "invert x" $$ displayPatch (invert x) $$ + redText "y'" $$ displayPatch y' $$ + redText "invert ix'" $$ displayPatch (invert ix') + IsEq -> succeeded -permutivity :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) +permutivity :: (ShowPatchBasic p, Eq2 p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p :> p) wA wB -> TestResult permutivity c (x:>y:>z) = case c (x :> y) of @@ -212,8 +260,8 @@ Just (z4 :> x4) -> --traceDoc (greenText "third commuted" $$ -- greenText "about to commute" $$ - -- greenText "y1" $$ showPatch y1 $$ - -- greenText "z4" $$ showPatch z4) $ + -- greenText "y1" $$ displayPatch y1 $$ + -- greenText "z4" $$ displayPatch z4) $ case c (y1 :> z4) of Nothing -> failed $ redText "permutivity2" Just (z3_ :> y4) @@ -221,68 +269,77 @@ --traceDoc (greenText "passed z3") $ error "foobar test" $ case c (y4 :> x4) of Nothing -> failed $ redText "permutivity5: input was" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "z" $$ showPatch z $$ - redText "z3" $$ showPatch z3 $$ + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "z" $$ displayPatch z $$ + redText "z3" $$ displayPatch z3 $$ redText "failed commute of" $$ - redText "y4" $$ showPatch y4 $$ - redText "x4" $$ showPatch x4 $$ + redText "y4" $$ displayPatch y4 $$ + redText "x4" $$ displayPatch x4 $$ redText "whereas commute of x and y give" $$ - redText "y1" $$ showPatch y1 $$ - redText "x1" $$ showPatch x1 + redText "y1" $$ displayPatch y1 $$ + redText "x1" $$ displayPatch x1 Just (x3_ :> y2_) | NotEq <- x3_ =\/= x3 -> failed $ redText "permutivity6" | NotEq <- y2_ =/\= y2 -> failed $ redText "permutivity7" | otherwise -> succeeded | otherwise -> failed $ redText "permutivity failed" $$ - redText "z3" $$ showPatch z3 $$ - redText "z3_" $$ showPatch z3_ + redText "z3" $$ displayPatch z3 $$ + redText "z3_" $$ displayPatch z3_ -partialPermutivity :: (Patchy p, ShowPatchBasic p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) - -> (p :> p :> p) wA wB -> TestResult -partialPermutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) <&&> pp (invert zz:>invert yy:>invert xx) - where pp (x:>y:>z) = - case c (y :> z) of +partialPermutivity + :: (Invert p, ShowPatchBasic p) + => (forall wX wY. (p :> p) wX wY -> Maybe ((p :> p) wX wY)) + -> (p :> p :> p) wA wB + -> TestResult +partialPermutivity c (xx :> yy :> zz) = + pp (xx :> yy :> zz) <&&> pp (invert zz :> invert yy :> invert xx) + where + pp (x :> y :> z) = + case c (y :> z) of + Nothing -> rejected + Just (z1 :> y1) -> + case c (x :> z1) of Nothing -> rejected - Just (z1 :> y1) -> - case c (x :> z1) of - Nothing -> rejected - Just (_ :> x1) -> - case c (x :> y) of - Just _ -> rejected -- this is covered by full permutivity test above - Nothing -> - case c (x1 :> y1) of - Nothing -> succeeded - Just _ -> failed $ greenText "partialPermutivity error" $$ - greenText "x" $$ showPatch x $$ - greenText "y" $$ showPatch y $$ - greenText "z" $$ showPatch z + Just (_ :> x1) -> + case c (x :> y) of + Just _ -> rejected -- this is covered by full permutivity test above + Nothing -> + case c (x1 :> y1) of + Nothing -> succeeded + Just _ -> + failed $ + greenText "partialPermutivity error" $$ greenText "x" $$ + displayPatch x $$ + greenText "y" $$ + displayPatch y $$ + greenText "z" $$ + displayPatch z -mergeArgumentsConsistent :: (Patchy p, ShowPatchBasic p) => +mergeArgumentsConsistent :: (ShowPatchBasic p) => (forall wX wY . p wX wY -> Maybe Doc) -> (p :\/: p) wA wB -> TestResult mergeArgumentsConsistent isConsistent (x :\/: y) = fromMaybe $ - msum [(\z -> redText "mergeArgumentsConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x, - (\z -> redText "mergeArgumentsConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y] + msum [(\z -> redText "mergeArgumentsConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x, + (\z -> redText "mergeArgumentsConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y] -mergeConsistent :: (Patchy p, ShowPatchBasic p, Merge p) => +mergeConsistent :: (ShowPatchBasic p, Merge p) => (forall wX wY . p wX wY -> Maybe Doc) -> (p :\/: p) wA wB -> TestResult mergeConsistent isConsistent (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> fromMaybe $ - msum [(\z -> redText "mergeConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x, - (\z -> redText "mergeConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y, - (\z -> redText "mergeConsistent x'" $$ showPatch x' $$ z $$ - redText "where x' comes from x" $$ showPatch x $$ - redText "and y" $$ showPatch y) `fmap` isConsistent x', - (\z -> redText "mergeConsistent y'" $$ showPatch y' $$ z) `fmap` isConsistent y'] + msum [(\z -> redText "mergeConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x, + (\z -> redText "mergeConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y, + (\z -> redText "mergeConsistent x'" $$ displayPatch x' $$ z $$ + redText "where x' comes from x" $$ displayPatch x $$ + redText "and y" $$ displayPatch y) `fmap` isConsistent x', + (\z -> redText "mergeConsistent y'" $$ displayPatch y' $$ z) `fmap` isConsistent y'] -mergeEitherWay :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> TestResult +mergeEitherWay :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> TestResult mergeEitherWay (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> case merge (y :\/: x) of @@ -290,7 +347,7 @@ IsEq <- y'' =\/= y' -> succeeded | otherwise -> failed $ redText "mergeEitherWay bug" -mergeCommute :: (Patchy p, MyEq p, ShowPatchBasic p, Merge p, MightHaveDuplicate p) +mergeCommute :: (Eq2 p, ShowPatchBasic p, Merge p, MightHaveDuplicate p) => (p :\/: p) wX wY -> TestResult mergeCommute (x :\/: y) = case merge (x :\/: y) of @@ -303,36 +360,36 @@ | otherwise -> case commute (x :> y') of Nothing -> failed $ redText "mergeCommute 1" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "x'" $$ showPatch x' $$ - redText "y'" $$ showPatch y' + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "x'" $$ displayPatch x' $$ + redText "y'" $$ displayPatch y' Just (y_ :> x'_) | IsEq <- y_ =\/= y, IsEq <- x'_ =\/= x' -> case commute (y :> x') of Nothing -> failed $ redText "mergeCommute 2 failed" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "x'" $$ showPatch x' $$ - redText "y'" $$ showPatch y' + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "x'" $$ displayPatch x' $$ + redText "y'" $$ displayPatch y' Just (x_ :> y'_) | IsEq <- x_ =\/= x, IsEq <- y'_ =\/= y' -> succeeded | otherwise -> failed $ redText "mergeCommute 3" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "x'" $$ showPatch x' $$ - redText "y'" $$ showPatch y' $$ - redText "x_" $$ showPatch x_ $$ - redText "y'_" $$ showPatch y'_ + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "x'" $$ displayPatch x' $$ + redText "y'" $$ displayPatch y' $$ + redText "x_" $$ displayPatch x_ $$ + redText "y'_" $$ displayPatch y'_ | otherwise -> failed $ redText "mergeCommute 4" $$ - redText "x" $$ showPatch x $$ - redText "y" $$ showPatch y $$ - redText "x'" $$ showPatch x' $$ - redText "y'" $$ showPatch y' $$ - redText "x'_" $$ showPatch x'_ $$ - redText "y_" $$ showPatch y_ + redText "x" $$ displayPatch x $$ + redText "y" $$ displayPatch y $$ + redText "x'" $$ displayPatch x' $$ + redText "y'" $$ displayPatch y' $$ + redText "x'_" $$ displayPatch x'_ $$ + redText "y_" $$ displayPatch y_ -- | coalesce effect preserving @@ -345,9 +402,24 @@ Nothing -> rejected Just x -> case maybeFail $ repoApply r x of Nothing -> failed $ redText "x is not applicable to r." + $$ text (showModel r) + $$ displayPatch x + $$ redText "a:>b" + $$ displayPatch a $$ displayPatch b + $$ redText "r'=" + $$ text (showModel r') Just r_x -> if r_x `eqModel` r' then succeeded - else failed $ redText "r_x /= r'" + else failed $ redText "r_x /= r', r=" + $$ text (showModel r) + $$ redText "a:>b=" + $$ displayPatch a $$ displayPatch b + $$ redText "x=" + $$ displayPatch x + $$ redText "r'=" + $$ text (showModel r') + $$ redText "r_x=" + $$ text (showModel r_x) coalesceCommute :: (PrimPatch prim, MightBeEmptyHunk prim) @@ -358,29 +430,59 @@ case j (b :> c) of Nothing -> rejected Just x -> - case commuteFLorComplain (a :> b :>: c :>: NilFL) of - Right (b' :>: c' :>: NilFL :> a') -> - case commute (a:>:NilFL :> x) of - Just (x' :> a'':>:NilFL) -> - case a'' =/\= a' of - NotEq -> failed $ greenText "coalesceCommute 3" - IsEq -> case j (b' :> c') of - Nothing -> failed $ greenText "coalesceCommute 4" - Just x'' -> case x' =\/= x'' of - NotEq -> failed $ greenText "coalesceCommute 5" - IsEq -> succeeded - _ -> failed $ greenText "coalesceCommute 1" + case commuteFL (a :> b :>: c :>: NilFL) of + Just (b' :>: c' :>: NilFL :> a') -> + case commuteFL (a :> x) of + Just (x' :> a'') -> + case a'' =/\= a' of + NotEq -> + failed $ greenText "a'' =/\\= a' failed" + $$ display1 + $$ display2 + IsEq -> + case j (b' :> c') of + Nothing -> + failed $ greenText "coalesce (b':>c') failed" + $$ display1 + $$ display2 + Just x'' -> + case x' =\/= x'' of + NotEq -> + failed $ greenText "x' =\\/= x'' failed" + $$ display1 + $$ display2 + $$ display3 + IsEq -> succeeded + where + display3 = redText "## coalesce (b':>c') => x''" + $$ displayPatch x'' + where + display2 = + redText "## commute (a:>x) => x'" $$ displayPatch x' + $$ redText "## :> a''" $$ displayPatch a'' + _ -> failed $ greenText "commute a x failed" $$ display1 + where + display1 = + redText "## a" $$ displayPatch a + $$ redText "## b" $$ displayPatch b + $$ redText "## c" $$ displayPatch c + $$ redText "## coalesce (b:>c) => x" $$ displayPatch x + $$ redText "## commute (a:>b:>c) => a'" $$ displayPatch a' + $$ redText "## b'" $$ displayPatch b' + $$ redText "## c'" $$ displayPatch c' _ -> rejected -show_read :: (Show2 p, MyEq p, ReadPatch p, ShowPatchBasic p, Patchy p) => p wA wB -> TestResult -show_read p = let ps = renderPS Standard (showPatch p) +-- note: we would normally use displayPatch in the failure message +-- but that would be very misleading here +show_read :: (Show2 p, Eq2 p, ReadPatch p, ShowPatchBasic p) => p wA wB -> TestResult +show_read p = let ps = renderPS (showPatch ForStorage p) in case readPatch ps of - Nothing -> failed (redText "unable to read " $$ showPatch p) + Nothing -> failed (redText "unable to read " $$ showPatch ForStorage p) Just (Sealed p' ) | IsEq <- p' =\/= p -> succeeded | otherwise -> failed $ redText "trouble reading patch p" $$ - showPatch p $$ + showPatch ForStorage p $$ redText "reads as p'" $$ - showPatch p' $$ + showPatch ForStorage p' $$ redText "aka" $$ greenText (show2 p) $$ redText "and" $$ diff --git a/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs b/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs --- a/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs +++ b/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs @@ -14,84 +14,82 @@ import Darcs.Test.Patch.WSub import Darcs.Test.Util.TestResult -import Darcs.Patch.Prim.V1 ( Prim ) -import Darcs.Patch.Patchy ( showPatch ) +import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Read ( ReadPatch ) -import Darcs.Patch.Show ( ShowPatchBasic ) +import Darcs.Patch.Show ( ShowPatchBasic, displayPatch ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Sealed( Sealed ) import Darcs.Patch.Merge ( Merge ) -import Darcs.Patch ( Patchy ) import Darcs.Util.Printer ( Doc, redText, ($$) ) import qualified Darcs.Util.Tree as T ( Tree ) -permutivity :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) +permutivity :: (ShowPatchBasic wp, Eq2 wp, WSub wp p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p :> p) wA wB -> TestResult permutivity f = W.permutivity (fmap toW . f . fromW) . toW -partialPermutivity :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) +partialPermutivity :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p :> p) wA wB -> TestResult partialPermutivity f = W.partialPermutivity (fmap toW . f . fromW) . toW -mergeEitherWay :: (Patchy wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult +mergeEitherWay :: (ShowPatchBasic wp, Eq2 wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult mergeEitherWay = W.mergeEitherWay . toW -commuteInverses :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) +commuteInverses :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p) wA wB -> TestResult commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . toW -recommute :: (Patchy wp, ShowPatchBasic wp, MightHaveDuplicate wp, MyEq wp, WSub wp p) +recommute :: (ShowPatchBasic wp, MightHaveDuplicate wp, Eq2 wp, WSub wp p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) -> (p :> p) wA wB -> TestResult recommute f = W.recommute (fmap toW . f . fromW) . toW -mergeCommute :: (Patchy wp, MightHaveDuplicate wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) +mergeCommute :: (MightHaveDuplicate wp, ShowPatchBasic wp, Eq2 wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult mergeCommute = W.mergeCommute . toW -mergeConsistent :: (Patchy wp, Merge wp, ShowPatchBasic wp, WSub wp p) => +mergeConsistent :: (Merge wp, ShowPatchBasic wp, WSub wp p) => (forall wX wY . p wX wY -> Maybe Doc) -> (p :\/: p) wA wB -> TestResult mergeConsistent f = W.mergeConsistent (f . fromW) . toW -mergeArgumentsConsistent :: (Patchy wp, ShowPatchBasic wp, WSub wp p) => +mergeArgumentsConsistent :: (ShowPatchBasic wp, WSub wp p) => (forall wX wY . p wX wY -> Maybe Doc) -> (p :\/: p) wA wB -> TestResult mergeArgumentsConsistent f = W.mergeArgumentsConsistent (f . fromW) . toW -show_read :: (Patchy p, ShowPatchBasic p, ReadPatch p, MyEq p, Show2 p) => p wX wY -> TestResult +show_read :: (ShowPatchBasic p, ReadPatch p, Eq2 p, Show2 p) => p wX wY -> TestResult show_read = W.show_read -patchAndInverseCommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) => +patchAndInverseCommute :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p) wA wB -> TestResult patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW -coalesceCommute :: MightBeEmptyHunk Prim - => (forall wX wY . (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY)) - -> (Prim :> Prim :> Prim) wA wB -> TestResult +coalesceCommute :: MightBeEmptyHunk Prim2 + => (forall wX wY . (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY)) + -> (Prim2 :> Prim2 :> Prim2) wA wB -> TestResult coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW consistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model) - => Sealed (WithStartState model (Tree Prim)) -> TestResult + => Sealed (WithStartState model (Tree Prim2)) -> TestResult consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x then succeeded else failed $ redText "oops") -commuteFails :: (MyEq p, Patchy p, ShowPatchBasic p) +commuteFails :: (Eq2 p, ShowPatchBasic p) => ((p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p) wX wY -> TestResult commuteFails c (x :> y) = case c (x :> y) of Nothing -> succeeded Just (y' :> x') -> - failed $ redText "x" $$ showPatch x $$ - redText ":> y" $$ showPatch y $$ - redText "y'" $$ showPatch y' $$ - redText ":> x'" $$ showPatch x' + failed $ redText "x" $$ displayPatch x $$ + redText ":> y" $$ displayPatch y $$ + redText "y'" $$ displayPatch y' $$ + redText ":> x'" $$ displayPatch x' diff --git a/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs b/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs --- a/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs +++ b/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs @@ -1,19 +1,25 @@ -{-# LANGUAGE CPP #-} module Darcs.Test.Patch.Properties.RepoPatchV2 ( propConsistentTreeFlattenings ) where +import Prelude () +import Darcs.Prelude + import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree ) import Darcs.Test.Patch.WithState import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState , Fail, maybeFail ) import qualified Darcs.Util.Tree as T ( Tree ) -import Darcs.Patch.Witnesses.Sealed( Sealed(..) ) -import Darcs.Patch.V2.RepoPatch( prim2repopatchV2 ) -import Darcs.Patch.Prim.V1 ( Prim ) +import Darcs.Patch.Prim ( fromPrim ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim ) +import Darcs.Patch.V2 ( RepoPatchV2 ) -#include "impossible.h" +type Prim2 = V2.Prim +fromPrim2 :: Prim2 wX wY -> RepoPatchV2 Prim2 wX wY +fromPrim2 = fromPrim + assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool assertEqualFst (x,bx) (y,by) | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True @@ -26,10 +32,11 @@ | otherwise = "Nothing" propConsistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model) - => Sealed (WithStartState model (Tree Prim)) -> Bool + => Sealed (WithStartState model (Tree Prim2)) + -> Bool propConsistentTreeFlattenings (Sealed (WithStartState start t)) = fromJust $ - do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2repopatchV2 t + do Sealed (G2 flat) <- return $ flattenTree $ mapTree fromPrim2 t rms <- return $ map (start `repoApply`) flat return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat) diff --git a/harness/Darcs/Test/Patch/Properties/V1Set1.hs b/harness/Darcs/Test/Patch/Properties/V1Set1.hs --- a/harness/Darcs/Test/Patch/Properties/V1Set1.hs +++ b/harness/Darcs/Test/Patch/Properties/V1Set1.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Test.Patch.Properties.V1Set1 ( checkMerge, checkMergeEquiv, checkMergeSwap, checkCanon , checkCommute, checkCantCommute @@ -7,16 +5,17 @@ , tMergeEitherWayValid, tTestCheck ) where import Darcs.Patch - ( Patchy, commute, invert, merge, effect + ( commute, invert, merge, effect , readPatch, showPatch , fromPrim, canonize, sortCoalesceFL ) -import Darcs.Patch.Prim.V1 ( Prim ) +import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Read ( ReadPatch ) -import Darcs.Patch.Show ( ShowPatchBasic ) +import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(..) ) import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check ) -import Darcs.Util.Printer ( renderPS, RenderMode(..) ) +import Darcs.Util.Printer ( renderPS ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Show @@ -27,14 +26,14 @@ import Darcs.Util.Printer ( text ) -type Patch = V1.RepoPatchV1 Prim +type Patch = V1.RepoPatchV1 V1.Prim -quickmerge :: (Patchy p, Merge p) => (p :\/: p ) wX wY -> p wY wZ +quickmerge :: (Merge p) => (p :\/: p ) wX wY -> p wY wZ quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of _ :/\: p1' -> unsafeCoercePEnd p1' -instance MyEq p => Eq ((p :/\: p) wX wY) where +instance Eq2 p => Eq ((p :/\: p) wX wY) where (x :/\: y) == (x' :/\: y') = isIsEq (x =\/= x') && isIsEq (y =\/= y') -- ---------------------------------------------------------------------------- @@ -130,15 +129,15 @@ -- A few "test" properties, doing things with input patches and giving a OK/not -- OK type of answer. -tShowRead :: (Show2 p, Patchy p, ReadPatch p, ShowPatchBasic p) +tShowRead :: (Show2 p, ReadPatch p, ShowPatchBasic p) => (forall wX wY wW wZ . p wX wY -> p wW wZ -> Bool) -> forall wX wY . p wX wY -> TestResult tShowRead eq p = - case readPatch $ renderPS Standard $ showPatch p of + case readPatch $ renderPS $ showPatch ForStorage p of Just (Sealed p') -> if p' `eq` p then succeeded else failed $ text $ "Failed to read shown: "++(show2 p)++"\n" Nothing -> failed $ text $ "Failed to read at all: "++(show2 p)++"\n" -tMergeEitherWayValid :: forall wX wY p . (Check p, Show2 p, Merge p, Patchy p) => (p :\/: p) wX wY -> TestResult +tMergeEitherWayValid :: forall wX wY p . (Check p, Show2 p, Merge p, Invert p) => (p :\/: p) wX wY -> TestResult tMergeEitherWayValid (p1 :\/: p2) = case p2 :>: quickmerge (p1:\/: p2) :>: NilFL of combo2 -> diff --git a/harness/Darcs/Test/Patch/Properties/V1Set2.hs b/harness/Darcs/Test/Patch/Properties/V1Set2.hs --- a/harness/Darcs/Test/Patch/Properties/V1Set2.hs +++ b/harness/Darcs/Test/Patch/Properties/V1Set2.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.Test.Patch.Properties.V1Set2 ( propCommuteInverse, propPatchAndInverseIsIdentity , propSimpleSmartMergeGoodEnough, propCommuteEquivalency @@ -36,7 +33,9 @@ , propUnravelOrderIndependent, propResolveConflictsValid ) where -import Prelude hiding ( pi ) +import Prelude () +import Darcs.Prelude + import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework ( Test ) @@ -46,24 +45,29 @@ import Darcs.Patch ( invert, commute, merge, readPatch, resolveConflicts, - fromPrim, showPatch ) + fromPrim, showPatch, ShowPatchFor(..) ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Invert ( Invert ) import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Patch.V1.Commute ( unravel, merger ) -import Darcs.Patch.Prim.V1 () -import Darcs.Patch.Prim.V1.Core ( Prim(..) ) -import Darcs.Patch.Prim.V1.Commute ( WrappedCommuteFunction(..), Perhaps(..), - subcommutes ) -import Darcs.Util.Printer ( renderPS, RenderMode(..) ) +import Darcs.Patch.Prim.V1 ( Prim ) +import Darcs.Patch.Prim.V1.Commute + ( Perhaps(..) + , toPerhaps + , speedyCommute + , cleverCommute + , commuteFiledir + , commuteFilepatches + ) +import Darcs.Util.Printer ( renderPS ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal, unseal, mapSeal, Sealed2(..) ) import Darcs.Patch.Witnesses.Unsafe -#include "impossible.h" - -type Patch = V1.RepoPatchV1 Prim +type Prim1 = V1.Prim +type Patch = V1.RepoPatchV1 Prim1 -- | Groups a set of tests by giving them the same prefix in their description. @@ -84,7 +88,7 @@ propCommuteTwice :: Sealed2 (FL Patch :> FL Patch) -> Property propCommuteTwice (Sealed2 (p1:>p2)) = (doesCommute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute)) -doesCommute :: (MyEq p, Invert p, Commute p, Check p) => p wX wY -> p wY wZ -> Bool +doesCommute :: (Eq2 p, Invert p, Commute p, Check p) => p wX wY -> p wY wZ -> Bool doesCommute p1 p2 = commute (p1:>p2) /= Nothing && checkAPatch (p1:>:p2:>:NilFL) propCommuteEquivalency :: Sealed2 (FL Patch :> FL Patch) -> Property @@ -208,9 +212,9 @@ and $ map (\l -> (\ml -> checkAPatch (p+>+ml)) `unseal` mergeList l) $ resolveConflicts p -mergeList :: [Sealed (FL Prim wX)] -> Sealed (FL Patch wX) +mergeList :: [Sealed (FL Prim1 wX)] -> Sealed (FL Patch wX) mergeList patches = mapFL_FL fromPrim `mapSeal` doml NilFL patches - where doml :: FL Prim wX wY -> [Sealed (FL Prim wX)] -> Sealed (FL Prim wX) + where doml :: FL Prim1 wX wY -> [Sealed (FL Prim1 wX)] -> Sealed (FL Prim1 wX) doml mp (Sealed p:ps) = case commute (invert p :> mp) of Just (mp' :> _) -> doml (p +>+ mp') ps @@ -218,7 +222,7 @@ doml mp [] = Sealed mp propReadShow :: FL Patch wX wY -> Bool -propReadShow p = case readPatch $ renderPS Standard $ showPatch p of +propReadShow p = case readPatch $ renderPS $ showPatch ForStorage p of Just (Sealed p') -> isIsEq (p' =\/= p) Nothing -> False @@ -234,8 +238,29 @@ Nothing -> False Just (_ :> p1'') -> isIsEq (p1'' =/\= p1) -type CommuteProperty = Sealed2 (Prim :> Prim) -> Property +type CommuteProperty = Sealed2 (Prim1 :> Prim1) -> Property +type CommuteFunction = + forall wX wY . (Prim1 :> Prim1) wX wY -> Perhaps ((Prim1 :> Prim1) wX wY) + +newtype WrappedCommuteFunction = WrappedCommuteFunction + { runWrappedCommuteFunction :: CommuteFunction } + +wrapCommuteFunction :: (forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)) -> WrappedCommuteFunction +wrapCommuteFunction f = WrappedCommuteFunction $ + \(p :> q) -> do + q' :> p' <- f (V1.unPrim p :> V1.unPrim q) + return (V1.Prim q' :> V1.Prim p') + +subcommutes :: [(String, WrappedCommuteFunction)] +subcommutes = + [("speedyCommute", wrapCommuteFunction speedyCommute), + ("commuteFiledir", wrapCommuteFunction (cleverCommute commuteFiledir)), + ("commuteFilepatches", wrapCommuteFunction (cleverCommute commuteFilepatches)), + ("commutex", wrapCommuteFunction (toPerhaps . commute)) + ] + + subcommutesInverse :: [(String, CommuteProperty)] subcommutesInverse = zip names (map prop_subcommute cs) where (names, cs) = unzip subcommutes @@ -297,19 +322,19 @@ Failed -> True _ -> False -doesFail :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool +doesFail :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool doesFail c p1 p2 = fails (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL) where fails Failed = True fails _ = False -does :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool +does :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool does c p1 p2 = succeeds (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL) where succeeds (Succeeded _) = True succeeds _ = False -nontrivial :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool +nontrivial :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool nontrivial c p1 p2 = succeeds (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL) where succeeds (Succeeded (p2' :> p1' )) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2) diff --git a/harness/Darcs/Test/Patch/RepoModel.hs b/harness/Darcs/Test/Patch/RepoModel.hs --- a/harness/Darcs/Test/Patch/RepoModel.hs +++ b/harness/Darcs/Test/Patch/RepoModel.hs @@ -1,5 +1,6 @@ module Darcs.Test.Patch.RepoModel where import Darcs.Patch.Apply ( Apply, ApplyState ) +import Darcs.Patch.Witnesses.Ordered ( FL ) import Test.QuickCheck ( Gen ) type Fail = Either String @@ -21,3 +22,4 @@ type family ModelOf (patch :: * -> * -> *) :: * -> * +type instance ModelOf (FL prim) = ModelOf prim diff --git a/harness/Darcs/Test/Patch/Selection.hs b/harness/Darcs/Test/Patch/Selection.hs --- a/harness/Darcs/Test/Patch/Selection.hs +++ b/harness/Darcs/Test/Patch/Selection.hs @@ -8,8 +8,8 @@ import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.V2 ( RepoPatchV2 ) +import qualified Darcs.Patch.V2.Prim as V2 import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.UI.SelectChanges @@ -26,7 +26,7 @@ -- A test module for interactive patch selection. -type Patch = RepoPatchV2 Prim +type Patch = RepoPatchV2 V2.Prim testSuite :: Test testSuite = testGroup "Darcs.Patch.Selection" $ diff --git a/harness/Darcs/Test/Patch/V1Model.hs b/harness/Darcs/Test/Patch/V1Model.hs --- a/harness/Darcs/Test/Patch/V1Model.hs +++ b/harness/Darcs/Test/Patch/V1Model.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} - - -- | Repository model module Darcs.Test.Patch.V1Model ( V1Model, repoTree @@ -44,14 +41,12 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC -import Data.List ( intercalate ) import qualified Data.Map as M import Test.QuickCheck ( Arbitrary(..) , Gen, choose, vectorOf, frequency ) -#include "impossible.h" - +-- import Text.Show.Pretty ( ppShow ) ---------------------------------------------------------------------- -- * Model definition @@ -76,17 +71,18 @@ ---------------------------------------- -- Instances +data FlatItem = Dir FilePath | File FilePath [String] + deriving Show + +flattenTree :: Tree Fail -> [FlatItem] +flattenTree = map flattenEntry . T.list where + flattenEntry (fn, T.SubTree _) = Dir (BC.unpack (flatten fn)) + flattenEntry (fn, T.File blob) = File (BC.unpack (flatten fn)) + (map BLC.unpack $ BLC.lines $ unFail $ T.readBlob blob) + flattenEntry (_, _) = impossible + instance Show (V1Model wX) where - show repo = "V1Model{ " - ++ intercalate " " (map showEntry $ list repo) - ++ " }" - where - showPath = show . flatten - showContent content = "[" ++ intercalate " " (map show content) ++ "]" - showEntry (path,item) - | isDir item = showPath path - | isFile item = showPath path ++ showContent (fileContent item) - showEntry _ = impossible + show repo = "V1Model " ++ show (flattenTree (repoTree repo)) instance Show1 V1Model where showDict1 = ShowDictClass @@ -276,7 +272,7 @@ -- Small repositories help generating (potentially) conflicting patches. instance RepoModel V1Model where type RepoState V1Model = Tree - showModel m = show m + showModel m = show {- ppShow -} m aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)] dirsNo <- frequency [(3, return 1), (1, return 0)] aRepo filesNo dirsNo diff --git a/harness/Darcs/Test/Patch/WSub.hs b/harness/Darcs/Test/Patch/WSub.hs --- a/harness/Darcs/Test/Patch/WSub.hs +++ b/harness/Darcs/Test/Patch/WSub.hs @@ -30,11 +30,14 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart, unsafeCoercePEnd ) import Darcs.Patch.Merge ( Merge ) -import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.V2 ( RepoPatchV2 ) -import Darcs.Patch.Patchy ( Commute, Invert(..) ) +import qualified Darcs.Patch.V2.Prim as V2 +import Darcs.Patch.Commute ( Commute ) +import Darcs.Patch.Invert ( Invert(..) ) +type Prim2 = V2.Prim + infixr 5 :>: infixr 5 +>+ infixr 1 :> @@ -85,7 +88,7 @@ fromW = id toW = id -instance WSub Prim Prim where +instance WSub Prim2 Prim2 where fromW = id toW = id @@ -107,7 +110,7 @@ instance (WSub wp p, Show2 wp) => Show2 (FL p) where showDict2 = ShowDictClass -instance (WSub wp p, Commute wp, MyEq wp) => MyEq (FL p) where +instance (WSub wp p, Commute wp, Eq2 wp) => Eq2 (FL p) where unsafeCompare x y = unsafeCompare (toW x) (toW y) instance (WSub wp p, Commute wp, Invert wp) => Invert (FL p) where @@ -126,12 +129,12 @@ commute :: (WSub wp p, Commute wp) => (p :> p) wX wY -> Maybe ((p :> p) wX wY) commute = fmap fromW . W.commute . toW -getPairs :: FL (RepoPatchV2 Prim) wX wY -> [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim)] +getPairs :: FL (RepoPatchV2 Prim2) wX wY -> [Sealed2 (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2)] getPairs = map (mapSeal2 fromW) . W.getPairs . toW -getTriples :: FL (RepoPatchV2 Prim) wX wY -> [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim)] +getTriples :: FL (RepoPatchV2 Prim2) wX wY -> [Sealed2 (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2 :> RepoPatchV2 Prim2)] getTriples = map (mapSeal2 fromW) . W.getTriples . toW -coalesce :: (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY) +coalesce :: (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY) coalesce = fmap fromW . W.coalesce . toW diff --git a/harness/Darcs/Test/Patch/WithState.hs b/harness/Darcs/Test/Patch/WithState.hs --- a/harness/Darcs/Test/Patch/WithState.hs +++ b/harness/Darcs/Test/Patch/WithState.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} module Darcs.Test.Patch.WithState diff --git a/harness/Darcs/Test/Repository/Inventory.hs b/harness/Darcs/Test/Repository/Inventory.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Repository/Inventory.hs @@ -0,0 +1,159 @@ +module Darcs.Test.Repository.Inventory where + +import Darcs.Repository.Inventory + ( Inventory(..) + , HeadInventory + , ValidHash(..) + , InventoryHash + , PatchHash + , PristineHash + , getValidHash + , mkValidHash + , parseInventory + , showInventory + , skipPristineHash + , peekPristineHash + , pokePristineHash + , prop_inventoryParseShow + , prop_peekPokePristineHash + , prop_skipPokePristineHash + ) +import Darcs.Patch.Info ( rawPatchInfo ) +import Darcs.Util.Printer ( renderPS ) + +import Darcs.Test.Patch.Info () + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Test.Framework ( Test, testGroup ) +import Test.Framework.Providers.HUnit ( testCase ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.HUnit ( Assertion, (@=?) ) +import Test.QuickCheck + +testSuite :: Test +testSuite = testGroup "Darcs.Repository.Inventory" + [ testProperty "parse/show roundtrips" prop_inventoryParseShow + , testProperty "peek gets back what we poked" prop_peekPokePristineHash + , testProperty "skip/poke roundtrips" prop_skipPokePristineHash + , testCase "example1" (testInventory rawHeadInv1 headInv1) + , testCase "example2" (testInventory rawHeadInv2 headInv2) + ] + +instance Arbitrary B.ByteString where + arbitrary = B.pack <$> arbitrary + +instance Arbitrary Inventory where + arbitrary = uncurry Inventory <$> arbitrary + +instance Arbitrary InventoryHash where + arbitrary = arbitraryHash +instance Arbitrary PatchHash where + arbitrary = arbitraryHash +instance Arbitrary PristineHash where + arbitrary = arbitraryHash + +arbitraryHash :: ValidHash h => Gen h +arbitraryHash = mkValidHash <$> do + n <- elements [64, 75] -- see D.R.Cache.okayHash + vectorOf n $ elements $ '-' : (['0'..'9'] ++ ['a'..'f']) + +testInventory :: B.ByteString -> HeadInventory -> Assertion +testInventory raw (vhash,inv) = do + let hash = getValidHash vhash + hash @=? peekPristineHash raw + let rest = skipPristineHash raw + Just inv @=? parseInventory rest + rest @=? renderPS (showInventory inv) + raw @=? renderPS (pokePristineHash hash rest) + +headInv1 :: HeadInventory +headInv1 = + ( mkValidHash "57fb9c1abbed1c0b880e2fffebe32a2163762b87e67e9bf4dcd3168e5abcad83" + , Inventory + { inventoryParent = Nothing + , inventoryPatches = + [ ( rawPatchInfo + "20180311141206" + "Add d/f and e." + "tester" + [ "Ignore-this: b541ff7ea385297c8ad07fe58016efa8" ] + False + , mkValidHash + "0000000154-703d7811c2e3f1e1aa81e4be5fab31a291cc18158ec8a75733b6faa5fb406286" + ) + , ( rawPatchInfo + "20180311141206" + "Move d/f to e/f." + "tester" + [ "Ignore-this: b71452c8a91c573f7e7fa2e8eb34afd1" ] + False + , mkValidHash + "0000000106-4b1bc6db02d2eea04efe888b64ce853a416c14ae1ae43550b0137f11a8a8dfee" + ) + ] + } + ) + +rawHeadInv1 :: B.ByteString +rawHeadInv1 = BC.pack + "pristine:57fb9c1abbed1c0b880e2fffebe32a2163762b87e67e9bf4dcd3168e5abcad83\n\ + \[Add d/f and e.\n\ + \tester**20180311141206\n\ + \ Ignore-this: b541ff7ea385297c8ad07fe58016efa8\n\ + \] \n\ + \hash: 0000000154-703d7811c2e3f1e1aa81e4be5fab31a291cc18158ec8a75733b6faa5fb406286\n\ + \[Move d/f to e/f.\n\ + \tester**20180311141206\n\ + \ Ignore-this: b71452c8a91c573f7e7fa2e8eb34afd1\n\ + \] \n\ + \hash: 0000000106-4b1bc6db02d2eea04efe888b64ce853a416c14ae1ae43550b0137f11a8a8dfee\n\ + \" + +headInv2 :: HeadInventory +headInv2 = + ( mkValidHash "f2f70f1326252fc53077d7cd71769f405618829ba40a8f00f112ac97213f5f4b" + , Inventory + { inventoryParent = + Just + (mkValidHash + "0000220070-6ef010a955c38fc4301787092979994bafd366eb50152b66e089deff649d35da") + , inventoryPatches = + [ ( rawPatchInfo + "20160429142058" + "TAG 2.12.0" + "Guillaume Hoffmann " + [ "Ignore-this: 5c8cbe0424942686a2168f9e6fd8e35d" ] + False + , mkValidHash + "0000088075-e1cc4489099cfff1df5875a8146dc012110c156f3dad839f4632d62ee2331e43" + ) + , ( rawPatchInfo + "20160429143015" + "bump version to 2.13.0" + "Guillaume Hoffmann " + [ "Ignore-this: 7468e30e96f3bf833f4e374e9cc7e515" ] + False + , mkValidHash + "0000000198-0f5455b7c229e132a2fc2173dcce2b567f806c1d3eb1c37fd9fe8d8e42ef4fc9" + ) + ] + } + ) + +rawHeadInv2 :: B.ByteString +rawHeadInv2 = BC.pack + "pristine:f2f70f1326252fc53077d7cd71769f405618829ba40a8f00f112ac97213f5f4b\n\ + \Starting with inventory:\n\ + \0000220070-6ef010a955c38fc4301787092979994bafd366eb50152b66e089deff649d35da\n\ + \[TAG 2.12.0\n\ + \Guillaume Hoffmann **20160429142058\n\ + \ Ignore-this: 5c8cbe0424942686a2168f9e6fd8e35d\n\ + \] \n\ + \hash: 0000088075-e1cc4489099cfff1df5875a8146dc012110c156f3dad839f4632d62ee2331e43\n\ + \[bump version to 2.13.0\n\ + \Guillaume Hoffmann **20160429143015\n\ + \ Ignore-this: 7468e30e96f3bf833f4e374e9cc7e515\n\ + \] \n\ + \hash: 0000000198-0f5455b7c229e132a2fc2173dcce2b567f806c1d3eb1c37fd9fe8d8e42ef4fc9\n\ + \" diff --git a/harness/Darcs/Test/Util/TestResult.hs b/harness/Darcs/Test/Util/TestResult.hs --- a/harness/Darcs/Test/Util/TestResult.hs +++ b/harness/Darcs/Test/Util/TestResult.hs @@ -1,4 +1,3 @@ - module Darcs.Test.Util.TestResult ( TestResult , succeeded @@ -8,56 +7,51 @@ , fromMaybe , isOk , isFailed - ) - where - + ) where -import Darcs.Util.Printer ( Doc, renderString, RenderMode(..) ) +import Darcs.Util.Printer (Doc, renderString) import qualified Test.QuickCheck.Property as Q - - -data TestResult = TestSucceeded - | TestFailed Doc - | TestRejected -- ^ Rejects test case - +data TestResult + = TestSucceeded + | TestFailed Doc + | TestRejected succeeded :: TestResult succeeded = TestSucceeded -failed :: Doc -- ^ Error message - -> TestResult +failed :: Doc -> TestResult failed = TestFailed rejected :: TestResult rejected = TestRejected --- | @t <&&> s@ fails <=> t or s fails --- @t <&&> s@ succeeds <=> none fails and some succeeds --- @t <&&> s@ is rejected <=> both are rejected +-- | Succeed even if one of the arguments is rejected. (<&&>) :: TestResult -> TestResult -> TestResult -t@(TestFailed _) <&&> _s = t -_t <&&> s@(TestFailed _) = s -TestRejected <&&> s = s -t <&&> TestRejected = t -TestSucceeded <&&> TestSucceeded = TestSucceeded +t@(TestFailed _) <&&> _s = t +_t <&&> s@(TestFailed _) = s +TestRejected <&&> s = s +t <&&> TestRejected = t +TestSucceeded <&&> TestSucceeded = TestSucceeded -- | 'Nothing' is considered success whilst 'Just' is considered failure. fromMaybe :: Maybe Doc -> TestResult -fromMaybe Nothing = succeeded +fromMaybe Nothing = succeeded fromMaybe (Just errMsg) = failed errMsg isFailed :: TestResult -> Bool isFailed (TestFailed _) = True -isFailed _other = False +isFailed _other = False --- | A test is considered OK if it does not fail. +-- | A test is considered Ok if it does not fail. isOk :: TestResult -> Bool isOk = not . isFailed - -- 'Testable' instance is defined by converting 'TestResult' to 'QuickCheck.Property.Result' +-- | 'Testable' instance is defined by converting 'TestResult' to +-- 'QuickCheck.Property.Result' instance Q.Testable TestResult where - property TestSucceeded = Q.property Q.succeeded - property (TestFailed errorMsg) = Q.property (Q.failed{Q.reason = renderString Encode errorMsg}) - property TestRejected = Q.property Q.rejected + property TestSucceeded = Q.property Q.succeeded + property (TestFailed errorMsg) = + Q.property (Q.failed {Q.reason = renderString errorMsg}) + property TestRejected = Q.property Q.rejected diff --git a/harness/Storage/Hashed/Test.hs b/harness/Storage/Hashed/Test.hs deleted file mode 100644 --- a/harness/Storage/Hashed/Test.hs +++ /dev/null @@ -1,542 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Storage.Hashed.Test( tests ) where - -import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) ) -import qualified Prelude -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS -import System.Directory( doesFileExist, removeFile, doesDirectoryExist - , createDirectory, removeDirectoryRecursive - , setCurrentDirectory ) -import System.FilePath( () ) -import Control.Monad.Identity -import Control.Monad.Trans( lift ) -import Control.Applicative( (<$>) ) -import Control.Exception ( catch, IOException ) -import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) - -import Data.Maybe -import Data.Word -import Data.List( sort, intercalate, intersperse ) - -import Darcs.Util.Path hiding ( setCurrentDirectory ) -import Darcs.Util.Tree hiding ( lookup ) -import Darcs.Util.Index -import Darcs.Util.Tree.Hashed -import Darcs.Util.Hash -import Darcs.Util.Tree.Monad hiding ( tree, createDirectory ) -import Darcs.Util.Tree.Plain - -import System.Mem( performGC ) - -import qualified Data.Set as S -import qualified Data.Map as M - -import qualified Bundled.Posix as Posix - ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) - -import Test.HUnit hiding ( path ) -import Test.Framework( testGroup ) -import qualified Test.Framework as TF ( Test ) -import Test.QuickCheck - -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 - ------------------------- --- Test Data --- - -blobs :: [(AnchoredPath, BL.ByteString)] -blobs = [ (floatPath "foo_a", BL.pack "a\n") - , (floatPath "foo_dir/foo_a", BL.pack "a\n") - , (floatPath "foo_dir/foo_b", BL.pack "b\n") - , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") - , (floatPath "foo space/foo\nnewline", BL.pack "newline\n") - , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n") - , (floatPath "foo space/foo_a", BL.pack "a\n") ] - -files :: [AnchoredPath] -files = map fst blobs - -dirs :: [AnchoredPath] -dirs = [ floatPath "foo_dir" - , floatPath "foo_dir/foo_subdir" - , floatPath "foo space" ] - -emptyStub :: TreeItem IO -emptyStub = Stub (return emptyTree) NoHash - -testTree :: Tree IO -testTree = - makeTree [ (makeName "foo", emptyStub) - , (makeName "subtree", SubTree sub) - , (makeName "substub", Stub getsub NoHash) ] - where sub = makeTree [ (makeName "stub", emptyStub) - , (makeName "substub", Stub getsub2 NoHash) - , (makeName "x", SubTree emptyTree) ] - getsub = return sub - getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) - , (makeName "file2", - File $ Blob (return $ BL.pack "foo") NoHash) ] - -equals_testdata :: Tree IO -> IO () -equals_testdata t = sequence_ [ - do isJust (findFile t p) @? show p ++ " in tree" - ours <- readBlob (fromJust $ findFile t p) - ours @?= stored - | (p, stored) <- blobs ] >> - sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree" - | (p, File _) <- list t ] - ---------------------------- --- Test list --- - -tests :: [TF.Test] -tests = [ testGroup "Bundled.Posix" posix - , testGroup "Darcs.Util.Hash" hash - , testGroup "Darcs.Util.Tree" tree - , testGroup "Darcs.Util.Index" index - , testGroup "Darcs.Util.Tree.Monad" monad - , testGroup "Hashed Storage" hashed ] - --------------------------- --- Tests --- - -hashed :: [TF.Test] -hashed = [ testCase "plain has all files" have_files - , testCase "pristine has all files" have_pristine_files - , testCase "pristine has no extras" pristine_no_extra - , testCase "pristine file contents match" pristine_contents - , testCase "plain file contents match" plain_contents - , testCase "writePlainTree works" write_plain ] - where - check_file t f = assertBool - ("path " ++ show f ++ " is missing in tree " ++ show t) - (isJust $ find t f) - check_files = forM_ files . check_file - - pristine_no_extra = extractRepoAndRun $ - do - t <- readDarcsPristine "." >>= expand - forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") - (path `elem` (dirs ++ files)) - have_files = extractRepoAndRun ( readPlainTree "." >>= expand >>= check_files ) - have_pristine_files = extractRepoAndRun ( readDarcsPristine "." >>= expand >>= check_files ) - - pristine_contents = extractRepoAndRun $ - do - t <- readDarcsPristine "." >>= expand - equals_testdata t - - plain_contents = extractRepoAndRun $ - do - t <- expand =<< filter nondarcs `fmap` readPlainTree "." - equals_testdata t - - write_plain = extractRepoAndRun $ - do - orig <- readDarcsPristine "." >>= expand - writePlainTree orig "_darcs/plain" - t <- expand =<< readPlainTree "_darcs/plain" - equals_testdata t - -index :: [TF.Test] -index = [ testCase "index versioning" check_index_versions - , testCase "index listing" check_index - , testCase "index content" check_index_content - , testProperty "xlate32" prop_xlate32 - , testProperty "xlate64" prop_xlate64 - , testProperty "align bounded" prop_align_bounded - , testProperty "align aligned" prop_align_aligned ] - where pristine = readDarcsPristine "." >>= expand - build_index = - do x <- pristine - exist <- doesFileExist "_darcs/index" - performGC -- required in win32 to trigger file close - when exist $ removeFile "_darcs/index" - idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x - return (x, idx) - check_index = extractRepoAndRun $ - do (pris, idx) <- build_index - (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) - check_blob_pair p x y = - do a <- readBlob x - b <- readBlob y - assertEqual ("content match on " ++ show p) a b - check_index_content = extractRepoAndRun $ - do (_, idx) <- build_index - plain <- readPlainTree "." - x <- sequence $ zipCommonFiles check_blob_pair plain idx - assertBool "files match" (length x > 0) - check_index_versions = extractRepoAndRun $ - do performGC -- required in win32 to trigger file close - Prelude.writeFile "_darcs/index" "nonsense index... do not crash!" - valid <- indexFormatValid "_darcs/index" - assertBool "index format invalid" $ not valid - prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32 - prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64 - prop_align_bounded (bound, x) = - bound > 0 && bound < 1024 && x >= 0 ==> - align bound x >= x && align bound x < x + bound - where _types = (bound, x) :: (Int, Int) - prop_align_aligned (bound, x) = - bound > 0 && bound < 1024 && x >= 0 ==> - align bound x `rem` bound == 0 - where _types = (bound, x) :: (Int, Int) - -tree :: [TF.Test] -tree = [ testCase "modifyTree" check_modify - , testCase "complex modifyTree" check_modify_complex - , testCase "modifyTree removal" check_modify_remove - , testCase "expand" check_expand - , testCase "expandPath" check_expand_path - , testCase "expandPath of sub" check_expand_path_sub - , testCase "diffTrees" check_diffTrees - , testCase "diffTrees identical" check_diffTrees_ident - , testProperty "expandPath" prop_expandPath - , testProperty "shapeEq" prop_shape_eq - , testProperty "expandedShapeEq" prop_expanded_shape_eq - , testProperty "expand is identity" prop_expand_id - , testProperty "filter True is identity" prop_filter_id - , testProperty "filter False is empty" prop_filter_empty - , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative - , testProperty "restrict is a subtree of both" prop_restrict_subtree - , testProperty "overlay keeps shape" prop_overlay_shape - , testProperty "overlay is superset of over" prop_overlay_super ] - where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x) - name = Name . BS.pack - check_modify = - let t = makeTree [(name "foo", blob "bar")] - modify = modifyTree t (floatPath "foo") (Just $ blob "bla") - in do x <- readBlob $ fromJust $ findFile t (floatPath "foo") - y <- readBlob $ fromJust $ findFile modify (floatPath "foo") - assertEqual "old version" x (BL.pack "bar") - assertEqual "new version" y (BL.pack "bla") - assertBool "list has foo" $ - isJust (Prelude.lookup (floatPath "foo") $ list modify) - length (list modify) @?= 1 - check_modify_complex = - let t = makeTree [ (name "foo", blob "bar") - , (name "bar", SubTree t1) ] - t1 = makeTree [ (name "foo", blob "bar") ] - modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") - in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo") - foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo") - bar_foo <- readBlob $ fromJust $ - findFile t (floatPath "bar/foo") - bar_foo' <- readBlob $ fromJust $ - findFile modify (floatPath "bar/foo") - assertEqual "old foo" foo (BL.pack "bar") - assertEqual "old bar/foo" bar_foo (BL.pack "bar") - assertEqual "new foo" foo' (BL.pack "bar") - assertEqual "new bar/foo" bar_foo' (BL.pack "bla") - assertBool "list has bar/foo" $ - isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) - assertBool "list has foo" $ - isJust (Prelude.lookup (floatPath "foo") $ list modify) - length (list modify) @?= length (list t) - check_modify_remove = - let t1 = makeTree [(name "foo", blob "bar")] - t2 :: Tree Identity = makeTree [ (name "foo", blob "bar") - , (name "bar", SubTree t1) ] - modify1 = modifyTree t1 (floatPath "foo") Nothing - modify2 = modifyTree t2 (floatPath "bar") Nothing - file = findFile modify1 (floatPath "foo") - subtree = findTree modify2 (floatPath "bar") - in do assertBool "file is gone" (isNothing file) - assertBool "subtree is gone" (isNothing subtree) - - no_stubs t = null [ () | (_, Stub _ _) <- list t ] - path = floatPath "substub/substub/file" - badpath = floatPath "substub/substub/foo" - check_expand = do - x <- expand testTree - assertBool "no stubs in testTree" $ not (no_stubs testTree) - assertBool "stubs in expanded tree" $ no_stubs x - assertBool "path reachable" $ path `elem` (map fst $ list x) - assertBool "badpath not reachable" $ - badpath `notElem` (map fst $ list x) - check_expand_path = do - test_exp <- expand testTree - t <- expandPath testTree path - t' <- expandPath test_exp path - t'' <- expandPath testTree $ floatPath "substub/x" - assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) - assertBool "path reachable in t" $ path `elem` (map fst $ list t) - assertBool "path reachable in t'" $ path `elem` (map fst $ list t') - assertBool "path reachable in t (with findFile)" $ - isJust $ findFile t path - assertBool "path reachable in t' (with findFile)" $ - isJust $ findFile t' path - assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') - assertBool "badpath not reachable in t" $ - badpath `notElem` (map fst $ list t) - assertBool "badpath not reachable in t'" $ - badpath `notElem` (map fst $ list t') - - check_expand_path_sub = do - t <- expandPath testTree $ floatPath "substub" - t' <- expandPath testTree $ floatPath "substub/stub" - t'' <- expandPath testTree $ floatPath "subtree/stub" - assertBool "leaf is not a Stub" $ - isNothing (findTree testTree $ floatPath "substub") - assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") - assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") - assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") - - check_diffTrees = extractRepoAndRun $ - do Prelude.writeFile "foo_dir/foo_a" "b\n" - working_plain <- filter nondarcs `fmap` readPlainTree "." - working <- updateIndex =<< - updateIndexFrom "_darcs/index" darcsTreeHash working_plain - pristine <- readDarcsPristine "." - (working', pristine') <- diffTrees working pristine - let foo_work = findFile working' (floatPath "foo_dir/foo_a") - foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") - working' `shapeEq` pristine' - @? show working' ++ " `shapeEq` " ++ show pristine' - assertBool "foo_dir/foo_a is in working'" $ isJust foo_work - assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris - foo_work_c <- readBlob (fromJust foo_work) - foo_pris_c <- readBlob (fromJust foo_pris) - BL.unpack foo_work_c @?= "b\n" - BL.unpack foo_pris_c @?= "a\n" - assertEqual "working' tree is minimal" 2 (length $ list working') - assertEqual "pristine' tree is minimal" 2 (length $ list pristine') - - check_diffTrees_ident = do - pristine <- readDarcsPristine "." - (t1, t2) <- diffTrees pristine pristine - assertBool "t1 is empty" $ null (list t1) - assertBool "t2 is empty" $ null (list t2) - - prop_shape_eq x = no_stubs x ==> x `shapeEq` x - where _types = x :: Tree Identity - prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x - where _types = x :: Tree Identity - prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x - where _types = x :: Tree Identity - prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x - where _types = x :: Tree Identity - prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x - where _types = x :: Tree Identity - prop_restrict_shape_commutative (t1, t2) = - no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> - restrict t1 t2 `shapeEq` restrict t2 t1 - where _types = (t1 :: Tree Identity, t2 :: Tree Identity) - prop_restrict_subtree (t1, t2) = - no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==> - let restricted = S.fromList (map fst $ list $ restrict t1 t2) - orig1 = S.fromList (map fst $ list t1) - orig2 = S.fromList (map fst $ list t2) - in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] - where _types = (t1 :: Tree Identity, t2 :: Tree Identity) - prop_overlay_shape (t1 :: Tree Identity, t2) = - (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> - runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 - prop_overlay_super (t1 :: Tree Identity, t2) = - (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==> - Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) - prop_expandPath (TreeWithPath t p) = - notStub $ find (runIdentity $ expandPath t p) p - where notStub (Just (Stub _ _)) = False - notStub Nothing = error "Did not exist." - notStub _ = True - -hash :: [TF.Test] -hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 ] - where prop_base16 x = (decodeBase16 . encodeBase16) x == x - -monad :: [TF.Test] -monad = [ testCase "path expansion" check_virtual - , testCase "rename" check_rename ] - where check_virtual = virtualTreeMonad run testTree >> return () - where run = do file <- readFile (floatPath "substub/substub/file") - file2 <- readFile (floatPath "substub/substub/file2") - lift $ BL.unpack file @?= "" - lift $ BL.unpack file2 @?= "foo" - check_rename = do (_, t) <- virtualTreeMonad run testTree - t' <- darcsAddMissingHashes =<< expand t - forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> - assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash - where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") - -posix :: [TF.Test] -posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus - , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] - where check_stat fun = extractRepoAndRun $ do - x <- Posix.fileSize `fmap` fun "foo_a" - Prelude.writeFile "test_empty" "" - y <- Posix.fileSize `fmap` fun "test_empty" - exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" - exist_existent <- Posix.fileExists `fmap` fun "test_empty" - assertEqual "file size" x 2 - assertEqual "file size" y 0 - assertBool "existence check" $ not exist_nonexistent - assertBool "existence check" exist_existent - ----------------------------------- --- Arbitrary instances --- - -#if !MIN_VERSION_QuickCheck(2,8,2) --- these instances were added to QuickCheck itself in version 2.8.2 -instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) - where arbitrary = S.fromList `fmap` arbitrary - -instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) - where arbitrary = M.fromList `fmap` arbitrary -#endif - -instance Arbitrary BL.ByteString where - arbitrary = BL.pack `fmap` arbitrary - -instance Arbitrary Hash where - arbitrary = sized hash' - where hash' 0 = return NoHash - hash' _ = do - tag <- oneof [return False, return True] - case tag of - False -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ] - True -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] :: [Int] ] - -instance (Monad m) => Arbitrary (TreeItem m) where - arbitrary = sized tree' - where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] - tree' n = oneof [ file n, subtree n ] - file 0 = return (File emptyBlob) - file _ = do content <- arbitrary - return (File $ Blob (return content) NoHash) - subtree n = do branches <- choose (1, n) - let sub name = do t <- tree' ((n - 1) `div` branches) - return (makeName $ show name, t) - sublist <- mapM sub [0..branches] - oneof [ tree' 0 - , return (SubTree $ makeTree sublist) - , return $ (Stub $ return (makeTree sublist)) NoHash ] - -instance (Monad m) => Arbitrary (Tree m) where - arbitrary = do item <- arbitrary - case item of - File _ -> arbitrary - Stub _ _ -> arbitrary - SubTree t -> return t - -data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show) - -instance Arbitrary TreeWithPath where - arbitrary = do t <- arbitrary - p <- oneof $ return (AnchoredPath []) : - (map (return . fst) $ list (runIdentity $ expand t)) - return $ TreeWithPath t p - ---------------------------- --- Other instances --- - -instance Show (Blob m) where - show (Blob _ h) = "Blob " ++ show h - -instance Show (TreeItem m) where - show (File f) = "File (" ++ show f ++ ")" - show (Stub _ h) = "Stub _ " ++ show h - show (SubTree s) = "SubTree (" ++ show s ++ ")" - -instance Show (Tree m) where - show t = "Tree " ++ show (treeHash t) ++ " { " ++ - (concat . intersperse ", " $ itemstrs) ++ " }" - where itemstrs = map show $ listImmediate t - -instance Show (Int -> Int) where - show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" - where val x = show x ++ " -> " ++ show (f x) - ------------------------ --- Test utilities --- - -shapeEq :: Tree m -> Tree m -> Bool -shapeEq a b = Just EQ == cmpShape a b - -expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool -expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b - -cmpcat :: [Maybe Ordering] -> Maybe Ordering -cmpcat (x:y:rest) | x == y = cmpcat (x:rest) - | x == Just EQ = cmpcat (y:rest) - | y == Just EQ = cmpcat (x:rest) - | otherwise = Nothing -cmpcat [x] = x -cmpcat [] = Just EQ -- empty things are equal - -cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering) -cmpTree x y = do x' <- expand x - y' <- expand y - con <- contentsEq x' y' - return $ cmpcat [cmpShape x' y', con] - where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) - cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a - b' <- readBlob b - return $ Just (compare a' b') - cmp _ _ _ = return (Just EQ) -- neutral - -cmpShape :: Tree m -> Tree m -> Maybe Ordering -cmpShape t r = cmpcat $ zipTrees cmp t r - where cmp _ (Just a) (Just b) = a `item` b - cmp _ Nothing (Just _) = Just LT - cmp _ (Just _) Nothing = Just GT - cmp _ Nothing Nothing = Just EQ - item (File _) (File _) = Just EQ - item (SubTree s) (SubTree p) = s `cmpShape` p - item _ _ = Nothing - -cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) -cmpExpandedShape a b = do x <- expand a - y <- expand b - return $ x `cmpShape` y - -nondarcs :: AnchoredPath -> TreeItem m -> Bool -nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False - | otherwise = True -nondarcs (AnchoredPath []) _ = True - -readDarcsPristine :: FilePath -> IO (Tree IO) -readDarcsPristine dir = do - let darcs = dir "_darcs" - h_inventory = darcs "hashed_inventory" - repo <- doesDirectoryExist darcs - unless repo $ fail $ "Not a darcs repository: " ++ dir - isHashed <- doesFileExist h_inventory - if isHashed - then do inv <- BS.readFile h_inventory - let thelines = BS.split '\n' inv - case thelines of - [] -> return emptyTree - (pris_line:_) -> do - let thehash = decodeDarcsHash $ BS.drop 9 pris_line - thesize = decodeDarcsSize $ BS.drop 9 pris_line - when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line - readDarcsHashed (darcs "pristine.hashed") (thesize, thehash) - 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!" - -extractRepoAndRun :: IO a -> IO a -extractRepoAndRun action = - do zipFile <- toArchive `fmap` BL.readFile "harness/hstestdata.zip" - removeDirectoryRecursive "_test_playground" `catch` \(_ :: IOException) -> return () - createDirectory "_test_playground" - setCurrentDirectory "_test_playground" - extractFilesFromArchive [] zipFile - result <- action - setCurrentDirectory ".." - removeDirectoryRecursive "_test_playground" - return result - diff --git a/harness/test.hs b/harness/test.hs --- a/harness/test.hs +++ b/harness/test.hs @@ -3,26 +3,16 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main ( main ) where -#ifdef DISABLE_TESTING -main :: IO () -main = fail $ "test infrastructure not built," - ++ " please pass --enable-tests to configure, then rebuild" -#else - import qualified Darcs.Test.Misc import qualified Darcs.Test.Patch import qualified Darcs.Test.Email -import qualified Storage.Hashed.Test +import qualified Darcs.Test.Repository.Inventory +import qualified Darcs.Test.HashedStorage import Control.Monad ( filterM ) import Control.Exception ( SomeException ) -import qualified Control.Monad.Trans import Data.Text ( Text, pack, unpack ) -import Data.Char ( toLower ) import Data.List ( isPrefixOf, isSuffixOf, sort ) -import Data.List.Split ( splitOn ) -import qualified Data.ByteString.Char8 as B -import Data.Maybe ( fromMaybe ) import GHC.IO.Encoding ( textEncodingName ) import System.Console.CmdArgs hiding ( args ) import System.Directory ( doesFileExist ) @@ -40,13 +30,14 @@ -- | TODO make runnable in parallel doHashed :: IO [Test] -doHashed = return Storage.Hashed.Test.tests +doHashed = return Darcs.Test.HashedStorage.tests -- | This is the big list of tests that will be run using testrunner. unitTests :: [Test] unitTests = [ Darcs.Test.Email.testSuite , Darcs.Test.Misc.testSuite + , Darcs.Test.Repository.Inventory.testSuite ] ++ Darcs.Test.Patch.testSuite -- ---------------------------------------------------------------------- @@ -72,7 +63,7 @@ , testfile :: FilePath , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly , _darcspath :: FilePath - , _diffalgorithm :: DiffAlgorithm + , diffalgorithm :: DiffAlgorithm } deriving Typeable @@ -104,17 +95,15 @@ case code of 200 -> return Skipped _ -> Failed <$> unpack <$> lastStderr - where defaults = pack $ unlines (["ALL " ++ fmtstr, "send no-edit-description", "ALL ignore-times"] ++ dcs) + where defaults = pack $ unlines + [ "ALL " ++ fmtstr + , "send no-edit-description" + , "ALL ignore-times" + , "ALL " ++ daf + ] fmtstr = case fmt of Darcs2 -> "darcs-2" Darcs1 -> "darcs-1" - dcs = [dc ++ " " ++ daf | dc <- ["revert","unrevert", "whatsnew", - "record", "unpull", "obliterate", - "amend-record", "mark-conflicts", - "rebase", "pull", "repair", - "rollback", "apply", - "rebase pull", "rebase suspend", - "rebase unsuspend", "rebase obliterate"] ] daf = case da of PatienceDiff -> "patience" MyersDiff -> "myers" @@ -125,33 +114,19 @@ pathVarSeparator = ":" #endif --- TODO: add a 'all' option (implement using an Enum instance)? -readOptionList :: (String -> a) -> (String -> [a]) -readOptionList readElem str = map readElem (splitOn "," str) - -readDiffAlgorithm :: String -> DiffAlgorithm -readDiffAlgorithm (map toLower -> "myers") = MyersDiff -readDiffAlgorithm (map toLower -> "patience") = PatienceDiff -readDiffAlgorithm _ = error "Valid diff algorithms: myers, patience" - -readRepoFormat :: String -> Format -readRepoFormat (map toLower -> "darcs-1") = Darcs1 -readRepoFormat (map toLower -> "darcs-2") = Darcs2 -readRepoFormat _ = error "Valid repo formats: darcs-1, darcs-2" - runtest :: ShellTest -> Sh Result runtest t = withTmp $ \dir -> do cp "tests/lib" dir cp "tests/network/sshlib" dir - cp ("tests" testfile t) (dir "test") + cp (fromText $ pack $ testfile t) (dir "test") srcdir <- pwd silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir) where withTmp = case testdir t of Just dir -> \job -> do - let d = (dir show (format t) takeBaseName (testfile t)) + let d = (dir show (format t) show (diffalgorithm t) takeBaseName (testfile t)) mkdir_p d job d Nothing -> withTmpDir @@ -162,53 +137,22 @@ liftIO (shelly $ runtest test) shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test -shellTest dp fmt tdir file da = Test (file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $ ShellTest fmt file tdir dp da - -hasPrefix :: B.ByteString -> B.ByteString -> Maybe B.ByteString -hasPrefix prefix = - let len = B.length prefix in - \str -> if B.take len str == prefix then Just (B.drop len str) else Nothing +shellTest dp fmt tdir file da = + Test (takeBaseName file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $ + ShellTest fmt file tdir dp da toString :: Shelly.FilePath -> String toString = unpack . toTextIgnore --- use of a pragma in a test script overrides the user's selection for that particular test, --- based on the assumption that the test author knows best -parsePragmas :: FilePath -> FilePath -> IO (FilePath, (Maybe [DiffAlgorithm], Maybe [Format])) -parsePragmas path file = do - contents <- B.lines <$> B.readFile (toString $ path file) - let parseLine - (_diffAlgorithms, repoFormats) - (hasPrefix (B.pack "#pragma diff-algorithm ") -> Just (readOptionList readDiffAlgorithm . B.unpack -> newDiffAlgorithms)) - = (Just newDiffAlgorithms, repoFormats) - parseLine - (diffAlgorithms, _repoFormats) - (hasPrefix (B.pack "#pragma repo-format ") -> Just (readOptionList readRepoFormat . B.unpack -> newRepoFormats)) - = (diffAlgorithms, Just newRepoFormats) - parseLine _ (hasPrefix (B.pack "#pragma ") -> Just pragma) = error $ "Unknown pragma " ++ B.unpack pragma ++ " in " ++ (toString $ path file) - parseLine x _ = x - pragmas = foldl parseLine (Nothing, Nothing) contents - return (file, pragmas) - -findShell :: FilePath -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test] -findShell dp tdir isFailing diffAlgorithmsDefault repoFormatsDefault = - do allFiles <- map (drop (length ("tests/"::String)) . toString) <$> ls (fromText "tests") - let files = sort $ filter relevant $ filter (".sh" `isSuffixOf`) allFiles - annotatedFiles <- Control.Monad.Trans.liftIO $ mapM (parsePragmas "tests") files +findShell :: FilePath -> Text -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test] +findShell dp sdir tdir isFailing diffAlgorithms repoFormats = + do files <- ls (fromText sdir) + let test_files = sort $ filter relevant $ filter (hasExt "sh") files return [ shellTest dp fmt tdir file da - | (file, (diffAlgorithmsPragma, repoFormatsPragma)) <- annotatedFiles - , fmt <- fromMaybe repoFormatsDefault repoFormatsPragma - , da <- fromMaybe diffAlgorithmsDefault diffAlgorithmsPragma ] - where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) - -findNetwork :: FilePath -> Maybe FilePath -> [DiffAlgorithm] -> [Format] -> Sh [Test] -findNetwork dp tdir diffAlgorithmsDefault repoFormatsDefault = - do files <- sort <$> filter (".sh" `isSuffixOf`) <$> map (drop (length ("tests/network/"::String)) . toString) <$> ls "tests/network" - annotatedFiles <- Control.Monad.Trans.liftIO $ mapM (parsePragmas "tests/network") files - return [ shellTest dp fmt tdir (toString $ "network" file) da - | (file, (diffAlgorithmsPragma, repoFormatsPragma)) <- annotatedFiles - , fmt <- fromMaybe repoFormatsDefault repoFormatsPragma - , da <- fromMaybe diffAlgorithmsDefault diffAlgorithmsPragma ] + | file <- map toString test_files + , fmt <- repoFormats + , da <- diffAlgorithms ] + where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) . takeBaseName . toString -- ---------------------------------------------------------------------- -- harness @@ -223,6 +167,7 @@ , patience :: Bool , darcs1 :: Bool , darcs2 :: Bool + , full :: Bool , darcs :: String , tests :: [String] , testDir :: Maybe FilePath @@ -240,12 +185,15 @@ [ hashed := False += help "Run hashed-storage tests [no]" , failing := False += help "Run the failing (shell) tests [no]" , shell := True += help "Run the passing, non-network shell tests [yes]" +-- RELEASE BRANCH ONLY: disable network tests (too fragile) +-- , network := True += help "Run the network shell tests [yes]" , network := False += help "Run the network shell tests [no]" , unit := True += help "Run the unit tests [yes]" , myers := False += help "Use myers diff [no]" , patience := True += help "Use patience diff [yes]" += name "p" , darcs1 := False += help "Use darcs-1 repo format [no]" += name "1" , darcs2 := True += help "Use darcs-2 repo format [yes]" += name "2" + , full := False += help "Run all tests in all variants" , darcs := "" += help "Darcs binary path" += typ "PATH" , tests := [] += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t" , testDir := Nothing += help "Directory to run tests in" += typ "PATH" += name "d" @@ -306,12 +254,14 @@ . (if patience conf then (PatienceDiff:) else id) $ [] - ftests <- shelly $ if failing conf then findShell darcsBin (testDir conf) True diffAlgorithm repoFormat else return [] - stests <- shelly $ if shell conf then findShell darcsBin (testDir conf) False diffAlgorithm repoFormat else return [] + stests <- shelly $ + if shell conf + then findShell darcsBin "tests" (testDir conf) (failing conf) diffAlgorithm repoFormat + else return [] utests <- if unit conf then doUnit else return [] - ntests <- shelly $ if network conf then findNetwork darcsBin (testDir conf) diffAlgorithm repoFormat else return [] + ntests <- shelly $ if network conf then findShell darcsBin "tests/network" (testDir conf) (failing conf) diffAlgorithm repoFormat else return [] hstests <- if hashed conf then doHashed else return [] - defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests ++ hstests) args + defaultMainWithArgs (stests ++ utests ++ ntests ++ hstests) args where exeSuffix :: String #ifdef WIN32 @@ -326,6 +276,15 @@ hSetBinaryMode stderr True hSetBinaryMode stdin True clp <- cmdArgs_ defaultConfig - run clp - -#endif + run $ + if full clp then clp + { hashed = True + , shell = True + , network = True + , unit = True + , myers = True + , patience = True + , darcs1 = True + , darcs2 = True + } + else clp 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.12.5\nGanesh Sittampalam **20170111174540\n Ignore-this: 5e9ed0bfd6de3ef43d6933f2bda92147\n] \n" +Just "\nContext:\n\n[branch-2.14: disable network tests\nGuillaume Hoffmann **20180404141317\n Ignore-this: 8d6e4b0590002fbe7b0a1d1299d4b\n] \n\n[branch-2.14: fix cabal sdist on newer Cabals\nGuillaume Hoffmann **20180404141206\n Ignore-this: 69de5e3a3c40f4fc94536db0e7f276a9\n The trick we found is to remove other-modules: Version from\n the darcs executable.\n] \n\n[TAG 2.14.0\nGuillaume Hoffmann **20180404141149\n Ignore-this: 6181e294bb45bb98b7c9e481990534c0\n] \n" diff --git a/release/distributed-version b/release/distributed-version --- a/release/distributed-version +++ b/release/distributed-version @@ -1,1 +1,1 @@ -Just 0 +Just 2 diff --git a/src/Bundled/Posix.hsc b/src/Bundled/Posix.hsc deleted file mode 100644 --- a/src/Bundled/Posix.hsc +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes #-} - -module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus - , getFileStatusBS - , fileExists - , modificationTime, fileSize, FileStatus - , EpochTime, isDirectory, isRegularFile ) where - -import qualified Data.ByteString.Char8 as BS -#if mingw32_HOST_OS -#else -import Data.ByteString.Unsafe( unsafeUseAsCString ) -#endif -import Foreign.Marshal.Alloc ( allocaBytes ) -import Foreign.C.Error ( throwErrno, getErrno, eNOENT ) -import Foreign.C.Types ( CTime, CInt ) -import Foreign.Ptr ( Ptr ) - -import System.Posix.Internals - ( CStat, c_fstat, sizeof_stat - , st_mode, st_size, st_mtime, s_isdir, s_isreg ) -#if mingw32_HOST_OS -import System.Posix.Internals ( c_stat, CFilePath ) -#endif - -import System.Posix.Types ( Fd(..), CMode, EpochTime ) - -#if mingw32_HOST_OS -import Foreign.C.String( withCWString, CWString ) -#else -import Foreign.C.String ( withCString, CString ) -#endif - -#if mingw32_HOST_OS -import Data.Int ( Int64 ) - -type FileOffset = Int64 -lstat :: CFilePath -> Ptr CStat -> IO CInt -lstat = c_stat -#else -import System.Posix.Types ( FileOffset ) -import System.Posix.Internals( lstat ) -#endif - -#if mingw32_HOST_OS -bsToPath :: forall a. BS.ByteString -> (CWString -> IO a) -> IO a -bsToPath s f = withCWString (BS.unpack s) f -strToPath :: forall a. String -> (CWString -> IO a) -> IO a -strToPath = withCWString -#else -bsToPath :: forall a. BS.ByteString -> (CString -> IO a) -> IO a -bsToPath = unsafeUseAsCString -strToPath :: forall a. String -> (CString -> IO a) -> IO a -strToPath = withCString -#endif - -data FileStatus = FileStatus { - fst_exists :: !Bool, - fst_mode :: !CMode, - fst_mtime :: !CTime, - fst_size :: !FileOffset - } - -getFdStatus :: Fd -> IO FileStatus -getFdStatus (Fd fd) = do - do_stat (c_fstat fd) - -do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus -do_stat stat_func = do - allocaBytes sizeof_stat $! \p -> do - ret <- stat_func p - if (ret == -1) then do err <- getErrno - if (err == eNOENT) - then return $! (FileStatus False 0 0 0) - else throwErrno "do_stat" - else do mode <- st_mode p - mtime <- st_mtime p - size <- st_size p - return $! FileStatus True mode mtime size -{-# INLINE do_stat #-} - -isDirectory :: FileStatus -> Bool -isDirectory = s_isdir . fst_mode - -isRegularFile :: FileStatus -> Bool -isRegularFile = s_isreg . fst_mode - -modificationTime :: FileStatus -> EpochTime -modificationTime = fst_mtime - -fileSize :: FileStatus -> FileOffset -fileSize = fst_size - -fileExists :: FileStatus -> Bool -fileExists = fst_exists - -#include - --- lstat is broken on win32 with at least GHC 6.10.3 -getSymbolicLinkStatus :: FilePath -> IO FileStatus -##if mingw32_HOST_OS -getSymbolicLinkStatus = getFileStatus -##else -getSymbolicLinkStatus fp = - do_stat (\p -> (fp `strToPath` (`lstat` p))) -##endif - -getFileStatus :: FilePath -> IO FileStatus -getFileStatus fp = - do_stat (\p -> (fp `strToPath` (`lstat` p))) - --- | Requires NULL-terminated bytestring -> unsafe! Use with care. -getFileStatusBS :: BS.ByteString -> IO FileStatus -getFileStatusBS fp = - do_stat (\p -> (fp `bsToPath` (`lstat` p))) -{-# INLINE getFileStatusBS #-} diff --git a/src/Darcs/Patch.hs b/src/Darcs/Patch.hs --- a/src/Darcs/Patch.hs +++ b/src/Darcs/Patch.hs @@ -18,13 +18,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch - ( RepoPatch - , RepoType + ( RepoType , IsRepoType , PrimOf , Named , WrappedNamed - , Patchy , fromPrim , fromPrims , rmfile @@ -39,7 +37,9 @@ , binary , description , showContextPatch + , ShowPatchFor(..) , showPatch + , displayPatch , showNicely , infopatch , changepref @@ -88,15 +88,18 @@ , getdeps , listConflictedFiles , isInconsistent + , module Darcs.Patch.RepoPatch ) where -import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree, - maybeApplyToTree, ApplyState ) -import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL ) +import Darcs.Patch.Apply ( apply,applyToFilePaths, effectOnFilePaths, applyToTree, + maybeApplyToTree ) +import Darcs.Patch.Commute ( commute, commuteFL, commuteFLorComplain, commuteRL ) import Darcs.Patch.Conflict ( listConflictedFiles, resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) ) -import Darcs.Patch.Invert ( invertRL, invertFL ) +import Darcs.Patch.Invert ( invert, invertRL, invertFL ) +import Darcs.Patch.Inspect ( listTouchedFiles, hunkMatches ) +import Darcs.Patch.Merge ( merge ) import Darcs.Patch.Named ( Named, adddeps, namepatch, anonymous, @@ -104,14 +107,6 @@ infopatch, patch2patchinfo, patchname, patchcontents ) import Darcs.Patch.Named.Wrapped ( WrappedNamed ) -import Darcs.Patch.Patchy ( Patchy, - showPatch, showNicely, showContextPatch, - invert, - thing, things, - apply, - description, summary, summaryFL, - commute, listTouchedFiles, hunkMatches - ) import Darcs.Patch.Prim ( fromPrims, fromPrim, canonize, sortCoalesceFL, @@ -125,12 +120,7 @@ import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.RepoType ( RepoType, IsRepoType ) +import Darcs.Patch.Show ( description, showPatch, showNicely, displayPatch + , summary, summaryFL, thing, things, ShowPatchFor(..), ShowContextPatch(..) ) import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims ) import Darcs.Patch.TokenReplace ( forceTokReplace ) -import Darcs.Patch.V1.Commute ( merge ) - -import Darcs.Util.Tree( Tree ) - - -instance (Patchy p, ApplyState p ~ Tree) => Patchy (Named p) -instance (Patchy p, ApplyState p ~ Tree) => Patchy (WrappedNamed rt p) diff --git a/src/Darcs/Patch/Annotate.hs b/src/Darcs/Patch/Annotate.hs --- a/src/Darcs/Patch/Annotate.hs +++ b/src/Darcs/Patch/Annotate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-} -- Copyright (C) 2010 Petr Rockai -- @@ -32,16 +32,19 @@ module Darcs.Patch.Annotate ( - annotate + annotateFile , annotateDirectory , format , machineFormat , AnnotateResult + , Annotate(..) ) where import Prelude () import Darcs.Prelude +import Control.Monad.State ( modify, modify', when, gets, State, execState ) + import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.Map as M @@ -51,175 +54,171 @@ import Data.List( nub, groupBy ) import Data.Maybe( isJust, mapMaybe ) -import Control.Monad.State ( modify, when, gets, State, execState ) +import qualified Darcs.Patch.Prim.FileUUID as FileUUID -import Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTree(..) ) -import Darcs.Patch.Apply ( Apply, apply, ApplyState ) -import Darcs.Patch.Info ( PatchInfo(..), showPatchInfoUI, piAuthor, makePatchname ) -import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd ) +import Darcs.Patch.Info ( PatchInfo(..), displayPatchInfo, piAuthor, makePatchname ) +import Darcs.Patch.Named ( Named(..) ) +import Darcs.Patch.Named.Wrapped ( WrappedNamed(..) ) +import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd, hopefully ) +import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) +import Darcs.Patch.TokenReplace ( annotateReplace ) import Darcs.Patch.Witnesses.Ordered -import Darcs.Util.Tree( Tree ) import Darcs.Util.Path ( FileName, movedirfilename, fn2ps, ps2fn ) -import Darcs.Util.Printer( renderString, RenderMode(..) ) -import Darcs.Util.ByteString ( linesPS, unlinesPS ) -import Darcs.Util.Diff ( getChanges ) -import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) - -#include "impossible.h" - +import Darcs.Util.Printer( renderString ) +import Darcs.Util.ByteString ( linesPS, decodeLocale ) data FileOrDirectory = File | Directory deriving (Show, Eq) +type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString) + data Annotated = Annotated - { annotated :: V.Vector (Maybe PatchInfo, B.ByteString) - , current :: [(Int, B.ByteString)] - , path :: Maybe FileName + { annotated :: !AnnotateResult + , current :: ![(Int, B.ByteString)] + , path :: (Maybe FileName) , what :: FileOrDirectory , currentInfo :: PatchInfo - , diffAlgorithm :: D.DiffAlgorithm } deriving Show -type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString) - type AnnotatedM = State Annotated -instance ApplyMonad Tree AnnotatedM where - type ApplyMonadBase AnnotatedM = AnnotatedM - - nestedApply _ _ = undefinedFun "nestedApply" - liftApply _ _ = undefinedFun "liftApply" - getApplyState = undefinedFun "getApplyState" - -instance ApplyMonadTree AnnotatedM where - mReadFilePS = undefinedFun "mReadFilePS" - - mDoesFileExist _ = return True - mDoesDirectoryExist _ = return True - mCreateDirectory _ = return () - mCreateFile _ = return () - - mRemoveFile f = do - p <- gets path - when (p == Just f) $ modify (\x -> x { path = Nothing }) - updateDirectory f +class Annotate p where + annotate :: p wX wY -> AnnotatedM () - mRemoveDirectory = mRemoveFile +instance Annotate Prim where + annotate (FP fn fp) = case fp of + RmFile -> do + whenPathIs fn $ modify' (\s -> s { path = Nothing }) + whenWhatIs Directory $ updateDirectory fn + AddFile -> return () + Hunk off o n -> whenPathIs fn $ whenWhatIs File $ do + let remove = length o + let add = length n + i <- gets currentInfo + c <- gets current + a <- gets annotated + -- NOTE patches are inverted and in inverse order + modify' $ \s -> + -- NOTE subtract one from offset because darcs counts from one, + -- whereas vectors and lists count from zero. + let (to,from) = splitAt (off-1) c + in s { current = map eval $ to ++ replicate add (-1, B.empty) ++ drop remove from + , annotated = merge i a $ map eval $ take remove $ from + } + TokReplace t o n -> whenPathIs fn $ whenWhatIs File $ do + let test = annotateReplace t (BC.pack o) (BC.pack n) + i <- gets currentInfo + c <- gets current + a <- gets annotated + modify' $ \s -> s + { current = map (\(ix,b)->if test b then (-1,B.empty) else (ix,b)) c + , annotated = merge i a $ map eval $ filter (test . snd) $ c + } + -- TODO what if the status of a file changed from text to binary? + Binary _ _ -> whenPathIs fn $ bug "annotate: can't handle binary changes" + annotate (DP _ AddDir) = return () + annotate (DP fn RmDir) = whenWhatIs Directory $ do + whenPathIs fn $ modify' (\s -> s { path = Nothing }) + updateDirectory fn + annotate (Move fn fn') = do + modify' (\s -> s { path = fmap (movedirfilename fn fn') (path s) }) + whenWhatIs Directory $ do + let fix (i, x) = (i, fn2ps $ movedirfilename fn fn' (ps2fn x)) + modify $ \s -> s { current = map fix $ current s } + annotate (ChangePref _ _ _) = return () - mRename a b = do - p <- gets path - w <- gets what - when (isJust p) $ - modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) } - when (w == Directory) $ do - let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x)) - modify $ \st -> st { current = map fix $ current st } +instance Annotate FileUUID.Prim where + annotate _ = bug "annotate not implemented for FileUUID patches" - mModifyFilePS f job = do - p <- gets path - when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS) +instance Annotate p => Annotate (FL p) where + annotate = sequence_ . mapFL annotate - mModifyFilePSs f job = do - p <- gets path - when (p == Just f) $ updateFile job +instance Annotate p => Annotate (Named p) where + annotate (NamedP _ _ p) = annotate p -undefinedFun :: Monad m - => String - -> m a -undefinedFun name = fail $ name ++ " undefined for Annotated" +instance Annotate p => Annotate (WrappedNamed rt p) where + annotate (NormalP n) = annotate n + annotate (RebaseP _ _) = bug "annotate not implemented for Rebase patches" +instance Annotate p => Annotate (PatchInfoAnd rt p) where + annotate = annotate . hopefully -updateFile :: ([B.ByteString] - -> AnnotatedM [B.ByteString]) - -> AnnotatedM () -updateFile job = (==File) <$> gets what >>= flip when go - where - go = do - before <- map snd `fmap` gets current - after <- job before - da <- gets diffAlgorithm - reannotate $ getChanges da before after +whenWhatIs :: FileOrDirectory -> AnnotatedM () -> AnnotatedM () +whenWhatIs w actions = do + w' <- gets what + when (w == w') actions - reannotate [] = return () - reannotate ((off, remove, add):rest) = do - i <- gets currentInfo - c <- gets current - a <- gets annotated - modify $ \s -> s { current = take off c ++ [ (-1, x) | x <- add ] ++ - drop (off + length remove) c - , annotated = merge i a $ take (length remove) $ drop off c - } - reannotate rest +whenPathIs :: FileName -> AnnotatedM () -> AnnotatedM () +whenPathIs fn actions = do + p <- gets path + when (p == Just fn) actions - merge i a l = a V.// [ (line, (Just i, B.empty)) - | (line, _) <- l, line >= 0 && line < V.length a] +eval :: (Int, B.ByteString) -> (Int, B.ByteString) +eval (i,b) = seq i $ seq b $ (i,b) +merge :: a + -> V.Vector (Maybe a, BC.ByteString) + -> [(Int, t)] + -> V.Vector (Maybe a, BC.ByteString) +merge i a l = a V.// [ (line, (Just i, B.empty)) + | (line, _) <- l, line >= 0 && line < V.length a] updateDirectory :: FileName -> AnnotatedM () -updateDirectory p = (==Directory) <$> gets what >>= flip when go +updateDirectory p = whenWhatIs Directory $ do + let line = fn2ps p + files <- gets current + case filter ((==line) . snd) files of + [match@(ident, _)] -> reannotate ident match line + _ -> return () where - go = do let line = fn2ps p - files <- gets current - case filter ((==line) . snd) files of - [match@(ident, _)] -> reannotate ident match line - _ -> return () reannotate ident match line = modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ] , current = filter (/= match) $ current x } update line inf = (Just inf, BC.concat [ " -- created as: ", line ]) - complete :: Annotated -> Bool complete x = V.all (isJust . fst) $ annotated x - -annotate' :: (Apply p, ApplyState p ~ Tree) +annotate' :: Annotate p => FL (PatchInfoAnd rt p) wX wY -> Annotated -> Annotated annotate' NilFL ann = ann annotate' (p :>: ps) ann | complete ann = ann - | otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p }) - + | otherwise = annotate' ps $ execState (annotate p) (ann { currentInfo = info p }) -annotate :: (Apply p, ApplyState p ~ Tree) - => D.DiffAlgorithm - -> FL (PatchInfoAnd rt p) wX wY - -> FileName - -> B.ByteString - -> AnnotateResult -annotate da patches inipath inicontent = annotated $ annotate' patches initial +annotateFile :: Annotate p + => FL (PatchInfoAnd rt p) wX wY + -> FileName + -> B.ByteString + -> AnnotateResult +annotateFile patches inipath inicontent = annotated $ annotate' patches initial where initial = Annotated { path = Just inipath - , currentInfo = error "There is no currentInfo." + , currentInfo = bug "There is no currentInfo." , current = zip [0..] (linesPS inicontent) , what = File , annotated = V.replicate (length $ breakLines inicontent) (Nothing, B.empty) - , diffAlgorithm = da } - -annotateDirectory :: (Apply p, ApplyState p ~ Tree) - => D.DiffAlgorithm - -> FL (PatchInfoAnd rt p) wX wY +annotateDirectory :: Annotate p + => FL (PatchInfoAnd rt p) wX wY -> FileName -> [FileName] -> AnnotateResult -annotateDirectory da patches inipath inicontent = annotated $ annotate' patches initial +annotateDirectory patches inipath inicontent = annotated $ annotate' patches initial where initial = Annotated { path = Just inipath - , currentInfo = error "There is no currentInfo." + , currentInfo = bug "There is no currentInfo." , current = zip [0..] (map fn2ps inicontent) , what = Directory , annotated = V.replicate (length inicontent) (Nothing, B.empty) - , diffAlgorithm = da } - machineFormat :: B.ByteString -> AnnotateResult -> String machineFormat d a = unlines [ case i of Just inf -> show $ makePatchname inf @@ -228,10 +227,7 @@ ++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add | ((i, add), line) <- zip (V.toList a) (breakLines d) ] - -format :: B.ByteString - -> AnnotateResult - -> String +format :: B.ByteString -> AnnotateResult -> String format d a = pi_list ++ "\n" ++ numbered where numberedLines = zip [(1 :: Int)..] . lines $ file @@ -244,7 +240,7 @@ numbered = unlines . map prependNum $ numberedLines - pi_list = unlines [ show n ++ ": " ++ renderString Encode (showPatchInfoUI i) + pi_list = unlines [ show n ++ ": " ++ renderString (displayPatchInfo i) | (n :: Int, i) <- zip [1..] pis ] file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) ++ @@ -257,7 +253,7 @@ file_ann = groupBy ((==) `on` fst) $ zip (V.toList a) (breakLines d) - line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add] + line ((_, add), l) = decodeLocale $ BC.concat [l, " ", add] annotation (Just i, _) | Just n <- M.lookup i pi_map = pad 20 (piMail i) ++ " " ++ pad 4 ('#' : show n) @@ -271,11 +267,8 @@ | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi | otherwise = piAuthor pi - -breakLines :: BC.ByteString - -> [BC.ByteString] +breakLines :: BC.ByteString -> [BC.ByteString] breakLines s = case BC.split '\n' s of [] -> [] split | BC.null (last split) -> init split | otherwise -> split - diff --git a/src/Darcs/Patch/Apply.hs b/src/Darcs/Patch/Apply.hs --- a/src/Darcs/Patch/Apply.hs +++ b/src/Darcs/Patch/Apply.hs @@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | @@ -34,25 +34,20 @@ , applyToTree , applyToState , maybeApplyToTree - , applyToFileMods , effectOnFilePaths ) where import Prelude () import Darcs.Prelude -import Data.Set ( Set ) - import Control.Exception ( catch, IOException ) import Control.Arrow ( (***) ) import Darcs.Util.Tree( Tree ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) ) -import Darcs.Util.Path( FileName, fn2fp, fp2fn ) +import Darcs.Util.Path( fn2fp, fp2fn ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) ) -import Darcs.Patch.Index.Monad ( withPatchMods ) -import Darcs.Patch.Index.Types ( PatchMod ) class Apply p where type ApplyState p :: (* -> *) -> * @@ -90,7 +85,7 @@ -- | Apply a patch to a 'Tree', yielding a new 'Tree'. -applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree) +applyToTree :: (Apply p, Monad m, ApplyState p ~ Tree) => p wX wY -> Tree m -> m (Tree m) @@ -109,8 +104,3 @@ -> IO (Maybe (Tree IO)) maybeApplyToTree patch tree = (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing) - --------------------------------------------------------------------------------- --- | Apply a patch to set of 'FileName's, yielding the new set of 'FileName's and 'PatchMod's -applyToFileMods :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Set FileName -> (Set FileName, [PatchMod FileName]) -applyToFileMods patch = withPatchMods (apply patch) diff --git a/src/Darcs/Patch/ApplyMonad.hs b/src/Darcs/Patch/ApplyMonad.hs --- a/src/Darcs/Patch/ApplyMonad.hs +++ b/src/Darcs/Patch/ApplyMonad.hs @@ -1,9 +1,7 @@ {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses - , ConstraintKinds, UndecidableInstances, CPP #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE UndecidableSuperClasses #-} -#endif + , ConstraintKinds, UndecidableInstances + , UndecidableSuperClasses #-} -- Copyright (C) 2010, 2011 Petr Rockai -- -- Permission is hereby granted, free of charge, to any person @@ -40,9 +38,8 @@ import qualified Darcs.Util.Tree.Monad as TM import Darcs.Util.Tree ( Tree ) import Data.Maybe ( fromMaybe ) -import Darcs.Util.ByteString( linesPS, unlinesPS ) -import Darcs.Util.Path ( FileName, movedirfilename, fn2fp, isParentOrEqOf, - floatPath, AnchoredPath ) +import Darcs.Util.Path + ( FileName, movedirfilename, fn2fp, isParentOrEqOf, floatPath, AnchoredPath ) import Control.Monad.State.Strict import Control.Monad.Identity( Identity ) import Darcs.Patch.MonadProgress @@ -75,8 +72,6 @@ mDoesDirectoryExist :: FileName -> m Bool mDoesFileExist :: FileName -> m Bool mReadFilePS :: FileName -> m B.ByteString - mReadFilePSs :: FileName -> m [B.ByteString] - mReadFilePSs f = linesPS `fmap` mReadFilePS f mCreateDirectory :: FileName -> m () mRemoveDirectory :: FileName -> m () mCreateFile :: FileName -> m () @@ -84,8 +79,6 @@ mRemoveFile :: FileName -> m () mRename :: FileName -> FileName -> m () mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m () - mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m () - mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS) mChangePref :: String -> String -> String -> m () mChangePref _ _ _ = return () diff --git a/src/Darcs/Patch/ApplyPatches.hs b/src/Darcs/Patch/ApplyPatches.hs --- a/src/Darcs/Patch/ApplyPatches.hs +++ b/src/Darcs/Patch/ApplyPatches.hs @@ -2,22 +2,21 @@ ( applyPatches ) where -import Darcs.Patch.Info ( showPatchInfoUI ) +import Darcs.Patch.Info ( displayPatchInfo ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info ) import Darcs.Patch.Apply ( Apply(..) ) -import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.MonadProgress ( MonadProgress, ProgressAction(..), runProgressActions) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) import Darcs.Util.Printer ( text, ($$) ) -applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Patchy p) +applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Apply p) => FL (PatchInfoAnd rt p) wX wY -> m () applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps) where doApply hp = ProgressAction { paAction = apply (hopefully hp) - , paMessage = showPatchInfoUI (info hp) + , paMessage = displayPatchInfo (info hp) , paOnError = text "Unapplicable patch:" $$ - showPatchInfoUI (info hp) + displayPatchInfo (info hp) } diff --git a/src/Darcs/Patch/Bracketed/Instances.hs b/src/Darcs/Patch/Bracketed/Instances.hs --- a/src/Darcs/Patch/Bracketed/Instances.hs +++ b/src/Darcs/Patch/Bracketed/Instances.hs @@ -32,10 +32,10 @@ fromPrim p = Singleton (fromPrim p) instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where - showPatch (Singleton p) = showPatch p - showPatch (Braced NilFL) = blueText "{" $$ blueText "}" - showPatch (Braced ps) = blueText "{" $$ vcat (mapFL showPatch ps) $$ blueText "}" - showPatch (Parens ps) = blueText "(" $$ vcat (mapFL showPatch ps) $$ blueText ")" + showPatch f (Singleton p) = showPatch f p + showPatch _ (Braced NilFL) = blueText "{" $$ blueText "}" + showPatch f (Braced ps) = blueText "{" $$ vcat (mapFL (showPatch f) ps) $$ blueText "}" + showPatch f (Parens ps) = blueText "(" $$ vcat (mapFL (showPatch f) ps) $$ blueText ")" -- the ReadPatch instance is defined in Darcs.Patch.Read as it is -- used as an intermediate form during reading of lists of patches 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 @@ -15,19 +15,13 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Patch.Bundle - ( hashBundle - , makeBundle2 - , makeBundleN + ( makeBundleN , scanBundle , contextPatches , scanContextFile , patchFilename - , getContext , minContext - , parseBundle ) where import Prelude () @@ -50,7 +44,7 @@ import Darcs.Patch.Depends ( slightlyOptimizePatchset ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, - showPatchInfoUI, isTag ) + displayPatchInfo, isTag ) import Darcs.Patch.Named.Wrapped ( WrappedNamed ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFLPIAP, info, patchInfoAndPatch, unavailable, hopefully, @@ -59,17 +53,18 @@ import Darcs.Patch.ReadMonads ( parseStrictly ) import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) -import Darcs.Patch.Show ( ShowPatchBasic ) +import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(ForStorage) ) import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (:>)(..), reverseFL, (+<+), mapFL, mapFL_FL, mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Util.ByteString ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS) -import Darcs.Util.Crypt.SHA1 ( sha1PS ) +import Darcs.Util.ByteString + ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS, decodeLocale ) +import Darcs.Util.Hash ( sha1PS ) import Darcs.Util.Printer ( Doc, renderPS, newline, text, ($$), - (<>), vcat, vsep, renderString, RenderMode(..) ) + (<>), vcat, vsep, renderString ) -- |hashBundle creates a SHA1 string of a given a FL of named patches. This -- allows us to ensure that the patches in a received patchBundle have not been @@ -77,7 +72,7 @@ hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (WrappedNamed rt p) wX wY -> String hashBundle to_be_sent = - show $ sha1PS $ renderPS Standard $ vcat (mapFL showPatch to_be_sent) <> newline + show $ sha1PS $ renderPS $ vcat (mapFL (showPatch ForStorage) to_be_sent) <> newline makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> PatchSet rt p wStart wX -> FL (WrappedNamed rt p) wX wY -> IO Doc @@ -96,8 +91,8 @@ -> FL (WrappedNamed rt p) wX wY -> IO Doc makeBundle2 the_s common' to_be_sent to_be_sent2 = do patches <- case the_s of - Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree - Nothing -> return (vsep $ mapFL showPatch to_be_sent) + Just tree -> fst `fmap` virtualTreeIO (showContextPatch ForStorage to_be_sent) tree + Nothing -> return (vsep $ mapFL (showPatch ForStorage) to_be_sent) return $ format patches where format the_new = text "" @@ -107,7 +102,7 @@ $$ text "" $$ text "Context:" $$ text "" - $$ vcat (map showPatchInfo common) + $$ vcat (map (showPatchInfo ForStorage) common) $$ text "Patch bundle hash:" $$ text (hashBundle to_be_sent2) $$ text "" @@ -153,7 +148,7 @@ sealCtxAndPs ctx ps = Right $ sealContextWithPatches ctx ps - sealContextWithPatches :: RepoPatch p => [PatchInfo] + sealContextWithPatches :: [PatchInfo] -> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY -> Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin) @@ -201,14 +196,14 @@ -- |unavailablePatches converts a list of PatchInfos into a RL of PatchInfoAnd -- Unavailable patches. This is used to represent the Context of a patchBundle. -unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY +unavailablePatches :: [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY unavailablePatches = foldr (flip (:<:) . piUnavailable) (unsafeCoerceP NilRL) -- |piUnavailable returns an Unavailable within a PatchInfoAnd given a -- PatchInfo. -piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd rt p wX wY +piUnavailable :: PatchInfo -> PatchInfoAnd rt p wX wY piUnavailable i = patchInfoAndPatch i . unavailable $ - "Patch not stored in patch bundle:\n" ++ renderString Encode (showPatchInfoUI i) + "Patch not stored in patch bundle:\n" ++ renderString (displayPatchInfo i) -- |getContext parses a context list, returning a tuple containing the list, -- and remaining ByteString input. @@ -238,11 +233,11 @@ -- removed any leading spaces. The before-newline part is unpacked to a String, -- and tupled up with the remaining ByteString. sillyLex :: B.ByteString -> (String, B.ByteString) -sillyLex ps = (BC.unpack a, b) +sillyLex ps = (decodeLocale a, b) where (a, b) = BC.break (== '\n') (dropSpace ps) -contextPatches :: RepoPatch p => PatchSet rt p Origin wX +contextPatches :: PatchSet rt p Origin wX -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX contextPatches set = case slightlyOptimizePatchset set of PatchSet (ts :<: Tagged t _ ps') ps -> @@ -250,11 +245,11 @@ PatchSet NilRL ps -> PatchSet NilRL NilRL :> ps -- |'scanContextFile' scans the context in the file of the given name. -scanContextFile :: RepoPatch p => FilePath -> IO (PatchSet rt p Origin wX) +scanContextFile :: FilePath -> IO (PatchSet rt p Origin wX) scanContextFile filename = scanContext `fmap` mmapFilePS filename where -- are the type witnesses sensible? - scanContext :: RepoPatch p => B.ByteString -> PatchSet rt p Origin wX + scanContext :: B.ByteString -> PatchSet rt p Origin wX scanContext input | B.null input = error "Bad context!" | otherwise = case sillyLex input of 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 @@ -15,116 +15,134 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - --- | PatchChoices divides a sequence of patches into three sets: "first", --- "middle" and "last", such that all patches can be applied, if you first --- apply the first ones then the middle ones and then the last ones. --- Obviously if there are dependencies between the patches that will put a --- constraint on how you can choose to divide them up. The PatchChoices data --- type and associated functions are here to deal with many of the common +-- | The purpose of this module is to deal with many of the common -- cases that come up when choosing a subset of a group of patches. -- --- '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. +-- The idea is to divide a sequence of candidate patches into an initial +-- section named 'InFirst', a final section named 'InLast', and between them a +-- third section of not yet decided patches named 'InMiddle'. The reason for the +-- neutral terminology 'InFirst', 'InMiddle', and 'InLast', is that which of 'InFirst' +-- and 'InLast' counts as @selected@ or @deselected@ depends on +-- what we want to achive, that is, on the command and its options. +-- See "Darcs.UI.SelectChanges" for examples of how to use the functions from +-- this module. -- --- Internally, a PatchChoices doesn't always reorder the patches until --- it is asked for the final output (e.g. by 'get_first_choice'). --- Instead, each patch is placed in a state of definitely first, --- definitely last and undecided; undecided leans towards --- "middle". The patches that are first are commuted to the head --- immediately, but patches that are middle and last are mixed --- together. In case you're wondering about the first-middle-last --- language, it's because in some cases the "yes" answers will be last --- (as is the case for the revert command), and in others first (as in --- record, pull and push). +-- Obviously if there are dependencies between the patches that will put a +-- constraint on how you can choose to divide them up. Unless stated otherwise, +-- functions that move patches from one section to another pull all dependent +-- patches with them. -- --- Some patch marked "middle" may in fact be unselectable because of --- dependencies: when a patch is marked "last", its dependencies are --- not updated until patchSlot is called on them. -module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesLps, - patchChoicesLpsSub, - patchSlot, patchSlot', - getChoices, refineChoices, - separateFirstMiddleFromLast, - separateFirstFromMiddleLast, - forceFirst, forceFirsts, forceLast, forceLasts, - forceMatchingFirst, forceMatchingLast, - selectAllMiddles, - makeUncertain, makeEverythingLater, makeEverythingSooner, - LabelledPatch, Label, label, lpPatch, getLabelInt, - Slot(..), - substitute - ) where +-- Internally, we don't necessarily reorder patches immediately, but merely +-- tag them with the desired status, and thus postpone the actual commutation. +-- This saves a lot of unnecessary work, especially when choices are made +-- interactively, where the user can revise earlier decisions. +module Darcs.Patch.Choices + ( -- * Choosing patches + PatchChoices + , Slot(..) + -- ** Constructing + , patchChoices + , mkPatchChoices + -- ** Querying + , patchSlot + , getChoices + , separateFirstMiddleFromLast + , separateFirstFromMiddleLast + -- ** Forcing patches into a given 'Slot' + , forceMatchingFirst + , forceFirsts + , forceFirst + , forceMatchingLast + , forceLasts + , forceLast + , forceMiddle + , makeEverythingSooner + , makeEverythingLater + -- ** Operations on 'InMiddle' patches + , selectAllMiddles + , refineChoices + -- ** Substitution + , substitute + -- * Labelling patches + , LabelledPatch + , Label + , label + , unLabel + , labelPatches + , getLabelInt + ) where import Prelude () import Darcs.Prelude -import Control.Monad.Identity ( Identity ) -import Control.Monad.State ( StateT(..) ) - -import Prelude hiding ( pred ) - -import Darcs.Patch - ( Patchy, commuteRL, commute, merge, listTouchedFiles, hunkMatches - , invert ) -import Darcs.Patch.Merge ( Merge ) +import Darcs.Patch.Merge ( Merge, merge ) +import Darcs.Patch.Invert ( Invert, invert ) +import Darcs.Patch.Commute ( Commute, commute, commuteRL ) +import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles, hunkMatches ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL ) -import Darcs.Patch.Patchy ( Invert, Commute, PatchInspect ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered - ( FL(..), RL(..), - (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..), - zipWithFL, mapFL_FL, concatFL, - (+>+), reverseRL, anyFL ) + ( FL(..), RL(..) + , (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..) + , zipWithFL, mapFL_FL, concatFL + , (+>+), reverseRL, anyFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) ) - - -#include "impossible.h" - +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -- | 'Label' @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 @Label mp i@. The @i@ is just some --- arbitrary label, expected to be unique within the patches being +-- The identifier is implemented as a tuple @Label mp i@. The @i@ is an +-- integer, 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 @Label Nothing --- 5@, the resulting sub-patches could be identified as @Label (Label Nothing 5) --- 1@, @Label (Label Nothing 5) 2@, etc. -data Label = Label (Maybe Label) Integer deriving ( Eq, Ord ) +-- 5@, the resulting sub-patches could be identified as +-- @Label (Just (Label Nothing 5))1@, @Label (Just (Label Nothing 5)) 2@, etc. +-- +-- IOW, 'Label' is a non-empty, reversed list of 'Int's. +data Label = Label (Maybe Label) Int deriving Eq + +-- | A patch with a 'Label' attached to it. data LabelledPatch p wX wY = LP Label (p wX wY) --- | The @Bool@ parameter indicates whether the patch has been explicitely --- selected (or rejected) by the user. -data PatchChoice p wX wY = PC { pcPatch :: (LabelledPatch p wX wY) - , _pcChoice :: Bool} +-- | This internal type tags a 'LabelledPatch' with a 'Bool', to distinguish +-- 'InMiddle' from 'InLast' patches. +data PatchChoice p wX wY = PC + { pcPatch :: (LabelledPatch p wX wY) -- ^ the 'LabelledPatch' in question + , _pcIsLast :: Bool -- ^ 'False' = 'InMiddle', 'True' = 'InLast' + } +-- | Internal function to tag a 'LabelledPatch' as 'InMiddle' or 'InLast'. +pcSetLast :: Bool -> LabelledPatch p wX wY -> PatchChoice p wX wY +pcSetLast = flip PC + +-- TODO pcsFirsts should be an 'RL', not an 'FL'. +-- | A sequence of 'LabelledPatch'es where each patch is either +-- 'InFirst', 'InMiddle', or 'InLast'. The representation is +-- optimized for the case where we start chosing patches from the left +-- of the sequence: patches that are 'InFirst' are commuted to the head +-- immediately, but patches that are 'InMiddle' or 'InLast' are mixed +-- together; when a patch is marked 'InLast', its dependencies are +-- not updated until we retrieve the final result. data PatchChoices p wX wY where PCs :: { pcsFirsts :: FL (LabelledPatch p) wX wM - , pcsLasts :: FL (PatchChoice p) wM wY} + , pcsMiddleLasts :: FL (PatchChoice p) wM wY} -> PatchChoices p wX wY --- | See module documentation for 'Darcs.Patch.Choices' +-- | See module documentation for "Darcs.Patch.Choices". data Slot = InFirst | InMiddle | InLast label :: LabelledPatch p wX wY -> Label label (LP tg _) = tg -getLabelInt :: Label -> Integer +getLabelInt :: Label -> Int getLabelInt (Label _ i) = i -lpPatch :: LabelledPatch p wX wY -> p wX wY -lpPatch (LP _ p) = p - -liftLP :: (p wX wY -> p wA wB) -> (LabelledPatch p wX wY -> LabelledPatch p wA wB) -liftLP f (LP t p) = LP t (f p) +unLabel :: LabelledPatch p wX wY -> p wX wY +unLabel (LP _ p) = p -- This is dangerous if two patches from different labelled series are compared -- ideally Label (and hence LabelledPatch/PatchChoices) would have a witness type @@ -132,75 +150,94 @@ compareLabels :: LabelledPatch p wA wB -> LabelledPatch p wC wD -> EqCheck (wA, wB) (wC, wD) compareLabels (LP l1 _) (LP l2 _) = if l1 == l2 then unsafeCoerceP IsEq else NotEq -instance MyEq p => MyEq (LabelledPatch p) where - unsafeCompare (LP l1 p1) (LP l2 p2) = l1 == l2 && unsafeCompare p1 p2 +instance Eq2 p => Eq2 (LabelledPatch p) where + unsafeCompare (LP l1 p1) (LP l2 p2) = l1 == l2 && unsafeCompare p1 p2 instance Invert p => Invert (LabelledPatch p) where - invert = liftLP invert + invert (LP t p) = LP t (invert p) instance Commute p => Commute (LabelledPatch p) where - commute (LP l1 p1 :> LP l2 p2) = do p2' :> p1' <- commute (p1 :> p2) - return (LP l2 p2' :> LP l1 p1') + commute (LP l1 p1 :> LP l2 p2) = do + p2' :> p1' <- commute (p1 :> p2) + return (LP l2 p2' :> LP l1 p1') instance PatchInspect p => PatchInspect (LabelledPatch p) where - listTouchedFiles (LP _ p) = listTouchedFiles p - hunkMatches f (LP _ p) = hunkMatches f p + listTouchedFiles = listTouchedFiles . unLabel + hunkMatches f = hunkMatches f . unLabel instance Merge p => Merge (LabelledPatch p) where - merge (LP l1 p1 :\/: LP l2 p2) = case merge (p1 :\/: p2) of - p2' :/\: p1' -> LP l2 p2' :/\: LP l1 p1' + merge (LP l1 p1 :\/: LP l2 p2) = + case merge (p1 :\/: p2) of + p2' :/\: p1' -> LP l2 p2' :/\: LP l1 p1' instance Commute p => Commute (PatchChoice p) where - commute (PC p1 c1 :> PC p2 c2) = do p2' :> p1' <- commute (p1 :> p2) - return (PC p2' c2 :> PC p1' c1) + commute (PC p1 c1 :> PC p2 c2) = do + p2' :> p1' <- commute (p1 :> p2) + return (PC p2' c2 :> PC p1' c1) instance PatchInspect p => PatchInspect (PatchChoice p) where - listTouchedFiles (PC p _) = listTouchedFiles p - hunkMatches f (PC p _) = hunkMatches f p + listTouchedFiles = listTouchedFiles . pcPatch + hunkMatches f = hunkMatches f . pcPatch instance Merge p => Merge (PatchChoice p) where merge (PC lp1 c1 :\/: PC lp2 c2) = case merge (lp1 :\/: lp2) of lp2' :/\: lp1' -> PC lp2' c2 :/\: PC lp1' c1 -patchChoices :: Patchy p => FL p wX wY -> PatchChoices p wX wY -patchChoices = fst . patchChoicesLps +-- | Create a 'PatchChoices' from a sequence of patches, so that +-- all patches are initially 'InMiddle'. +patchChoices :: FL p wX wY -> PatchChoices p wX wY +patchChoices = mkPatchChoices . labelPatches Nothing --- |Label a sequence of patches as subpatches of an existing label. This is intended for --- use when substituting a patch for an equivalent patch or patches. -patchChoicesLpsSub :: Patchy p - => Maybe Label -> FL p wX wY - -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY) -patchChoicesLpsSub tg ps = let lps = zipWithFL LP (map (Label tg) [1..]) ps - in (PCs NilFL (mapFL_FL (\lp -> PC lp False) lps), lps) +-- | Label a sequence of patches, maybe using the given parent label. +labelPatches :: Maybe Label -> FL p wX wY -> FL (LabelledPatch p) wX wY +labelPatches tg ps = zipWithFL LP (map (Label tg) [1..]) ps --- |Label a sequence of patches. -patchChoicesLps :: Patchy p => FL p wX wY -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY) -patchChoicesLps = patchChoicesLpsSub Nothing +-- | Create a 'PatchChoices' from an already labelled sequence of patches, +-- so that all patches are initially 'InMiddle'. +mkPatchChoices :: FL (LabelledPatch p) wX wY -> PatchChoices p wX wY +mkPatchChoices = PCs NilFL . mapFL_FL (pcSetLast False) -instance MyEq p => MyEq (PatchChoice p) where - unsafeCompare (PC lp1 _) (PC lp2 _) = unsafeCompare lp1 lp2 +instance Eq2 p => Eq2 (PatchChoice p) where + unsafeCompare (PC lp1 _) (PC lp2 _) = unsafeCompare lp1 lp2 -separateFirstFromMiddleLast :: Patchy p => PatchChoices p wX wZ - -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ -separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC lp _) -> lp) l +-- | Like 'getChoices' but lumps together 'InMiddle' and 'InLast' patches. +-- This is more efficient than using 'getChoices' and then catenating 'InMiddle' +-- and 'InLast' sections because we have to commute less. +-- (This is what 'PatchChoices' are optimized for.) +-- +-- prop> separateFirstFromMiddleLast c == case getChoices c of f:>m:>l -> f:>m+>+l +separateFirstFromMiddleLast :: PatchChoices p wX wZ + -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ +separateFirstFromMiddleLast (PCs f ml) = f :> mapFL_FL pcPatch ml -separateFirstMiddleFromLast :: Patchy p => PatchChoices p wX wZ - -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ +-- | Like 'getChoices' but lumps together 'InFirst' and 'InMiddle' patches. +-- +-- prop> separateFirstMiddleFromLast c == case getChoices c of f:>m:>l -> f+>+m:>l +separateFirstMiddleFromLast :: Commute p + => PatchChoices p wX wZ + -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ separateFirstMiddleFromLast (PCs f l) = case pushLasts l of (m :> l') -> f +>+ m :> l' --- | @getChoices@ evaluates a @PatchChoices@ into the first, middle and last sequences --- by doing the commutes that were needed. -getChoices :: Patchy p => PatchChoices p wX wY - -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY -getChoices (PCs f l) = - case pushLasts l of - (m :> l') -> f :> m :> l' +-- | Retrieve the resulting sections from a 'PatchChoice'. The result is a +-- triple @first:>middle:>last@, such that all patches in @first@ are +-- 'InFirst', all patches in @middle@ are 'InMiddle', and all patches in @last@ +-- are 'InLast'. +getChoices :: Commute p + => PatchChoices p wX wY + -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY +getChoices (PCs f ml) = + case pushLasts ml of + (m :> l') -> f :> m :> l' -pushLasts :: Patchy p => FL (PatchChoice p) wX wY - -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY +-- | Internal function to commute patches in the common 'pcsMiddleLasts' segment +-- so that all 'InLast' patches are behind 'InMiddle' ones. Patches 'InMiddle' +-- that depend on any 'InLast' are promoted to 'InLast'. +pushLasts :: Commute p + => FL (PatchChoice p) wX wY + -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY pushLasts NilFL = NilFL :> NilFL pushLasts (PC lp False :>: pcs) = case pushLasts pcs of @@ -211,27 +248,32 @@ case commuteWhatWeCanFL (lp :> m) of (m' :> lp' :> deps) -> m' :> (lp' :>: deps +>+ l) --- | @refineChoices act@ performs @act@ on the middle part of a sequence --- of choices, in order to hopefully get more patches into the @first@ and --- @last@ parts of a @PatchChoices@. -refineChoices :: (Patchy p, Monad m, Functor m) => - (forall wU wV . FL (LabelledPatch p) wU wV -> - PatchChoices p wU wV -> - m (PatchChoices p wU wV)) - -> PatchChoices p wX wY -> m (PatchChoices p wX wY) +-- TODO for the way we use this function it is too restrictive IMO: it does not +-- allow the user to select anything that doesn't match the pre-filters. +-- | Use the given monadic 'PatchChoices' transformer on the 'InMiddle' section +-- of a 'PatchChoices', then fold the result back into the original 'PatchChoices'. +refineChoices :: (Commute p, Monad m) + => (forall wU wV . FL (LabelledPatch p) wU wV -> + PatchChoices p wU wV -> m (PatchChoices p wU wV)) + -> PatchChoices p wX wY -> m (PatchChoices p wX wY) refineChoices act ps = - case getChoices ps of - (f :> m :> l) -> do - let mchoices = PCs NilFL . mapFL_FL (flip PC False) $ m - (PCs f' l') <- act m mchoices - return . PCs (f +>+ f') $ l' +>+ mapFL_FL (flip PC True) l + case getChoices ps of + (f :> m :> l) -> do + (PCs f' l') <- act m (mkPatchChoices m) + return . PCs (f +>+ f') $ l' +>+ mapFL_FL (pcSetLast True) l -patchSlot :: forall p wA wB wX wY. Patchy p => LabelledPatch p wA wB - -> PatchChoices p wX wY -> (Slot, PatchChoices p wX wY) -patchSlot (LP t _) pc@(PCs f l) = - if foundIn f - then (InFirst, pc) - else psLast f NilRL NilRL l +-- | Given a 'LabelledPatch' determine to which section of the given +-- 'PatchChoices' it belongs. This is not trivial to compute, since a patch +-- tagged as 'InMiddle' may be forced to actually be 'InLast' by dependencies. We +-- return a possibly re-ordered 'PatchChoices' so as not to waste the +-- commutation effort. +patchSlot :: forall p wA wB wX wY. Commute p + => LabelledPatch p wA wB + -> PatchChoices p wX wY + -> (Slot, PatchChoices p wX wY) +patchSlot (LP t _) pc@(PCs f ml) + | foundIn f = (InFirst, pc) + | otherwise = psLast f NilRL NilRL ml where foundIn = anyFL ((== t) . label) psLast :: forall wM wC wL . @@ -243,7 +285,7 @@ psLast firsts middles bubble (PC lp True :>: ls) | label lp == t = (InLast , PCs { pcsFirsts = firsts - , pcsLasts = settleM middles + , pcsMiddleLasts = settleM middles +>+ settleB bubble +>+ PC lp True :>: ls}) psLast firsts middles bubble (PC lp False :>: ls) @@ -251,13 +293,13 @@ case commuteRL (bubble :> lp) of Just (lp' :> bubble') -> (InMiddle, PCs { pcsFirsts = firsts - , pcsLasts = settleM middles + , pcsMiddleLasts = settleM middles +>+ PC lp' False :>: settleB bubble' +>+ ls}) Nothing -> (InLast, PCs { pcsFirsts = firsts - , pcsLasts = settleM middles + , pcsMiddleLasts = settleM middles +>+ settleB bubble +>+ PC lp True :>: ls}) @@ -271,16 +313,14 @@ settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble -patchSlot' :: Patchy p => - LabelledPatch p wA wB -> StateT (PatchChoices p wX wY) Identity Slot -patchSlot' lp = StateT (return . patchSlot lp) - -forceMatchingFirst :: forall p wA wB. Patchy p => - ( forall wX wY . LabelledPatch p wX wY -> Bool) - -> PatchChoices p wA wB - -> PatchChoices p wA wB -forceMatchingFirst pred (PCs fn l) = - fmfLasts fn NilRL l +-- | Force all patches matching the given predicate to be 'InFirst', +-- pulling any dependencies with them. This even forces any patches +-- that were already tagged 'InLast'. +forceMatchingFirst :: forall p wA wB. Commute p + => ( forall wX wY . LabelledPatch p wX wY -> Bool) + -> PatchChoices p wA wB + -> PatchChoices p wA wB +forceMatchingFirst pred (PCs f0 ml) = fmfLasts f0 NilRL ml where fmfLasts :: FL (LabelledPatch p) wA wM -> RL (PatchChoice p) wM wN @@ -295,21 +335,30 @@ in fmfLasts f' l1' l2 fmfLasts f l1 (a :>: l2) = fmfLasts f (l1 :<: a) l2 fmfLasts f l1 NilFL = PCs { pcsFirsts = f - , pcsLasts = reverseRL l1 } + , pcsMiddleLasts = reverseRL l1 } pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool pred_pc (PC lp _) = pred lp -forceFirsts :: Patchy p => [Label] -> PatchChoices p wA wB - -> PatchChoices p wA wB +-- | Force all patches labelled with one of the given labels to be 'InFirst', +-- pulling any dependencies with them. This even forces any patches +-- that were already tagged 'InLast'. +forceFirsts :: Commute p + => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB forceFirsts ps = forceMatchingFirst ((`elem` ps) . label) -forceFirst :: Patchy p => Label -> PatchChoices p wA wB - -> PatchChoices p wA wB +-- | Force a single patch labelled with the given label to be 'InFirst', +-- pulling any dependencies with them. This even forces any patches +-- that were already tagged 'InLast'. +forceFirst :: Commute p + => Label -> PatchChoices p wA wB -> PatchChoices p wA wB forceFirst p = forceMatchingFirst ((== p) . label) --TODO: stop after having seen the patch we want to force first -selectAllMiddles :: forall p wX wY. Patchy p => Bool - -> PatchChoices p wX wY -> PatchChoices p wX wY +-- | Make all 'InMiddle' patches either 'InFirst' or 'InLast'. This does *not* +-- modify any patches that are already determined to be 'InLast' by +-- dependencies. +selectAllMiddles :: forall p wX wY. Commute p + => Bool -> PatchChoices p wX wY -> PatchChoices p wX wY selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l) where g (PC lp _) = PC lp True selectAllMiddles False (PCs f l) = samf f NilRL NilRL l @@ -327,73 +376,98 @@ samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (l1 :<: PC lp True) l2 samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) -forceMatchingLast :: Patchy p => (forall wX wY . LabelledPatch p wX wY -> Bool) - -> PatchChoices p wA wB - -> PatchChoices p wA wB -forceMatchingLast pred (PCs f l) = do - fmlFirst pred True NilRL f l +-- | Similar to 'forceMatchingFirst' only that patches are forced to be +-- 'InLast' regardless of their previous status. +forceMatchingLast :: Commute p => (forall wX wY . LabelledPatch p wX wY -> Bool) + -> PatchChoices p wA wB + -> PatchChoices p wA wB +forceMatchingLast pred (PCs f ml) = + forceMatchingMiddleOrLast pred True NilRL f ml -fmlFirst :: forall p wA wB wM1 wM2 . Patchy p => - (forall wX wY . LabelledPatch p wX wY -> Bool) -> Bool - -> RL (LabelledPatch p) wA wM1 - -> FL (LabelledPatch p) wM1 wM2 - -> FL (PatchChoice p) wM2 wB - -> PatchChoices p wA wB -fmlFirst pred b f1 (a :>: f2) l - | pred a = - case commuteWhatWeCanFL (a :> f2) of - (f2' :> a' :> deps) -> - let - l' = mapFL_FL (\lp -> PC lp b) (a' :>: deps) +>+ l - in - fmlFirst pred b f1 f2' l' -fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (f1 :<: a) f2 l -fmlFirst pred b f1 NilFL l = PCs { pcsFirsts = reverseRL f1 - , pcsLasts = mapFL_FL ch l} - where ch (PC lp c) = (PC lp (if pred lp then b else c) ) +-- | Internal function working directly on the constituent parts of a +-- 'PatchChoices' and taking an accumulating 'RL' to build up a new 'InFirst' +-- section. It forces patches to be 'InMiddle' or 'InLast', depending +-- on the 'Bool' parameter ('True' means 'InLast', 'False' means 'InMiddle'). +-- It does this regardless of the previous status of patches and also pulls +-- any dependent patches with it. +forceMatchingMiddleOrLast + :: forall p wA wB wM1 wM2 . Commute p + => (forall wX wY . LabelledPatch p wX wY -> Bool) + -> Bool + -> RL (LabelledPatch p) wA wM1 -- ^ accumulator for 'InFirst' patches + -> FL (LabelledPatch p) wM1 wM2 -- ^ original 'InFirst' section + -> FL (PatchChoice p) wM2 wB -- ^ original 'InMiddle' and 'InLast' section + -> PatchChoices p wA wB +forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml + | pred a = + case commuteWhatWeCanFL (a :> f2) of + (f2' :> a' :> deps) -> + let + ml' = mapFL_FL (pcSetLast b) (a' :>: deps) +>+ ml + in + forceMatchingMiddleOrLast pred b f1 f2' ml' +forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml = + forceMatchingMiddleOrLast pred b (f1 :<: a) f2 ml +forceMatchingMiddleOrLast pred b f1 NilFL ml = + PCs { pcsFirsts = reverseRL f1 + , pcsMiddleLasts = mapFL_FL choose ml + } + where + choose (PC lp c) = (PC lp (if pred lp then b else c) ) -forceLasts :: Patchy p => [Label] - -> PatchChoices p wA wB -> PatchChoices p wA wB +-- | Force all patches labelled with one of the given labels to be 'InLast', +-- pulling any dependencies with them. This even forces any patches +-- that were previously tagged 'InFirst'. +forceLasts :: Commute p + => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB forceLasts ps = forceMatchingLast ((`elem` ps) . label) -forceLast :: Patchy p => Label - -> PatchChoices p wA wB -> PatchChoices p wA wB +-- | Force a single patch labelled with the given label to be 'InLast', +-- pulling any dependencies with them, regardless of their previous status. +forceLast :: Commute p + => Label -> PatchChoices p wA wB -> PatchChoices p wA wB forceLast p = forceMatchingLast ((== p) . label) -makeUncertain :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB -makeUncertain t (PCs f l) = fmlFirst ((== t) . label) False NilRL f l +-- | Force a patch with the given 'Label' to be 'InMiddle', +-- pulling any dependencies with it, regardless of their previous status. +forceMiddle :: Commute p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB +forceMiddle t (PCs f l) = forceMatchingMiddleOrLast ((== t) . label) False NilRL f l -makeEverythingLater :: Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY -makeEverythingLater (PCs f l) = - let m = mapFL_FL (\lp -> PC lp False) f - l' = mapFL_FL (\(PC lp _) -> PC lp True) l - in - PCs NilFL $ m +>+ l' +-- | Turn 'InFirst' patches into 'InMiddle' ones and 'InMiddle' into 'InLast' ones. +makeEverythingLater :: PatchChoices p wX wY -> PatchChoices p wX wY +makeEverythingLater (PCs f ml) = + let m = mapFL_FL (pcSetLast False) f + ml' = mapFL_FL (\(PC lp _) -> PC lp True) ml + in PCs NilFL $ m +>+ ml' -makeEverythingSooner :: forall p wX wY. - Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY -makeEverythingSooner (PCs f l) = - case mes NilRL NilRL l - of (m :> l') -> - PCs (f +>+ m) l' +-- | Turn 'InMiddle' patches into 'InFirst' and 'InLast' patches into 'InMiddle'. +-- Does *not* pull dependencies into 'InFirst', instead patches that +-- cannot be commuted past 'InLast' patches stay 'InMiddle'. +makeEverythingSooner :: forall p wX wY. Commute p + => PatchChoices p wX wY -> PatchChoices p wX wY +makeEverythingSooner (PCs f ml) = + case mes NilRL NilRL ml + of (m :> ml') -> + PCs (f +>+ m) ml' where mes :: forall wM1 wM2 wM3 . RL (LabelledPatch p) wM1 wM2 -> RL (LabelledPatch p) wM2 wM3 -> FL (PatchChoice p) wM3 wY -> (FL (LabelledPatch p) :> FL (PatchChoice p)) wM1 wY - mes middle bubble (PC lp True :>: ls) = mes middle (bubble :<: lp) ls - mes middle bubble (PC lp False :>: ls) = + mes middle bubble (PC lp True :>: mls) = mes middle (bubble :<: lp) mls + mes middle bubble (PC lp False :>: mls) = case commuteRL (bubble :> lp) of - Nothing -> mes middle (bubble :<: lp) ls - Just (lp' :> bubble') -> mes (middle :<: lp') bubble' ls - mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble) + Nothing -> mes middle (bubble :<: lp) mls + Just (lp' :> bubble') -> mes (middle :<: lp') bubble' mls + mes middle bubble NilFL = + (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble) --- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice --- associated with @a@ -substitute :: forall p wX wY - . Patchy p - => Sealed2 (LabelledPatch p :||: FL (LabelledPatch p)) +-- | Substitute a single 'LabelledPatch' with an equivalent list of patches, +-- preserving its status as 'InFirst', 'InMiddle' or 'InLast'). +-- The patch is looked up using equality of 'Label's. +substitute :: forall p wX wY . + Sealed2 (LabelledPatch p :||: FL (LabelledPatch p)) -> PatchChoices p wX wY -> PatchChoices p wX wY substitute (Sealed2 (lp :||: new_lps)) (PCs f l) = @@ -405,5 +479,5 @@ | otherwise = lp' :>: NilFL substPc :: PatchChoice p wA wB -> FL (PatchChoice p) wA wB substPc (PC lp' c) - | IsEq <- compareLabels lp lp' = mapFL_FL (flip PC c) new_lps + | IsEq <- compareLabels lp lp' = mapFL_FL (pcSetLast c) new_lps | otherwise = PC lp' c :>: NilFL diff --git a/src/Darcs/Patch/Conflict.hs b/src/Darcs/Patch/Conflict.hs --- a/src/Darcs/Patch/Conflict.hs +++ b/src/Darcs/Patch/Conflict.hs @@ -1,5 +1,5 @@ -- Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam -{-# LANGUAGE CPP, ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..), listConflictedFiles , IsConflictedPrim(..), ConflictState(..) @@ -31,8 +31,6 @@ import Darcs.Util.Path ( FileName, fn2fp, fp2fn ) import Darcs.Util.Show ( appPrec ) -#include "impossible.h" - listConflictedFiles :: Conflict p => p wX wY -> [FilePath] listConflictedFiles p = nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p @@ -61,14 +59,32 @@ return $ ys' :> reverseRL rxs' instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where + -- By definition, a conflicting (primitive) patch is resolved if + -- another (primitive) patch depends on the conflict. + -- + -- So, when looking for conflicts in a list of patches, we go + -- through the whole list looking for individual patches that are + -- in conflict. But then we try to commute them past all the + -- patches we've already seen. If we fail, i.e. there's something + -- that depends on the conflict, then we forget about the conflict; + -- this is the Nothing case of the 'commuteNoConflictsFL' call. + -- + -- Note that 'primitive' does not mean Prim (this is a case of bad + -- naming) but rather a RepoPatchV1 or RepoPatchV2. Prim patches + -- are merely a 'base class' containing everything common to V1 and + -- V2 primitive patches. resolveConflicts x = rcs x NilFL - where rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]] - rcs NilRL _ = [] - rcs (ps:<:p) passedby | (_:_) <- resolveConflicts p = - case commuteNoConflictsFL (p:>passedby) of - Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby) - Nothing -> rcs ps (p:>:passedby) - rcs (ps:<:p) passedby = seq passedby $ rcs ps (p:>:passedby) + where + rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]] + rcs NilRL _ = [] + rcs (ps :<: p) passedby + | null (resolveConflicts p) = seq passedby rest -- TODO why seq here? + | otherwise = + case commuteNoConflictsFL (p :> passedby) of + Just (_ :> p') -> resolveConflicts p' ++ rest + Nothing -> rest + where + rest = rcs ps (p :>: passedby) conflictedEffect = concat . reverse . mapRL conflictedEffect instance CommuteNoConflicts p => CommuteNoConflicts (RL p) where 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 @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP , ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} module Darcs.Patch.Depends ( getUncovered @@ -28,8 +28,8 @@ , slightlyOptimizePatchset , getPatchesBeyondTag , splitOnTag - , newsetUnion - , newsetIntersection + , patchSetUnion + , patchSetIntersection , findUncommon , merge2FL , getDeps @@ -39,41 +39,35 @@ import Prelude () import Darcs.Prelude -#include "impossible.h" - import Prelude hiding ( pi ) import Data.List ( delete, intersect, (\\) ) import Data.Maybe ( fromMaybe ) -import qualified Data.ByteString.Char8 as BC ( unpack ) import Control.Arrow ( (&&&) ) import Darcs.Patch ( RepoPatch ) -import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Named ( Named (..), patch2patchinfo ) import Darcs.Patch.Named.Wrapped ( getdeps ) import Darcs.Patch.Choices ( Label, patchChoices, forceFirst - , PatchChoices, lpPatch, getChoices + , PatchChoices, unLabel, getChoices , LabelledPatch, label ) -import Darcs.Patch.Commute ( commute, commuteFL, commuteRL ) -import Darcs.Patch.Info ( PatchInfo, isTag, showPatchInfoUI, _piName ) +import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL ) +import Darcs.Patch.Info ( PatchInfo, isTag, displayPatchInfo, piName ) import Darcs.Patch.Merge ( Merge, mergeFL ) import Darcs.Patch.Permutations ( partitionFL, partitionRL ) import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info ) -import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, patchSet2RL, appendPSFL ) import Darcs.Patch.Progress ( progressRL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart ) import Darcs.Patch.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..), - (+>+), mapFL, RL(..), FL(..), isShorterThanRL, + (+>>+), (+<<+), mapFL, RL(..), FL(..), isShorterThanRL, (+<+), reverseFL, reverseRL, mapRL, lengthFL, splitAtFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, seal, Sealed2(..), seal2 ) -import Darcs.Util.Printer ( renderString, vcat, RenderMode(..) ) -import Darcs.Util.Tree ( Tree ) +import Darcs.Util.Printer ( renderString, vcat ) {- - This module uses the following definitions: @@ -100,17 +94,17 @@ ) -- | Searchs dependencies in @repoFL@ of the patches in @getDepsFL@. -getDeps :: (RepoPatch p, ApplyState p ~ Tree) => +getDeps :: (RepoPatch p) => FL (Named p) wA wR -> FL (PatchInfoAnd rt p) wX wY -> [SPatchAndDeps p] getDeps repoFL getDepsFL = let repoChoices = patchChoices repoFL - getDepsFL' = mapFL (BC.unpack . _piName . info) getDepsFL + getDepsFL' = mapFL (piName . info) getDepsFL labelledDeps = getLabelledDeps getDepsFL' repoChoices in map (deps repoChoices) labelledDeps where -- Search dependencies for the patch with label @l@ in @repoChoices@. - deps :: (Patchy (Named p)) => PatchChoices (Named p) wX wY -> + deps :: (Commute p) => PatchChoices (Named p) wX wY -> (String,Label) -> SPatchAndDeps p deps repoChoices (_,l) = case getChoices $ forceFirst l repoChoices of @@ -122,7 +116,7 @@ -- has r, which is the patch -- that we are looking at -- dependencies. - getLabelledDeps :: Patchy (Named p) => [String] -> + getLabelledDeps :: (Commute p) => [String] -> PatchChoices (Named p) x y -> [(String, Label)] getLabelledDeps patchnames repoChoices = case getChoices repoChoices of @@ -138,7 +132,7 @@ else filterDepsFL patchnames lps where lpTostring :: LabelledPatch (Named p) wA wB -> String - lpTostring = BC.unpack . _piName . patch2patchinfo . lpPatch + lpTostring = piName . patch2patchinfo . unLabel dep :: (String, Label) dep = lpTostring &&& label $ lp @@ -155,13 +149,13 @@ taggedIntersection does its best to reduce the number of inventories that are accessed from its rightmost argument. -} -taggedIntersection :: forall rt p wStart wX wY . Patchy p => - PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> +taggedIntersection :: forall rt p wStart wX wY . Commute p + => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> Fork (RL (Tagged rt p)) (RL (PatchInfoAnd rt p)) (RL (PatchInfoAnd rt p)) wStart wX wY -taggedIntersection (PatchSet NilRL ps1) s2 = Fork NilRL ps1 (newset2RL s2) -taggedIntersection s1 (PatchSet NilRL ps2) = Fork NilRL (newset2RL s1) ps2 +taggedIntersection (PatchSet NilRL ps1) s2 = Fork NilRL ps1 (patchSet2RL s2) +taggedIntersection s1 (PatchSet NilRL ps2) = Fork NilRL (patchSet2RL s1) ps2 taggedIntersection s1 (PatchSet (_ :<: Tagged t _ _) ps2) | Just (PatchSet ts1 ps1) <- maybeSplitSetOnTag (info t) s1 = Fork ts1 ps1 (unsafeCoercePStart ps2) @@ -172,7 +166,7 @@ Just (PatchSet com NilRL :> us) -> Fork com us (unsafeCoercePStart ps2) Just _ -> impossible - Nothing -> Fork NilRL (newset2RL s1) (newset2RL s2) + Nothing -> Fork NilRL (patchSet2RL s1) (patchSet2RL s2) -- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and -- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is @@ -188,7 +182,7 @@ Just $ PatchSet ts' (ps' +<+ ps) maybeSplitSetOnTag _ _ = Nothing -getPatchesBeyondTag :: Patchy p => PatchInfo -> PatchSet rt p wStart wX +getPatchesBeyondTag :: Commute p => PatchInfo -> PatchSet rt p wStart wX -> FlippedSeal (RL (PatchInfoAnd rt p)) wX getPatchesBeyondTag t (PatchSet (_ :<: Tagged hp _ _) ps) | info hp == t = flipSeal ps @@ -203,7 +197,7 @@ else case getPatchesBeyondTag t (PatchSet ts ps) of FlippedSeal xxs -> FlippedSeal (xxs :<: hp) getPatchesBeyondTag t (PatchSet NilRL NilRL) = - bug $ "tag\n" ++ renderString Encode (showPatchInfoUI t) + bug $ "tag\n" ++ renderString (displayPatchInfo t) ++ "\nis not in the patchset in getPatchesBeyondTag." getPatchesBeyondTag t0 (PatchSet (ts :<: Tagged t _ ps) NilRL) = getPatchesBeyondTag t0 (PatchSet ts (ps :<: t)) @@ -212,7 +206,7 @@ -- find the tag in the PatchSet, returning a pair: the clean PatchSet "up to" -- the tag, and a RL of patches after the tag; If the tag is not in the -- PatchSet, we return Nothing. -splitOnTag :: Patchy p => PatchInfo -> PatchSet rt p wStart wX +splitOnTag :: Commute p => PatchInfo -> PatchSet rt p wStart wX -> Maybe ((PatchSet rt p :> RL (PatchInfoAnd rt p)) wStart wX) -- If the tag we are looking for is the first Tagged tag of the patchset, just -- separate out the patchset's patches. @@ -323,7 +317,7 @@ appendPSFL ps' (hp :>: NilFL) | otherwise = appendPSFL (sops $ PatchSet ts ps) (hp :>: NilFL) -removeFromPatchSet :: Patchy p => FL (PatchInfoAnd rt p) wX wY +removeFromPatchSet :: Commute p => FL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY -> Maybe (PatchSet rt p wStart wX) removeFromPatchSet bad (PatchSet ts ps) | all (`elem` mapRL info ps) (mapFL info bad) = do ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps @@ -332,14 +326,14 @@ removeFromPatchSet bad (PatchSet (ts :<: Tagged t _ tps) ps) = removeFromPatchSet bad (PatchSet ts (tps :<: t +<+ ps)) -fastRemoveSubsequenceRL :: Patchy p +fastRemoveSubsequenceRL :: Commute p => RL (PatchInfoAnd rt p) wY wZ -> RL (PatchInfoAnd rt p) wX wZ -> Maybe (RL (PatchInfoAnd rt p) wX wY) fastRemoveSubsequenceRL NilRL ys = Just ys fastRemoveSubsequenceRL (xs:<:x) ys = fastRemoveRL x ys >>= fastRemoveSubsequenceRL xs -findCommonAndUncommon :: forall rt p wStart wX wY . Patchy p +findCommonAndUncommon :: forall rt p wStart wX wY . Commute p => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> Fork (PatchSet rt p) (FL (PatchInfoAnd rt p)) @@ -349,21 +343,21 @@ case partitionFL (infoIn them') $ reverseRL us' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" - ++ renderString Encode - (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) + ++ renderString + (vcat $ mapRL (displayPatchInfo . info) $ reverseFL bad) (common2 :> NilFL :> only_ours) -> case partitionFL (infoIn us') $ reverseRL them' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" - ++ renderString Encode (vcat $ - mapRL (showPatchInfoUI . info) $ reverseFL bad) + ++ renderString (vcat $ + mapRL (displayPatchInfo . info) $ reverseFL bad) _ :> NilFL :> only_theirs -> Fork (PatchSet common (reverseFL common2)) only_ours (unsafeCoercePStart only_theirs) where infoIn inWhat = (`elem` mapRL info inWhat) . info -findCommonWithThem :: Patchy p +findCommonWithThem :: Commute p => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart wX @@ -372,12 +366,12 @@ case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" - ++ renderString Encode - (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) + ++ renderString + (vcat $ mapRL (displayPatchInfo . info) $ reverseFL bad) common2 :> _nilfl :> only_ours -> PatchSet common (reverseFL common2) :> unsafeCoerceP only_ours -findUncommon :: Patchy p +findUncommon :: Commute p => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY findUncommon us them = @@ -385,7 +379,7 @@ _common :> us' -> case findCommonWithThem them us of _ :> them' -> unsafeCoercePStart us' :\/: them' -countUsThem :: Patchy p +countUsThem :: Commute p => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> (Int, Int) @@ -395,7 +389,7 @@ tt = mapRL info them' in (length $ uu \\ tt, length $ tt \\ uu) -mergeThem :: (Patchy p, Merge p) +mergeThem :: (Merge p) => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> Sealed (FL (PatchInfoAnd rt p) wX) mergeThem us them = @@ -404,28 +398,28 @@ case merge2FL (reverseRL us') (reverseRL them') of them'' :/\: _ -> Sealed them'' -newsetIntersection :: Patchy p +patchSetIntersection :: Commute p => [SealedPatchSet rt p wStart] -> SealedPatchSet rt p wStart -newsetIntersection [] = seal $ PatchSet NilRL NilRL -newsetIntersection [x] = x -newsetIntersection (Sealed y : ys) = - case newsetIntersection ys of +patchSetIntersection [] = seal $ PatchSet NilRL NilRL +patchSetIntersection [x] = x +patchSetIntersection (Sealed y : ys) = + case patchSetIntersection ys of Sealed z -> case taggedIntersection y z of Fork common a b -> case mapRL info a `intersect` mapRL info b of morecommon -> case partitionRL (\e -> info e `notElem` morecommon) a of commonps :> _ -> seal $ PatchSet common commonps -newsetUnion :: (Patchy p, Merge p) +patchSetUnion :: (Merge p) => [SealedPatchSet rt p wStart] -> SealedPatchSet rt p wStart -newsetUnion [] = seal $ PatchSet NilRL NilRL -newsetUnion [x] = x -newsetUnion (Sealed y@(PatchSet tsy psy) : Sealed y2 : ys) = +patchSetUnion [] = seal $ PatchSet NilRL NilRL +patchSetUnion [x] = x +patchSetUnion (Sealed y@(PatchSet tsy psy) : Sealed y2 : ys) = case mergeThem y y2 of Sealed p2 -> - newsetUnion $ seal (PatchSet tsy (psy +<+ reverseFL p2)) : ys + patchSetUnion $ seal (PatchSet tsy (psy +<+ reverseFL p2)) : ys -- | Merge two FLs (say L and R), starting in a common context. The result is a -- FL starting in the original end context of L, going to a new context that is @@ -440,7 +434,7 @@ -- (bf: I guess what was meant here is that 'merge2FL' works in the -- the way it does because it considers patch meta data whereas -- 'mergeFL' cannot since it must work for primitive patches, too. -merge2FL :: (Patchy p, Merge p) +merge2FL :: (Merge p) => FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wX wZ -> (FL (PatchInfoAnd rt p) :/\: FL (PatchInfoAnd rt p)) wY wZ @@ -454,7 +448,7 @@ ys'' :/\: xs' -> ys'' :/\: (x' :>: xs') -areUnrelatedRepos :: Patchy p +areUnrelatedRepos :: Commute p => PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> Bool areUnrelatedRepos us them = @@ -477,12 +471,7 @@ -- The types fit together (internally, in this module) because we commute the -- patch to the front before removing it and commutation inside a sequence does -- not change the sequence's contexts. --- --- However, the use sites outside this module are something different. We --- usually need coercions to get the patch(es) to be removed in shape. This is --- not very nice but probably unavoidable given the approximative nature of --- context witnesses. -fastRemoveFL :: Patchy p +fastRemoveFL :: Commute p => PatchInfoAnd rt p wX wY -- this type assumes element is at the front -> FL (PatchInfoAnd rt p) wX wZ -> Maybe (FL (PatchInfoAnd rt p) wY wZ) @@ -496,18 +485,18 @@ Just (b' :>: bs') where i = info a - pullout :: Patchy p + pullout :: Commute p => RL (PatchInfoAnd rt p) wA wB -> FL (PatchInfoAnd rt p) wB wC -> Maybe ((PatchInfoAnd rt p :> FL (PatchInfoAnd rt p)) wA wC) pullout _ NilFL = Nothing pullout acc (x :>: xs) | info x == i = do x' :> acc' <- commuteRL (acc :> x) - Just (x' :> reverseRL acc' +>+ xs) + Just (x' :> acc' +>>+ xs) | otherwise = pullout (acc :<: x) xs -- | Same as 'fastRemoveFL' only for 'RL'. -fastRemoveRL :: Patchy p +fastRemoveRL :: Commute p => PatchInfoAnd rt p wY wZ -- this type assumes element is at the back -> RL (PatchInfoAnd rt p) wX wZ -> Maybe (RL (PatchInfoAnd rt p) wX wY) @@ -521,12 +510,12 @@ Just (bs' :<: b') where i = info a - pullout :: Patchy p + pullout :: Commute p => RL (PatchInfoAnd rt p) wA wB -> FL (PatchInfoAnd rt p) wB wC -> Maybe ((RL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wA wC) pullout NilRL _ = Nothing pullout (xs :<: x) acc | info x == i = do acc' :> x' <- commuteFL (x :> acc) - Just (xs +<+ reverseFL acc' :> x') + Just (xs +<<+ acc' :> x') | otherwise = pullout xs (x :>: acc) diff --git a/src/Darcs/Patch/Dummy.hs b/src/Darcs/Patch/Dummy.hs --- a/src/Darcs/Patch/Dummy.hs +++ b/src/Darcs/Patch/Dummy.hs @@ -2,24 +2,28 @@ {-# LANGUAGE EmptyDataDecls #-} module Darcs.Patch.Dummy ( DummyPatch ) where +import Darcs.Patch.Annotate ( Annotate ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.Patchy - ( Patchy, ShowPatch, Invert, Commute, Apply(..), PatchInspect - , ReadPatch ) -import Darcs.Patch.Prim ( FromPrim, PrimPatch, PrimPatchBase(..) ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute ) +import Darcs.Patch.Invert ( Invert ) +import Darcs.Patch.Inspect ( PatchInspect ) +import Darcs.Patch.Read ( ReadPatch ) +import Darcs.Patch.Show ( ShowPatch ) +import Darcs.Patch.Prim ( FromPrim, PrimPatchCommon, PrimPatch, PrimPatchBase(..) ) import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize, PrimClassify , PrimDetails, PrimShow, PrimRead, PrimApply ) import Darcs.Patch.Merge ( Merge) import Darcs.Patch.Repair ( Check, RepairToFL ) import Darcs.Patch.RepoPatch ( RepoPatch ) -import Darcs.Patch.Show ( ShowPatchBasic ) -import Darcs.Patch.Witnesses.Eq ( MyEq ) +import Darcs.Patch.Show ( ShowPatchBasic, ShowContextPatch ) +import Darcs.Patch.Witnesses.Eq ( Eq2 ) import Darcs.Patch.Witnesses.Show ( Show2 ) import Darcs.Util.Tree( Tree ) @@ -29,15 +33,16 @@ instance IsHunk DummyPrim instance PatchListFormat DummyPrim -instance MyEq DummyPrim +instance Eq2 DummyPrim instance Invert DummyPrim instance PatchInspect DummyPrim instance ReadPatch DummyPrim instance ShowPatchBasic DummyPrim instance ShowPatch DummyPrim +instance ShowContextPatch DummyPrim instance Commute DummyPrim -instance Apply DummyPrim -instance Patchy DummyPrim +instance Apply DummyPrim where + type ApplyState DummyPrim = Tree instance RepairToFL DummyPrim instance PrimConstruct DummyPrim @@ -52,20 +57,23 @@ instance PatchDebug DummyPrim +instance PrimPatchCommon DummyPrim + instance IsHunk DummyPatch instance PatchListFormat DummyPatch -instance MyEq DummyPatch +instance Eq2 DummyPatch instance Invert DummyPatch instance PatchInspect DummyPatch instance ReadPatch DummyPatch instance ShowPatchBasic DummyPatch instance ShowPatch DummyPatch +instance ShowContextPatch DummyPatch instance Show2 DummyPatch instance Commute DummyPatch instance Apply DummyPatch where type ApplyState DummyPatch = Tree instance Matchable DummyPatch -instance Patchy DummyPatch +instance Annotate DummyPatch instance Effect DummyPatch instance Merge DummyPatch diff --git a/src/Darcs/Patch/Format.hs b/src/Darcs/Patch/Format.hs --- a/src/Darcs/Patch/Format.hs +++ b/src/Darcs/Patch/Format.hs @@ -1,7 +1,6 @@ module Darcs.Patch.Format ( PatchListFormat(..) , ListFormat(..) - , copyListFormat , FileNameFormat(..) ) where @@ -29,10 +28,8 @@ | ListFormatV2 -- ^ Show lists without braces. Read with arbitrary -- nested parens and flatten them out. -copyListFormat :: ListFormat p -> ListFormat q -copyListFormat ListFormatDefault = ListFormatDefault -copyListFormat ListFormatV1 = ListFormatV1 -copyListFormat ListFormatV2 = ListFormatV2 - -data FileNameFormat = OldFormat - | NewFormat +data FileNameFormat + = OldFormat -- ^ on-disk format for V1 patches + | NewFormat -- ^ on-disk format for V2 patches + | UserFormat -- ^ display format + deriving (Eq, Show) diff --git a/src/Darcs/Patch/Index/Monad.hs b/src/Darcs/Patch/Index/Monad.hs --- a/src/Darcs/Patch/Index/Monad.hs +++ b/src/Darcs/Patch/Index/Monad.hs @@ -17,15 +17,21 @@ -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Darcs.Patch.Index.Monad ( FileModMonad, withPatchMods ) where +module Darcs.Patch.Index.Monad + ( withPatchMods + , applyToFileMods + , makePatchID + ) where import Prelude () import Darcs.Prelude -import Darcs.Patch.Index.Types ( PatchMod(..) ) +import Darcs.Patch.Index.Types ( PatchMod(..), PatchId(..) ) +import Darcs.Patch.Info ( makePatchname, PatchInfo ) +import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) ) import Control.Monad.State import Control.Arrow @@ -34,7 +40,6 @@ import Data.Set ( Set ) import Data.List ( isPrefixOf ) import Darcs.Util.Tree (Tree) -#include "impossible.h" newtype FileModMonad a = FMM (State (Set FileName, [PatchMod FileName]) a) deriving (Functor, Applicative, Monad, MonadState (Set FileName, [PatchMod FileName])) @@ -79,7 +84,6 @@ addMod (PRename fn newfn) mModifyFilePS f _ = addMod (PTouch f) - mModifyFilePSs f _ = addMod (PTouch f) -- --------------------------------------------------------------------- -- State Handling Functions @@ -117,3 +121,11 @@ modifyFps :: (Set FileName -> Set FileName) -> FileModMonad () modifyFps f = modify $ first f + +makePatchID :: PatchInfo -> PatchId +makePatchID = PID . makePatchname + +-------------------------------------------------------------------------------- +-- | Apply a patch to set of 'FileName's, yielding the new set of 'FileName's and 'PatchMod's +applyToFileMods :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Set FileName -> (Set FileName, [PatchMod FileName]) +applyToFileMods patch = withPatchMods (apply patch) diff --git a/src/Darcs/Patch/Index/Types.hs b/src/Darcs/Patch/Index/Types.hs --- a/src/Darcs/Patch/Index/Types.hs +++ b/src/Darcs/Patch/Index/Types.hs @@ -21,9 +21,8 @@ import Prelude () import Darcs.Prelude -import Darcs.Util.Crypt.SHA1( SHA1(..) ) -import Darcs.Util.Path ( fp2fn, fn2fp, FileName ) -import Darcs.Patch.Info ( makePatchname, PatchInfo ) +import Darcs.Util.Hash( SHA1, sha1short, sha1zero ) +import Darcs.Util.Path ( fn2fp, FileName ) import Data.Binary ( Binary(..) ) import Data.Word ( Word32 ) @@ -40,10 +39,6 @@ (rfp,cnt) <- get return $ FileId rfp cnt --- | Parse FileId from a string -parseFileId :: String -> FileId -parseFileId s = let (f,'.':i) = break (=='.') s in FileId (fp2fn f) (read i) - -- | Convert FileId to string showFileId :: FileId -> String showFileId (FileId fn i) = show i++"#"++fn2fp fn @@ -59,12 +54,6 @@ pid2string :: PatchId -> String pid2string = show . patchId --- | describes a filepath that is interpreted relative to a certain --- point in the history of the repository. The point is given by --- Just pid which denotes the history up to (including) pid or --- Nothing which denotes the history including the last patch -data DatedFilePath = DatedFilePath FilePath (Maybe PatchId) - -- | This is used to track changes to files data PatchMod a = PTouch a | PCreateFile a @@ -79,9 +68,9 @@ -- track of them deriving (Show, Eq, Functor) -makePatchID :: PatchInfo -> PatchId -makePatchID = PID . makePatchname - short :: PatchId -> Word32 -short (PID (SHA1 a _ _ _ _)) = a +short (PID sha1) = sha1short sha1 + +zero :: PatchId +zero = PID sha1zero 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 @@ -15,48 +15,77 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Patch.Info ( PatchInfo(..), patchinfo, invertName, - rawPatchInfo, - addJunk, makePatchname, - makeFilename, readPatchInfo, - justName, justAuthor, justLog, - showPatchInfoUI, toXml, piDate, - setPiDate, piDateString, piDateBytestring, - piName, piRename, piAuthor, piTag, piLog, - showPatchInfo, isTag, readPatchInfos, escapeXML - ) where +module Darcs.Patch.Info + ( PatchInfo(..) -- constructor and fields exported *only for tests* + , rawPatchInfo -- exported *only for tests* + , patchinfo + , invertName + , addJunk + , makePatchname + , readPatchInfo + , justName + , justAuthor + , justLog + , displayPatchInfo + , toXml + , toXmlShort + , piDate + , setPiDate + , piDateString + , piName + , piRename + , piAuthor + , piTag + , piLog + , showPatchInfo + , isTag + , escapeXML + , validDate + , validLog + , validAuthor + , validDatePS + , validLogPS + , validAuthorPS + ) where -import Prelude () +import Prelude ( (^) ) import Darcs.Prelude +import Data.Char ( isAscii ) import System.Random ( randomRIO ) import Numeric ( showHex ) import Control.Monad ( when, unless, void ) -import Darcs.Util.ByteString ( unlinesPS, packStringToUTF8, unpackPSFromUTF8, decodeLocale) +import Darcs.Util.ByteString + ( decodeLocale + , packStringToUTF8 + , unlinesPS + , unpackPSFromUTF8 + ) import qualified Darcs.Patch.ReadMonads as RM ( take ) import Darcs.Patch.ReadMonads as RM ( skipSpace, char, takeTill, anyChar, ParserM, - option, parseStrictly, + option, takeTillChar, linesStartingWithEndingWith) +import Darcs.Patch.Show ( ShowPatchFor(..) ) import qualified Data.ByteString as B (length, splitAt, null ,isPrefixOf, tail, concat ,empty, head, cons, append ,ByteString ) -import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack) +import qualified Data.ByteString.Char8 as BC + ( index, head, notElem, all, unpack, pack ) import Data.List( isPrefixOf ) import Darcs.Util.Printer ( Doc, packedString, empty, ($$), (<>), (<+>), vcat, text, cyanText, blueText, prefix ) -import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) -import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, +import Darcs.Util.IsoDate ( readUTCDate ) +import System.Time ( CalendarTime, calendarTimeToString, toClockTime, toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO ) -import Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1 ) +import Darcs.Util.Hash ( sha1PS, SHA1 ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Show ( appPrec ) -import Prelude hiding (pi, log) -- | A PatchInfo value contains the metadata of a patch. The date, name, author -- and log fields are UTF-8 encoded text in darcs 2.4 and later, and just @@ -82,13 +111,47 @@ showString " " . showsPrec (appPrec + 1) log . showString " " . showsPrec (appPrec + 1) inverted +-- Validation + +-- We need these functions to ensure that we can parse the +-- result of showPatchInfo. + +validDate :: String -> Bool +validDate = all validCharForDate + +validDatePS :: B.ByteString -> Bool +validDatePS = BC.all validCharForDate + +-- | The isAscii limitation is due to the use of BC.pack below. +validCharForDate :: Char -> Bool +validCharForDate c = isAscii c && c /= '\n' && c /= ']' + +validLog :: String -> Bool +validLog = notElem '\n' + +validLogPS :: B.ByteString -> Bool +validLogPS = BC.notElem '\n' + +validAuthor :: String -> Bool +validAuthor = notElem '*' + +validAuthorPS :: B.ByteString -> Bool +validAuthorPS = BC.notElem '*' + rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo rawPatchInfo date name author log inverted = - PatchInfo { _piDate = BC.pack date - , _piName = packStringToUTF8 name - , _piAuthor = packStringToUTF8 author - , _piLog = map packStringToUTF8 log + PatchInfo { _piDate = BC.pack $ validateDate date + , _piName = packStringToUTF8 $ validateName name + , _piAuthor = packStringToUTF8 $ validateAuthor author + , _piLog = map (packStringToUTF8 . validateLog) log , isInverted = inverted } + where + validateAuthor = validate validAuthor "author" + validateName = validate validLog "patch name" + validateLog = validate validLog "log line" + validateDate = validate validDate "date" + validate test meta x = + if test x then x else error (unwords ["invalid",meta,show x]) -- | @patchinfo date name author log@ constructs a new 'PatchInfo' value -- with the given details, automatically assigning an Ignore-this header @@ -104,7 +167,8 @@ addJunk pinf = do x <- randomRIO (0,2^(128 ::Integer) :: Integer) when (_piLog pinf /= ignoreJunk (_piLog pinf)) $ - do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored." + do putStrLn $ "Lines beginning with 'Ignore-this: ' " ++ + "will not be shown when displaying a patch." confirmed <- promptYorn "Proceed? " unless confirmed $ fail "User cancelled because of Ignore-this." return $ pinf { _piLog = BC.pack (head ignored++showHex x ""): @@ -136,8 +200,8 @@ justLog :: PatchInfo -> String justLog = unlines . map BC.unpack . _piLog -showPatchInfoUI :: PatchInfo -> Doc -showPatchInfoUI pi = +displayPatchInfo :: PatchInfo -> Doc +displayPatchInfo pi = cyanText "patch " <> cyanText (show $ makePatchname pi) $$ text "Author: " <> text (piAuthor pi) $$ text "Date: " <> text (friendlyD $ _piDate pi) @@ -163,16 +227,12 @@ isTag :: PatchInfo -> Bool isTag pinfo = "TAG " `isPrefixOf` justName pinfo --- | Note: we ignore timezone information in the date string, --- systematically treating a time as UTC. So if the patch --- tells me it's 17:00 EST, we're actually treating it as --- 17:00 UTC, in other words 11:00 EST. This is for --- backwards compatibility to darcs prior to 2003-11, sometime --- before 1.0. Fortunately, newer patch dates are written in --- UTC, so this timezone truncation is harmless for them. +-- | Read the date from raw patch (meta) data and convert it to UTC. +-- The raw data may contain timezone info. This is for compatibiltity +-- with patches that were created before 2003-11, when darcs still +-- created patches that contained localized date strings. readPatchDate :: B.ByteString -> CalendarTime -readPatchDate = ignoreTz . readUTCDate . BC.unpack - where ignoreTz ct = ct { ctTZ = 0 } +readPatchDate = readUTCDate . BC.unpack piDate :: PatchInfo -> CalendarTime piDate = readPatchDate . _piDate @@ -180,9 +240,6 @@ piDateString :: PatchInfo -> String piDateString = BC.unpack . _piDate -piDateBytestring :: PatchInfo -> B.ByteString -piDateBytestring = _piDate - setPiDate :: String -> PatchInfo -> PatchInfo setPiDate date pi = pi { _piDate = BC.pack date } @@ -209,23 +266,31 @@ where bsUtf8 = unpackPSFromUTF8 bs friendlyD :: B.ByteString -> String ---friendlyD d = calendarTimeToString . readPatchDate . d friendlyD d = unsafePerformIO $ do ct <- toCalendarTime $ toClockTime $ readPatchDate d return $ calendarTimeToString ct toXml :: PatchInfo -> Doc -toXml pi = +toXml = toXml' True + +toXmlShort :: PatchInfo -> Doc +toXmlShort = toXml' False + +toXml' :: Bool -> PatchInfo -> Doc +toXml' includeComments pi = text " text "author='" <> escapeXMLByteString (_piAuthor pi) <> text "'" <+> text "date='" <> escapeXMLByteString (_piDate pi) <> text "'" <+> text "local_date='" <> escapeXML (friendlyD $ _piDate pi) <> text "'" <+> text "inverted='" <> text (show $ isInverted pi) <> text "'" <+> text "hash='" <> text (show $ makePatchname pi) <> text "'>" - $$ prefix "\t" ( - text "" <> escapeXMLByteString (_piName pi) <> text "" - $$ commentsAsXml (_piLog pi)) - $$ text "" + $$ indent abstract + $$ text "" + where + indent = prefix " " + name = text "" <> escapeXMLByteString (_piName pi) <> text "" + abstract | includeComments = name $$ commentsAsXml (_piLog pi) + | otherwise = name commentsAsXml :: [B.ByteString] -> Doc commentsAsXml comments @@ -264,22 +329,6 @@ else B.cons (B.head bs) (bstrReplace c s (B.tail bs)) --- | This makes darcs-1 (non-hashed repos) filenames, and is also generally --- used in both in hashed and non-hashed repo code for making patch "hashes". --- --- The name consists of three segments: --- --- * timestamp (ISO8601-compatible yyyymmmddHHMMSS, UTC) --- --- * SHA1 hash of the author --- --- * SHA1 hash of the patch name, author, date, log, and \"inverted\" --- flag. -makeFilename :: PatchInfo -> String -makeFilename pi = showIsoDateTime d++"-"++sha1_a++"-"++ (show $ makePatchname pi) ++ ".gz" - where d = readPatchDate $ _piDate pi - sha1_a = take 5 $ show $ sha1PS $ _piAuthor pi - -- | Hash on patch metadata (patch name, author, date, log, and \"inverted\" -- flag. Robust against context changes but does not garantee patch contents. -- Usually used as matcher or patch identifier (see Darcs.Patch.Match). @@ -294,6 +343,10 @@ b2ps $ isInverted pi] +showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc +showPatchInfo ForDisplay = displayPatchInfo +showPatchInfo ForStorage = storePatchInfo + -- |Patch is stored between square brackets. -- -- > [ @@ -306,8 +359,9 @@ -- -- note that below I assume the name has no newline in it. -- See 'readPatchInfo' for the inverse operation. -showPatchInfo :: PatchInfo -> Doc -showPatchInfo pi = +-- There are more assumptions, see validation functions above. +storePatchInfo :: PatchInfo -> Doc +storePatchInfo pi = blueText "[" <> packedString (_piName pi) $$ packedString (_piAuthor pi) <> text inverted <> packedString (_piDate pi) <> myunlines (_piLog pi) <> blueText "] " @@ -343,10 +397,3 @@ , _piLog = log , isInverted = BC.index s2 1 /= '*' } - -readPatchInfos :: B.ByteString -> [PatchInfo] -readPatchInfos inv | B.null inv = [] -readPatchInfos inv = case parseStrictly readPatchInfo inv of - Just (pinfo,r) -> pinfo : readPatchInfos r - _ -> [] - diff --git a/src/Darcs/Patch/Invert.hs b/src/Darcs/Patch/Invert.hs --- a/src/Darcs/Patch/Invert.hs +++ b/src/Darcs/Patch/Invert.hs @@ -6,7 +6,8 @@ import Prelude () import Darcs.Prelude -import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL ) +import Darcs.Patch.Witnesses.Ordered + ( FL(..), RL(..), reverseFL, reverseRL, (:>)(..) ) class Invert p where @@ -25,3 +26,6 @@ instance Invert p => Invert (RL p) where invert = reverseFL . invertRL + +instance Invert p => Invert (p :> p) where + invert (a :> b) = invert b :> invert a diff --git a/src/Darcs/Patch/Match.hs b/src/Darcs/Patch/Match.hs --- a/src/Darcs/Patch/Match.hs +++ b/src/Darcs/Patch/Match.hs @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-} -- | /First matcher, Second matcher and Nonrange matcher/ -- @@ -47,11 +47,11 @@ , splitSecondFL , matchPatch , matchAPatch - , matchAPatchread , getNonrangeMatchS , firstMatch , secondMatch , haveNonrangeMatch + , haveNonrangeExplicitMatch , havePatchsetMatch , checkMatchSyntax , applyInvToMatcher @@ -102,8 +102,7 @@ import Darcs.Util.Path ( AbsolutePath ) import Darcs.Patch - ( Patchy - , IsRepoType + ( IsRepoType , hunkMatches , listTouchedFiles , invert @@ -125,11 +124,12 @@ import Darcs.Patch.MonadProgress ( MonadProgress ) import Darcs.Patch.Named.Wrapped ( runInternalChecker, namedIsInternal, namedInternalChecker ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously, hopefully ) -import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, Origin ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, patchSet2RL, Origin ) import Darcs.Patch.Type ( PatchType(..) ) -import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.Apply( Apply, ApplyState ) import Darcs.Patch.ApplyPatches( applyPatches ) import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag ) +import Darcs.Patch.Invert( Invert ) import Darcs.Patch.Witnesses.Eq ( isIsEq ) import Darcs.Patch.Witnesses.Ordered ( RL(..), snocRLSealed, FL(..), (:>)(..) ) @@ -142,7 +142,6 @@ import Darcs.Util.DateMatcher ( parseDateMatcher ) import Darcs.Util.Tree ( Tree ) -#include "impossible.h" -- | A type for predicates over patches which do not care about -- contexts @@ -177,7 +176,7 @@ deriving ( Show ) -makeMatcher :: String -> (Sealed2 (PatchInfoAnd rt p) -> Bool) -> Matcher rt p +makeMatcher :: String -> MatchFun rt p -> Matcher rt p makeMatcher = MATCH -- | @applyMatcher@ applies a matcher to a patch. @@ -197,7 +196,7 @@ Left err -> error err Right m -> makeMatcher pattern m -addInternalMatcher :: (IsRepoType rt, Matchable p) => Maybe (Matcher rt p) -> Maybe (Matcher rt p) +addInternalMatcher :: (IsRepoType rt) => Maybe (Matcher rt p) -> Maybe (Matcher rt p) addInternalMatcher om = case namedInternalChecker of Nothing -> om @@ -218,16 +217,16 @@ -- When using , Parsec prepends "expecting " to the given error message, -- so the phrasing below makes sense. helpfulErrorMsg = "valid expressions over: " - ++ intercalate ", " (map (\(name, _, _, _) -> name) ps) + ++ intercalate ", " (map (\(name, _, _, _, _) -> name) ps) ++ "\nfor more help, see `darcs help patterns`." -- This type signature is just to bind an ambiguous type var. - ps :: [(String, String, [String], String -> MatchFun rt DummyPatch)] + ps :: [(String, String, String, [String], String -> MatchFun rt DummyPatch)] ps = primitiveMatchers -- matchAnyPatch is returned if submatch fails without consuming any -- input, i.e. if we pass --match '', we want to match anything. - matchAnyPatch :: Matchable p => MatchFun rt p + matchAnyPatch :: MatchFun rt p matchAnyPatch = const True submatch :: Matchable p => CharParser st (MatchFun rt p) @@ -258,16 +257,15 @@ where matchers_ = map createMatchHelper primitiveMatchers -createMatchHelper :: (String, String, [String], String -> MatchFun rt p) +createMatchHelper :: (String, String, String, [String], String -> MatchFun rt p) -> CharParser st (MatchFun rt p) -createMatchHelper (key,_,_,matcher) = +createMatchHelper (key,_,_,_,matcher) = do _ <- trystring key spaces q <- quoted return $ matcher q --- FIXME: would this be better defined in Darcs.Commands.Help? --- | The string that is emitted when the user runs @darcs help --match@. +-- | The string that is emitted when the user runs @darcs help patterns@. helpOnMatchers :: [String] helpOnMatchers = ["Selecting Patches:", @@ -291,45 +289,42 @@ ++ ["", "Here are some examples:", ""] ++ examples where -- This type signature exists to appease GHC. - ps :: [(String, String, [String], String -> MatchFun rt DummyPatch)] + ps :: [(String, String, String, [String], String -> MatchFun rt DummyPatch)] ps = primitiveMatchers - keywords = [showKeyword k d | (k,d,_,_) <- ps] - examples = [showExample k e | (k,_,es,_) <- ps, e <- es] + keywords = [showKeyword (unwords [k,a]) d | (k,a,d,_,_) <- ps] + examples = [showExample k e | (k,_,_,es,_) <- ps, e <- es] showKeyword keyword description = - -- FIXME: it would be nice to have a variable name here: - -- "author REGEX - match against author (email address)" - -- or "exact STRING - match against exact patch name". - "- " ++ keyword ++ " - " ++ description ++ "." + " " ++ keyword ++ " - " ++ description ++ "." showExample keyword example = - " darcs log --match " + " darcs log --match " ++ "'" ++ keyword ++ " " ++ example ++ "'" -primitiveMatchers :: Matchable p => [(String, String, [String], String -> MatchFun rt p)] - -- ^ keyword (operator), help description, list +primitiveMatchers :: Matchable p => [(String, String, String, [String], String -> MatchFun rt p)] + -- ^ keyword (operator), argument name, help description, list -- of examples, matcher function primitiveMatchers = - [ ("exact", "check a literal string against the patch name" + [ ("exact", "STRING", "check literal STRING is equal to patch name" , ["\"Resolve issue17: use dynamic memory allocation.\""] , exactmatch ) - , ("name", "check a regular expression against the patch name" + , ("name", "REGEX", "match REGEX against patch name" , ["issue17", "\"^[Rr]esolve issue17\\>\""] , namematch ) - , ("author", "check a regular expression against the author name" + , ("author", "REGEX", "match REGEX against patch author" , ["\"David Roundy\"", "droundy", "droundy@darcs.net"] , authormatch ) - , ("hunk", "check a regular expression against the contents of a hunk patch" + , ("hunk", "REGEX", "match REGEX against contents of a hunk patch" , ["\"foo = 2\"", "\"^instance .* Foo where$\""] , hunkmatch ) - , ("comment", "check a regular expression against the log message" + , ("comment", "REGEX", "match REGEX against the full log message" , ["\"prevent deadlocks\""] , logmatch ) - , ("hash", "match a full hash or a prefix for a patch" + , ("hash", "HASH", "match HASH against (a prefix of) the hash of a patch" , ["c719567e92c3b0ab9eddd5290b705712b8b918ef","c7195"] , hashmatch ) - , ("date", "match the patch date" + , ("date", "DATE", "match DATE against the patch date" , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""] , datematch ) - , ("touch", "match file paths for a patch" + , ("touch", "REGEX", "match file paths for a patch" , ["src/foo.c", "src/", "\"src/*.(c|h)\""] , touchmatch ) ] @@ -346,7 +341,10 @@ <|> between spaces spaces (many $ noneOf " ()") "string" -namematch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch +datematch, hashmatch, authormatch, exactmatch, namematch, logmatch + :: String -> MatchFun rt p + +hunkmatch, touchmatch :: Matchable p => String -> MatchFun rt p namematch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp) @@ -355,7 +353,6 @@ authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp) -logmatch :: Matchable p => String -> MatchFun rt p logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp) hunkmatch r (Sealed2 hp) = let regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack @@ -373,14 +370,31 @@ data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq +data IncludeInternalPatches = IncludeInternalPatches | ExcludeInternalPatches + deriving Eq + -- | @haveNonrangeMatch flags@ tells whether there is a flag in -- @flags@ which corresponds to a match that is "non-range". Thus, -- @--match@, @--patch@, @--hash@ and @--index@ make @haveNonrangeMatch@ -- true, but not @--from-patch@ or @--to-patch@. -haveNonrangeMatch :: forall rt p . (IsRepoType rt, Matchable p) => PatchType rt p -> [MatchFlag] -> Bool -haveNonrangeMatch _ fs = +haveNonrangeMatch :: forall rt p . (IsRepoType rt, Matchable p) + => PatchType rt p -> [MatchFlag] -> Bool +haveNonrangeMatch pt fs = haveNonrangeMatch' IncludeInternalPatches pt fs + +-- | @haveNonrangeExplicitMatch flags@ is just like @haveNonrangeMatch flags@, +-- but ignores "internal matchers" used to mask "internal patches" +haveNonrangeExplicitMatch :: forall rt p . (IsRepoType rt, Matchable p) + => PatchType rt p -> [MatchFlag] -> Bool +haveNonrangeExplicitMatch pt fs = haveNonrangeMatch' ExcludeInternalPatches pt fs + +haveNonrangeMatch' :: forall rt p . (IsRepoType rt, Matchable p) + => IncludeInternalPatches -> PatchType rt p -> [MatchFlag] -> Bool +haveNonrangeMatch' i _ fs = case hasIndexRange fs of Just (m,n) | m == n -> True; _ -> False - || isJust (nonrangeMatcher fs::Maybe (Matcher rt p)) + || isJust (nonrangeMatch::Maybe (Matcher rt p)) + where + nonrangeMatch | i == IncludeInternalPatches = nonrangeMatcher fs + | otherwise = nonrangeMatcherArgs fs -- | @havePatchsetMatch flags@ tells whether there is a "patchset -- match" in the flag list. A patchset match is @--match@ or @@ -438,11 +452,11 @@ secondMatch :: [MatchFlag] -> Bool secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher rt DummyPatch)) || isJust (hasIndexRange fs) -unpullLastN :: (ApplyMonad (ApplyState p) m, MonadProgress m, Patchy p, IsRepoType rt) +unpullLastN :: (Apply p, Invert p, ApplyMonad (ApplyState p) m, MonadProgress m, IsRepoType rt) => PatchSet rt p wX wY -> Int -> m () -unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (newset2RL repo) +unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (patchSet2RL repo) checkMatchSyntax :: [MatchFlag] -> IO () checkMatchSyntax opts = @@ -456,16 +470,16 @@ getMatchPattern (SeveralPattern m:_) = Just m getMatchPattern (_:fs) = getMatchPattern fs -tagmatch :: Matchable p => String -> Matcher rt p +tagmatch :: String -> Matcher rt p tagmatch r = makeMatcher ("tag-name "++r) tm where tm (Sealed2 p) = let n = justName (info p) in "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n) -patchmatch :: Matchable p => String -> Matcher rt p +patchmatch :: String -> Matcher rt p patchmatch r = makeMatcher ("patch-name "++r) (namematch r) -hashmatch' :: Matchable p => String -> Matcher rt p +hashmatch' :: String -> Matcher rt p hashmatch' r = makeMatcher ("hash "++r) (hashmatch r) @@ -535,18 +549,11 @@ secondMatcherIsTag (UpToTag _:_) = True secondMatcherIsTag (_:fs) = secondMatcherIsTag fs --- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in --- the flags listed in @fs@. -matchAPatchread :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchInfoAnd rt p wX wY -> Bool -matchAPatchread fs = case nonrangeMatcher fs of - Nothing -> const True - Just m -> applyMatcher m - -- | @matchAPatch fs p@ tells whether @p@ matches the matchers in -- the flags @fs@ matchAPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchInfoAnd rt p wX wY -> Bool matchAPatch fs p = - case nonrangeMatcher fs of + case nonrangeMatcher fs of Nothing -> True Just m -> applyMatcher m p @@ -647,8 +654,8 @@ findAPatch m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal2 $ hopefully p | otherwise = findAPatch m (PatchSet ts ps) --- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@ --- ending in patch which matches @m@. Calls 'error' if there is none. +-- | @matchAPatchset m ps@ returns a prefix of @ps@ +-- ending in a patch matching @m@, and calls 'error' if there is none. matchAPatchset :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m @@ -723,7 +730,7 @@ -- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd -- patch', and to apply its inverse. If we fail to fetch the patch -- then we share our sorrow with the user. -applyInvp :: (Patchy p, ApplyMonad (ApplyState p) m) => PatchInfoAnd rt p wX wY -> m () +applyInvp :: (Apply p, Invert p, ApplyMonad (ApplyState p) m) => PatchInfoAnd rt p wX wY -> m () applyInvp hp = apply (invert $ fromHopefully hp) where fromHopefully = conscientiously $ \e -> text "Sorry, patch not available:" @@ -739,5 +746,5 @@ safetake i (as:<:a) | isIsEq (namedIsInternal (hopefully a)) = safetake i as `snocRLSealed` a safetake i (as:<:a) = safetake (i-1) as `snocRLSealed` a -applyInvRL :: (ApplyMonad (ApplyState p) m, MonadProgress m, Patchy p) => RL (PatchInfoAnd rt p) wX wR -> m () +applyInvRL :: (Apply p, Invert p, ApplyMonad (ApplyState p) m, MonadProgress m) => RL (PatchInfoAnd rt p) wX wR -> m () applyInvRL = applyPatches . invertRL -- this gives nicer feedback diff --git a/src/Darcs/Patch/Matchable.hs b/src/Darcs/Patch/Matchable.hs --- a/src/Darcs/Patch/Matchable.hs +++ b/src/Darcs/Patch/Matchable.hs @@ -5,7 +5,9 @@ module Darcs.Patch.Matchable ( Matchable ) where import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.Patchy ( Patchy ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) -class (Patchy p, PatchInspect p) +class (Apply p, Commute p, Invert p, PatchInspect p) => Matchable p diff --git a/src/Darcs/Patch/Merge.hs b/src/Darcs/Patch/Merge.hs --- a/src/Darcs/Patch/Merge.hs +++ b/src/Darcs/Patch/Merge.hs @@ -5,24 +5,43 @@ -- Portability : portable module Darcs.Patch.Merge - ( + ( -- * Definitions Merge(..) , selfMerger , mergeFL + , naturalMerge + -- * Properties + , prop_mergeSymmetric + , prop_mergeCommute ) where -import Darcs.Patch.Commute ( Commute ) +import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.CommuteFn ( MergeFn ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), isIsEq ) import Darcs.Patch.Witnesses.Ordered ( (:\/:)(..) , (:/\:)(..) , FL(..) , RL + , (:>)(..) , reverseFL , reverseRL ) --- | Things that can always be merged +-- | Things that can always be merged. +-- +-- Instances should obey the following laws: +-- +-- * Symmetry +-- +-- prop> merge (p :\/: q) == q' :/\: p' <=> merge (q :\/: p) == p' :/\: q' +-- +-- * MergesCommute +-- +-- prop> merge (p :\/: q) == q' :/\: p' ==> commute (p :> q') == Just (q :> p') +-- +-- that is, the two branches of a merge commute to each other class Commute p => Merge p where merge :: (p :\/: p) wX wY -> (p :/\: p) wX wY @@ -48,3 +67,35 @@ mergeFL (p :\/: (x :>: xs)) = case merge (p :\/: x) of x' :/\: p' -> case mergeFL (p' :\/: xs) of xs' :/\: p'' -> (x' :>: xs') :/\: p'' + +-- | The natural, non-conflicting merge. +naturalMerge :: (Invert p, Commute p) + => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY) +naturalMerge (p :\/: q) = do + q' :> ip' <- commute (invert p :> q) + -- TODO: find a small convincing example that demonstrates why + -- it is necessary to do this extra check here + _ <- commute (p :> q') + return (q' :/\: invert ip') + +prop_mergeSymmetric :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool +prop_mergeSymmetric (p :\/: q) = + case merge (p :\/: q) of + q' :/\: p' -> + case merge (q :\/: p) of + p'' :/\: q'' -> + isIsEq (q' =\/= q'') && isIsEq (p' =\/= p'') + +prop_mergeCommute :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool +prop_mergeCommute (p :\/: q) = + case merge (p :\/: q) of + q' :/\: p' -> + case commute (p :> q') of + Nothing -> False + Just (q'' :> p'') -> + isIsEq (q'' =\/= q) && isIsEq (p'' =/\= p') + && + case commute (q :> p') of + Nothing -> False + Just (p'' :> q'') -> + isIsEq (p'' =\/= p) && isIsEq (q'' =/\= q') diff --git a/src/Darcs/Patch/MonadProgress.hs b/src/Darcs/Patch/MonadProgress.hs --- a/src/Darcs/Patch/MonadProgress.hs +++ b/src/Darcs/Patch/MonadProgress.hs @@ -55,5 +55,5 @@ silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m () silentlyRunProgressActions _ = mapM_ paAction -instance (Functor m, Monad m) => MonadProgress (TM.TreeMonad m) where +instance (Monad m) => MonadProgress (TM.TreeMonad m) where runProgressActions = silentlyRunProgressActions diff --git a/src/Darcs/Patch/Named.hs b/src/Darcs/Patch/Named.hs --- a/src/Darcs/Patch/Named.hs +++ b/src/Darcs/Patch/Named.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.Patch.Named ( Named(..), infopatch, @@ -42,25 +39,30 @@ import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, patchinfo, - showPatchInfoUI, makePatchname, invertName ) + piName, displayPatchInfo, makePatchname, invertName ) import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Patchy ( Commute(..), Invert(..), Apply(..), - PatchInspect(..), ReadPatch(..) ) -import Darcs.Patch.Prim ( PrimOf, PrimPatchBase ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Prim ( PrimPatchBase(..) ) import Darcs.Patch.ReadMonads ( ParserM, option, lexChar, choice, skipWhile, anyChar ) import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL, Check(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), showNamedPrefix ) +import Darcs.Patch.Show + ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..), ShowPatchFor(..) ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.Viewing () -- for ShowPatch FL instances -import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL, mapFL_FL ) import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal ) import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) ) -import Darcs.Util.Printer ( ($$), (<+>), (<>), prefix, text, vcat ) +import Darcs.Util.Printer + ( Doc, ($$), (<+>), (<>), prefix, text, vcat, cyanText, blueText ) -- | The @Named@ type adds a patch info about a patch, that is a name. data Named p wX wY where @@ -149,7 +151,7 @@ fmapFL_Named :: (FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD fmapFL_Named f (NamedP i deps p) = NamedP i deps (f p) -instance (Commute p, MyEq p) => MyEq (Named p) where +instance (Commute p, Eq2 p) => Eq2 (Named p) where unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) = n1 == n2 && d1 == d2 && unsafeCompare p1 p2 @@ -195,23 +197,73 @@ instance Check p => Check (Named p) where isInconsistent (NamedP _ _ p) = isInconsistent p +-- ForStorage: note the difference between use of <> when there are +-- no explicit dependencies vs. <+> when there are +showNamedPrefix :: ShowPatchFor -> PatchInfo -> [PatchInfo] -> Doc -> Doc +showNamedPrefix f@ForStorage n [] p = + showPatchInfo f n <> p +showNamedPrefix f@ForStorage n d p = + showPatchInfo f n + $$ blueText "<" + $$ vcat (map (showPatchInfo f) d) + $$ blueText ">" + <+> p +showNamedPrefix f@ForDisplay n [] p = + showPatchInfo f n + $$ p +showNamedPrefix f@ForDisplay n d p = + showPatchInfo f n + $$ showDependencies ShowDepsVerbose d + $$ p + +data ShowDepsFormat = ShowDepsVerbose | ShowDepsSummary + deriving (Eq) + +showDependencies :: ShowDepsFormat -> [PatchInfo] -> Doc +showDependencies format deps = vcat (map showDependency deps) + where + showDependency d = mark + <+> cyanText "patch" + <+> cyanText (show (makePatchname d)) + $$ asterisk <+> text (piName d) + mark | format == ShowDepsVerbose = blueText "depend" + | otherwise = text "D" + asterisk | format == ShowDepsVerbose = text "*" + | otherwise = text " *" + instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Named p) where - showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p - showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p + showPatch f (NamedP n d p) = showNamedPrefix f n d $ showPatch f p -instance (Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, PatchListFormat p, +instance (Apply p, IsHunk p, PatchListFormat p, + ShowContextPatch p) => ShowContextPatch (Named p) where + showContextPatch f (NamedP n d p) = + showNamedPrefix f n d <$> showContextPatch f p + +instance (CommuteNoConflicts p, Conflict p, PatchListFormat p, PrimPatchBase p, ShowPatch p) => ShowPatch (Named p) where - showContextPatch (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>) - showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>) - description (NamedP n _ _) = showPatchInfoUI n - summary p = description p $$ text "" $$ - 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. + description (NamedP n _ _) = displayPatchInfo n + summary p@(NamedP _ ds _) = + let + indent = prefix " " + deps | ds == [] = text "" + | otherwise = text "" + $$ indent (showDependencies ShowDepsSummary ds) + in + description p $$ deps $$ indent (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. summaryFL = vcat . mapFL summary - showNicely p@(NamedP _ _ pt) = description p $$ - prefix " " (showNicely pt) + showNicely p@(NamedP _ ds pt) = + let + indent = prefix " " + deps | ds == [] = text "" + | otherwise = text "" + $$ indent (showDependencies ShowDepsVerbose ds) + in + description p <> deps $$ indent (showNicely pt) instance Show2 p => Show1 (Named p wX) where showDict1 = ShowDictClass diff --git a/src/Darcs/Patch/Named/Wrapped.hs b/src/Darcs/Patch/Named/Wrapped.hs --- a/src/Darcs/Patch/Named/Wrapped.hs +++ b/src/Darcs/Patch/Named/Wrapped.hs @@ -12,15 +12,16 @@ import Prelude () import Darcs.Prelude +import Data.Coerce ( coerce ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) -import Darcs.Patch.Format ( PatchListFormat(..), ListFormat, copyListFormat ) +import Darcs.Patch.Format ( PatchListFormat(..), ListFormat ) import Darcs.Patch.Info - ( PatchInfo, showPatchInfo, showPatchInfoUI, patchinfo + ( PatchInfo, showPatchInfo, displayPatchInfo, patchinfo ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Named ( Named(..), fmapFL_Named ) @@ -31,8 +32,8 @@ ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Prim ( FromPrim, PrimOf ) -import Darcs.Patch.Prim.Class ( PrimPatchBase ) +import Darcs.Patch.Prim ( FromPrim ) +import Darcs.Patch.Prim.Class ( PrimPatchBase(..) ) import Darcs.Patch.Read ( ReadPatch(..) ) import qualified Darcs.Patch.Rebase.Container as Rebase ( Suspended(..) @@ -43,7 +44,7 @@ ( RepoType(..), IsRepoType(..), SRepoType(..) , RebaseType(..), RebaseTypeOf, SRebaseType(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..), ShowPatchFor(..) ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Sealed ( mapSeal ) @@ -210,27 +211,35 @@ instance (ShowPatchBasic p, PatchListFormat p) => ShowPatchBasic (WrappedNamed rt p) where - showPatch (NormalP n) = showPatch n - showPatch (RebaseP i s) = showPatchInfo i <> showPatch s + showPatch f (NormalP n) = showPatch f n + showPatch f (RebaseP i s) = showPatchInfo f i <> showPatch f s +instance ( ShowContextPatch p, PatchListFormat p, Apply p + , PrimPatchBase p, IsHunk p + ) + => ShowContextPatch (WrappedNamed rt p) where + + showContextPatch f (NormalP n) = showContextPatch f n + showContextPatch f@ForDisplay (RebaseP i s) = + fmap (showPatchInfo f i $$) $ return (showPatch f s) + showContextPatch f@ForStorage (RebaseP i s) = + fmap (showPatchInfo f i <>) $ return (showPatch f s) + instance ( ShowPatch p, PatchListFormat p, Apply p , PrimPatchBase p, IsHunk p, Conflict p, CommuteNoConflicts p ) => ShowPatch (WrappedNamed rt p) where - showContextPatch (NormalP n) = showContextPatch n - showContextPatch (RebaseP i s) = fmap (showPatchInfo i <>) $ showContextPatch s - description (NormalP n) = description n - description (RebaseP i _) = showPatchInfoUI i + description (RebaseP i _) = displayPatchInfo i summary (NormalP n) = summary n - summary (RebaseP i _) = showPatchInfoUI i + summary (RebaseP i _) = displayPatchInfo i summaryFL = vcat . mapFL summary showNicely (NormalP n) = showNicely n - showNicely (RebaseP i s) = showPatchInfoUI i $$ + showNicely (RebaseP i s) = displayPatchInfo i $$ prefix " " (showNicely s) instance PatchInspect p => PatchInspect (WrappedNamed rt p) where @@ -277,7 +286,7 @@ _ -> fmap (mapSeal NormalP) readPatch' instance PatchListFormat p => PatchListFormat (ReadRebasing p) where - patchListFormat = copyListFormat (patchListFormat :: ListFormat p) + patchListFormat = coerce (patchListFormat :: ListFormat p) instance (ReadPatch p, PatchListFormat p, PrimPatchBase p) => ReadPatch (ReadRebasing p) where readPatch' = diff --git a/src/Darcs/Patch/OldDate.hs b/src/Darcs/Patch/OldDate.hs deleted file mode 100644 --- a/src/Darcs/Patch/OldDate.hs +++ /dev/null @@ -1,351 +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 Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where - -import Prelude ( (^) ) -import Darcs.Prelude - -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 <- dateTime 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 ((<|>) . (\x -> try $ count x p)) (return []) $ reverse [1..m] - | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) - - ------ Date/Time Parser ----------------------------------------------- - -dateTime :: Int -> CharParser a CalendarTime -dateTime tz = - choice [try $ cvsDateTime tz, - try $ iso8601DateTime tz, - oldDateTime] - -dayAndHMSTime :: CharParser a (Int, Int, Int, Int) -dayAndHMSTime = do d <- day - _ <- mySpaces - h <- hour - _ <- char ':' - m <- minute - _ <- char ':' - s <- second - return (d, h, m, s) - -cvsDateTime :: Int -> CharParser a CalendarTime -cvsDateTime tz = - do y <- year - _ <- char '/' - mon <- monthNum - _ <- char '/' - (d, h, m, s) <- dayAndHMSTime - z <- option tz $ mySpaces >> zone - return (CalendarTime y mon d h m s 0 Monday 0 "" z False) - -oldDateTime :: CharParser a CalendarTime -oldDateTime = do wd <- dayName - _ <- mySpaces - mon <- monthName - _ <- mySpaces - (d, h, m, s) <- dayAndHMSTime - _ <- mySpaces - z <- zone - _ <- mySpaces - 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?) -} -iso8601DateTime :: Int -> CharParser a CalendarTime -iso8601DateTime localTz = try $ - do d <- iso8601Date - t <- option id $ try $ do optional $ oneOf " T" - iso8601Time - return $ t $ d { ctTZ = localTz } - -iso8601Date :: CharParser a CalendarTime -iso8601Date = - 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` twoDigits - wd <- option 1 $ do { optional dash; nDigits 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 <- fourDigits "year (0000-9999)" - return $ \c -> c { ctYear = y } - month_ = try $ do m <- twoDigits "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 <- twoDigits "day in month (1 to 31)" - return $ \c -> c { ctDay = d } - yearDay_ = try $ do d <- nDigits 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 -iso8601Time :: CharParser a (CalendarTime -> CalendarTime) -iso8601Time = 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 <- twoDigits - return $ \c -> c { ctHour = h } - min_ = do m <- twoDigits - return $ \c -> c { ctMin = m } - sec_ = do s <- twoDigits - 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 [ char '+' >> return 1 - , char '-' >> return (-1) ] - h <- twoDigits - m <- option 0 $ do { optional colon; twoDigits } - 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) - -nDigits :: Int -> CharParser a Int -nDigits n = read `liftM` count n digit - -twoDigits, fourDigits :: CharParser a Int -twoDigits = nDigits 2 -fourDigits = nDigits 4 - -mySpaces :: CharParser a String -mySpaces = manyN 1 $ char ' ' - -dayName :: CharParser a Day -dayName = 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 = fourDigits - -monthNum :: CharParser a Month -monthNum = 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!" - -monthName :: CharParser a Month -monthName = 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 = twoDigits - -minute :: CharParser a Int -minute = twoDigits - -second :: CharParser a Int -second = twoDigits - -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/PatchInfoAnd.hs b/src/Darcs/Patch/PatchInfoAnd.hs --- a/src/Darcs/Patch/PatchInfoAnd.hs +++ b/src/Darcs/Patch/PatchInfoAnd.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.Patch.PatchInfoAnd ( Hopefully(..), SimpleHopefully(..), PatchInfoAnd(..), WPatchInfo, unWPatchInfo, compareWPatchInfo, piap, n2pia, patchInfoAndPatch, @@ -34,8 +31,8 @@ import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.Printer ( Doc, renderString, errorDoc, text, ($$), vcat - , RenderMode(..) ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI, justName ) + ) +import Darcs.Patch.Info ( PatchInfo, showPatchInfo, displayPatchInfo, justName ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) @@ -47,12 +44,16 @@ , generaliseRepoTypeWrapped ) import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim ) -import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..), - ShowPatch(..), Commute(..), PatchInspect(..) ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( ShowPatch(..) ) import Darcs.Patch.Repair ( Repair(..), RepairToFL ) import Darcs.Patch.RepoType ( RepoType(..), IsRepoType, RebaseTypeOf, RebaseType(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowContextPatch(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) @@ -67,7 +68,9 @@ -- 'SimpleHopefully' does the real work of emulating -- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and -- @Hashed hash sh@ represents an expected hashed patch with its hash. -data Hopefully a wX wY = Hopefully (SimpleHopefully a wX wY) | Hashed String (SimpleHopefully a wX wY) +data Hopefully a wX wY + = Hopefully (SimpleHopefully a wX wY) + | Hashed String (SimpleHopefully a wX wY) deriving Show -- | @SimpleHopefully@ is a variant of @Either String@ adapted for @@ -101,7 +104,7 @@ compareWPatchInfo :: WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD) compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq -instance MyEq WPatchInfo where +instance Eq2 WPatchInfo where WPatchInfo x `unsafeCompare` WPatchInfo y = x == y fmapH :: (a wX wY -> b wW wZ) -> Hopefully a wX wY -> Hopefully b wW wZ @@ -160,15 +163,15 @@ conscientiously er (PIAP pinf hp) = case hopefully2either hp of Right p -> p - Left e -> errorDoc $ er (showPatchInfoUI pinf $$ text e) + Left e -> errorDoc $ er (displayPatchInfo pinf $$ text e) -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring. hopefullyM :: Monad m => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB) hopefullyM (PIAP pinf hp) = case hopefully2either hp of Right p -> return p - Left e -> fail $ renderString Encode - (showPatchInfoUI pinf $$ text e) + Left e -> fail $ renderString + (displayPatchInfo pinf $$ text e) -- Any recommendations for a nice adverb to name the below? hopefully2either :: Hopefully a wX wY -> Either String (a wX wY) @@ -197,7 +200,7 @@ -- Equality on PatchInfoAnd is solely determined by the PatchInfo -- It is a global invariant of darcs that once a patch is recorded, -- it should always have the same representation in the same context. -instance MyEq (PatchInfoAnd rt p) where +instance Eq2 (PatchInfoAnd rt p) where unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 instance Invert p => Invert (PatchInfoAnd rt p) where @@ -206,23 +209,27 @@ instance PatchListFormat (PatchInfoAnd rt p) instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd rt p) where - showPatch (PIAP n p) = case hopefully2either p of - Right x -> showPatch x - Left _ -> showPatchInfoUI n + showPatch f (PIAP n p) = + case hopefully2either p of + Right x -> showPatch f x + Left _ -> showPatchInfo f n +instance (Apply p, IsHunk p, PatchListFormat p, PrimPatchBase p, + ShowContextPatch p) => ShowContextPatch (PatchInfoAnd rt p) where + showContextPatch f (PIAP n p) = case hopefully2either p of + Right x -> showContextPatch f x + Left _ -> return $ showPatchInfo f n + instance (Apply p, Conflict p, CommuteNoConflicts p, IsHunk p, PatchListFormat p, PrimPatchBase p, ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd rt p) where - showContextPatch (PIAP n p) = case hopefully2either p of - Right x -> showContextPatch x - Left _ -> return $ showPatchInfoUI n - description (PIAP n _) = showPatchInfoUI n + description (PIAP n _) = displayPatchInfo n summary (PIAP n p) = case hopefully2either p of Right x -> summary x - Left _ -> showPatchInfoUI n + Left _ -> displayPatchInfo n summaryFL = vcat . mapFL summary showNicely (PIAP n p) = case hopefully2either p of Right x -> showNicely x - Left _ -> showPatchInfoUI n + Left _ -> displayPatchInfo n instance Commute p => Commute (PatchInfoAnd rt p) where commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) @@ -260,6 +267,3 @@ isHunk _ = Nothing instance PatchDebug p => PatchDebug (PatchInfoAnd rt p) - -instance (Patchy p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd rt p) - diff --git a/src/Darcs/Patch/Patchy.hs b/src/Darcs/Patch/Patchy.hs deleted file mode 100644 --- a/src/Darcs/Patch/Patchy.hs +++ /dev/null @@ -1,36 +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. - -{-# LANGUAGE CPP #-} - - -module Darcs.Patch.Patchy - ( Patchy, - Apply(..), Commute(..), Invert(..), - PatchInspect(..), ReadPatch(..), - showPatch, ShowPatch(..) - ) where - -import Darcs.Patch.Apply ( Apply(..) ) -import Darcs.Patch.Commute ( Commute(..) ) -import Darcs.Patch.Invert ( Invert(..) ) -import Darcs.Patch.Inspect ( PatchInspect(..) ) -import Darcs.Patch.Read ( ReadPatch(..) ) -import Darcs.Patch.Show ( showPatch, ShowPatch(..) ) - -class (Apply p, Commute p, Invert p) => Patchy p - diff --git a/src/Darcs/Patch/Patchy/Instances.hs b/src/Darcs/Patch/Patchy/Instances.hs deleted file mode 100644 --- a/src/Darcs/Patch/Patchy/Instances.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Darcs.Patch.Patchy.Instances () where - -import Darcs.Patch.Format ( PatchListFormat ) -import Darcs.Patch.Patchy ( Patchy ) -import Darcs.Patch.Permutations () -import Darcs.Patch.FileHunk ( IsHunk ) -import Darcs.Patch.Viewing () -import Darcs.Patch.Witnesses.Ordered ( FL, RL ) - -instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (FL p) -instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (RL p) 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 @@ -17,9 +17,7 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} - module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon, commuteWhatWeCanFL, commuteWhatWeCanRL, genCommuteWhatWeCanRL, genCommuteWhatWeCanFL, @@ -38,12 +36,11 @@ import Darcs.Patch.Commute ( Commute, commute, commuteFLorComplain, commuteRL ) import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Invert ( Invert(..) ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+<+) , reverseFL, (+>+), (:\/:)(..), lengthFL , lengthRL, reverseRL ) -#include "impossible.h" -- |split an 'FL' into "left" and "right" lists according to a predicate @p@, using commutation as necessary. -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy @@ -134,11 +131,11 @@ genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL -removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) wX wY -> (FL p :\/: FL p) wX wY +removeCommon :: (Eq2 p, Commute p) => (FL p :\/: FL p) wX wY -> (FL p :\/: FL p) wX wY removeCommon (xs :\/: NilFL) = xs :\/: NilFL removeCommon (NilFL :\/: xs) = NilFL :\/: xs removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys) - where rc :: (MyEq p, Commute p) => FL p wX wY -> [(p:>FL p) wX wZ] -> (FL p :\/: FL p) wY wZ + where rc :: (Eq2 p, Commute p) => FL p wX wY -> [(p:>FL p) wX wZ] -> (FL p :\/: FL p) wY wZ rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns) rc ms [n:>ns] = ms :\/: n:>:ns rc ms (_:nss) = rc ms nss @@ -146,17 +143,17 @@ -- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head. -- Otherwise it returns 'Nothing' -removeFL :: (MyEq p, Commute p) => p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ) +removeFL :: (Eq2 p, Commute p) => p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ) removeFL x xs = r x $ headPermutationsFL xs - where r :: (MyEq p, Commute p) => p wX wY -> [(p:>FL p) wX wZ] -> Maybe (FL p wY wZ) + where r :: (Eq2 p, Commute p) => p wX wY -> [(p:>FL p) wX wZ] -> Maybe (FL p wY wZ) r _ [] = Nothing r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs | otherwise = r z zss -- | 'removeRL' is like 'removeFL' except with 'RL' -removeRL :: (MyEq p, Commute p) => p wY wZ -> RL p wX wZ -> Maybe (RL p wX wY) +removeRL :: (Eq2 p, Commute p) => p wY wZ -> RL p wX wZ -> Maybe (RL p wX wY) removeRL x xs = r x $ headPermutationsRL xs - where r :: (MyEq p, Commute p) => p wY wZ -> [RL p wX wZ] -> Maybe (RL p wX wY) + where r :: (Eq2 p, Commute p) => p wY wZ -> [RL p wX wZ] -> Maybe (RL p wX wY) r z ((zs:<:z'):zss) | IsEq <- z =/\= z' = Just zs | otherwise = r z zss r _ _ = Nothing @@ -165,21 +162,21 @@ -- @ab@ have been commuted out of it, if possible. If this is not possible -- for any reason (the set of patches @ab@ is not actually a subset of @abc@, -- or they can't be commuted out) we return 'Nothing'. -removeSubsequenceFL :: (MyEq p, Commute p) => FL p wA wB +removeSubsequenceFL :: (Eq2 p, Commute p) => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC) removeSubsequenceFL a b | lengthFL a > lengthFL b = Nothing | otherwise = rsFL a b - where rsFL :: (MyEq p, Commute p) => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC) + where rsFL :: (Eq2 p, Commute p) => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC) rsFL NilFL ys = Just ys rsFL (x:>:xs) yys = removeFL x yys >>= removeSubsequenceFL xs -- | 'removeSubsequenceRL' is like @removeSubsequenceFL@ except that it works -- on 'RL' -removeSubsequenceRL :: (MyEq p, Commute p) => RL p wAb wAbc +removeSubsequenceRL :: (Eq2 p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb) removeSubsequenceRL a b | lengthRL a > lengthRL b = Nothing | otherwise = rsRL a b - where rsRL :: (MyEq p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb) + where rsRL :: (Eq2 p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb) rsRL NilRL ys = Just ys rsRL (xs:<:x) yys = removeRL x yys >>= removeSubsequenceRL xs @@ -222,7 +219,7 @@ Just $ xs:<:p1':<:p2' swapfirstRL _ = Nothing -instance (MyEq p, Commute p) => MyEq (FL p) where +instance (Eq2 p, Commute p) => Eq2 (FL p) where a =\/= b | lengthFL a /= lengthFL b = NotEq | otherwise = cmpSameLength a b where cmpSameLength :: FL p wX wY -> FL p wX wZ -> EqCheck wY wZ @@ -231,7 +228,7 @@ cmpSameLength _ _ = NotEq xs =/\= ys = reverseFL xs =/\= reverseFL ys -instance (MyEq p, Commute p) => MyEq (RL p) where +instance (Eq2 p, Commute p) => Eq2 (RL p) where unsafeCompare = bug "Buggy use of unsafeCompare on RL" a =/\= b | lengthRL a /= lengthRL b = NotEq | otherwise = cmpSameLength a b diff --git a/src/Darcs/Patch/Prim.hs b/src/Darcs/Patch/Prim.hs --- a/src/Darcs/Patch/Prim.hs +++ b/src/Darcs/Patch/Prim.hs @@ -1,25 +1,24 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim - ( showPrim, showPrimFL, - primIsAddfile, primIsHunk, primIsBinary, primIsSetpref, - primIsAdddir, is_filepatch, - canonize, tryToShrink, - sortCoalesceFL, coalesce, canonizeFL, - tryShrinkingInverse, - summarizePrim, - applyPrimFL, - readPrim, - FromPrim(..), FromPrims(..), ToFromPrim(..), - PrimPatch, PrimPatchBase(..), PrimConstruct(..) - ) - where + ( primIsAddfile, primIsHunk, primIsBinary, primIsSetpref + , primIsAdddir, is_filepatch + , summarizePrim + , applyPrimFL + , PrimRead(..) + , PrimShow(..) + , FromPrim(..), FromPrims(..), ToFromPrim(..) + , PrimPatch, PrimPatchBase(..) + , PrimConstruct(..) + , PrimCanonize(..) + , PrimPatchCommon + ) where import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimCanonize(..) , PrimClassify(..), PrimDetails(..) - , PrimShow(..), showPrimFL, PrimRead(..) + , PrimShow(..), PrimRead(..) , PrimApply(..) , FromPrim(..), FromPrims(..), ToFromPrim(..) , PrimPatchBase(..), PrimPatch + , PrimPatchCommon ) - diff --git a/src/Darcs/Patch/Prim/Class.hs b/src/Darcs/Patch/Prim/Class.hs --- a/src/Darcs/Patch/Prim/Class.hs +++ b/src/Darcs/Patch/Prim/Class.hs @@ -1,10 +1,11 @@ module Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimCanonize(..) , PrimClassify(..), PrimDetails(..) - , PrimShow(..), showPrimFL, PrimRead(..) + , PrimShow(..), PrimRead(..) , PrimApply(..) , PrimPatch, PrimPatchBase(..) , FromPrim(..), FromPrims(..), ToFromPrim(..) + , PrimPatchCommon ) where @@ -15,34 +16,52 @@ import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk ) import Darcs.Util.Path ( FileName ) -import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) +import Darcs.Patch.Format ( FileNameFormat, PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.Patchy ( Patchy ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.ReadMonads ( ParserM ) import Darcs.Patch.Repair ( RepairToFL ) -import Darcs.Patch.Show ( ShowPatch ) +import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) import Darcs.Patch.SummaryData ( SummDetail ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered - ( FL(..), RL, (:>), mapFL, mapFL_FL, reverseFL ) + ( FL(..), RL, (:>), mapFL_FL, reverseFL ) import Darcs.Patch.Witnesses.Show ( Show2 ) import Darcs.Patch.Witnesses.Sealed ( Sealed ) -import Darcs.Util.Printer ( Doc, vcat ) +import Darcs.Util.Printer ( Doc ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import qualified Data.ByteString as B ( ByteString ) -class (Patchy prim, MyEq prim - ,PatchListFormat prim, IsHunk prim, RepairToFL prim - ,PatchInspect prim, ReadPatch prim, ShowPatch prim - ,Show2 prim - ,PrimConstruct prim, PrimCanonize prim - ,PrimClassify prim, PrimDetails prim - ,PrimShow prim, PrimRead prim, PrimApply prim +-- | This class describes the abstract interface to primitive patches +-- that is indepenent of the on-disk format. +class ( Apply prim + , Commute prim + , Invert prim + , Eq2 prim + , IsHunk prim + , PatchInspect prim + , RepairToFL prim + , Show2 prim + , PrimConstruct prim + , PrimCanonize prim + , PrimClassify prim + , PrimDetails prim + , PrimApply prim ) + => PrimPatchCommon prim + +class ( PrimPatchCommon prim + , ReadPatch prim + , ShowPatch prim + , ShowContextPatch prim + , PatchListFormat prim + ) => PrimPatch prim class PrimPatch (PrimOf p) => PrimPatchBase p where @@ -55,7 +74,7 @@ type PrimOf (RL p) = PrimOf p class FromPrim p where - fromPrim :: PrimOf p wX wY -> p wX wY + fromPrim :: PrimOf p wX wY -> p wX wY class FromPrim p => ToFromPrim p where toPrim :: p wX wY -> Maybe (PrimOf p wX wY) @@ -143,9 +162,7 @@ class PrimShow prim where showPrim :: FileNameFormat -> prim wA wB -> Doc - -showPrimFL :: PrimShow prim => FileNameFormat -> FL prim wA wB -> Doc -showPrimFL f xs = vcat (mapFL (showPrim f) xs) + showPrimCtx :: ApplyMonad (ApplyState prim) m => FileNameFormat -> prim wA wB -> m Doc class PrimRead prim where readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim wX)) diff --git a/src/Darcs/Patch/Prim/FileUUID.hs b/src/Darcs/Patch/Prim/FileUUID.hs --- a/src/Darcs/Patch/Prim/FileUUID.hs +++ b/src/Darcs/Patch/Prim/FileUUID.hs @@ -1,9 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.FileUUID ( Prim ) where -import Prelude () -import Darcs.Prelude - import Darcs.Patch.Prim.FileUUID.Apply () import Darcs.Patch.Prim.FileUUID.Coalesce () import Darcs.Patch.Prim.FileUUID.Commute () @@ -12,11 +9,10 @@ import Darcs.Patch.Prim.FileUUID.Read () import Darcs.Patch.Prim.FileUUID.Show () -import Darcs.Patch.Prim.Class ( PrimPatch, PrimPatchBase(..), FromPrim(..) ) -import Darcs.Patch.Patchy ( Patchy ) +import Darcs.Patch.Prim.Class ( PrimPatchCommon, PrimPatch, PrimPatchBase(..), FromPrim(..) ) +instance PrimPatchCommon Prim instance PrimPatch Prim -instance Patchy Prim instance PrimPatchBase Prim where type PrimOf Prim = Prim diff --git a/src/Darcs/Patch/Prim/FileUUID/Apply.hs b/src/Darcs/Patch/Prim/FileUUID/Apply.hs --- a/src/Darcs/Patch/Prim/FileUUID/Apply.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Apply.hs @@ -1,81 +1,98 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} -module Darcs.Patch.Prim.FileUUID.Apply ( ObjectMap(..) ) where +module Darcs.Patch.Prim.FileUUID.Apply ( hunkEdit, ObjectMap(..) ) where import Prelude () import Darcs.Prelude -import Darcs.Patch.Apply ( Apply(..) ) -import Darcs.Patch.ApplyMonad - ( ApplyMonad(..), ApplyMonadTrans(..), ToTree(..), ApplyMonadState(..) - ) -import Darcs.Patch.Repair ( RepairToFL(..) ) - -import Darcs.Patch.Prim.Class ( PrimApply(..) ) -import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), hunkEdit ) -import Darcs.Patch.Prim.FileUUID.ObjectMap - import Control.Monad.State( StateT, runStateT, gets, lift, put ) +import qualified Data.ByteString as B import qualified Data.Map as M --- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) +import Debug.Trace ( trace ) +-- import Text.Show.Pretty ( ppShow ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.ApplyMonad + ( ApplyMonad(..), ApplyMonadTrans(..) + , ToTree(..), ApplyMonadState(..) + ) +import Darcs.Patch.Prim.Class ( PrimApply(..) ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), HunkMove(..) ) +import Darcs.Patch.Prim.FileUUID.Show +import Darcs.Patch.Prim.FileUUID.ObjectMap +import Darcs.Patch.Repair ( RepairToFL(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) + import Darcs.Util.Hash( Hash(..) ) +import Darcs.Util.Printer( text, packedString, ($$), renderString ) -import qualified Data.ByteString as B -#include "impossible.h" - instance Apply Prim where - type ApplyState Prim = ObjectMap - apply (Manifest i (dirid, name)) = editDirectory dirid (M.insert name i) - apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name) - apply (TextHunk i hunk) = editFile i (hunkEdit hunk) - apply (BinaryHunk i hunk) = editFile i (hunkEdit hunk) - apply Identity = return () - apply (Move{}) = bug "apply for move not implemented" + type ApplyState Prim = ObjectMap + apply (Manifest i (L dirid name)) = editDirectory dirid (M.insert name i) + apply (Demanifest _ (L dirid name)) = editDirectory dirid (M.delete name) + apply (Hunk i hunk) = editFile i (hunkEdit hunk) + apply (HunkMove (HM fs ls ft lt c)) = + editFile fs (hunkEdit (H ls c B.empty)) >> editFile ft (hunkEdit (H lt B.empty c)) + apply Identity = return () instance RepairToFL Prim where - applyAndTryToFixFL p = apply p >> return Nothing + applyAndTryToFixFL p = apply p >> return Nothing instance PrimApply Prim where - applyPrimFL NilFL = return () - applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps + applyPrimFL NilFL = return () + applyPrimFL (p :>: ps) = apply p >> applyPrimFL ps instance ToTree ObjectMap -- TODO -editObject :: (Monad m) => UUID -> (Maybe (Object m) -> Object m) -> (StateT (ObjectMap m) m) () -editObject i edit = do load <- gets getObject - store <- gets putObject - obj <- lift $ load i - new <- lift $ store i $ edit obj - put new - return () +hunkEdit :: Hunk wX wY -> FileContent -> FileContent +hunkEdit h@(H off old new) c + | old `B.isPrefixOf` (B.drop off c) = + B.concat [B.take off c, new, B.drop (off + B.length old) c] + | otherwise = error $ renderString $ + text "##error applying hunk:" $$ displayHunk Nothing h $$ "##to" $$ + packedString c +-- $$ text "##old=" <> text (ppShow old) $$ +-- text "##new=" <> text (ppShow new) $$ +-- text "##c=" <> text (ppShow c) +editObject :: Monad m + => UUID + -> (Maybe (Object m) -> Object m) + -> (StateT (ObjectMap m) m) () +editObject i edit = do + load <- gets getObject + store <- gets putObject + obj <- lift $ load i + new <- lift $ store i $ edit obj + put new +-- a semantic, ObjectMap-based interface for patch application class ApplyMonadObjectMap m where - -- a semantic, ObjectMap-based interface for patch application - editFile :: UUID -> (B.ByteString -> B.ByteString) -> m () - editDirectory :: UUID -> (DirContent -> DirContent) -> m () + editFile :: UUID -> (FileContent -> FileContent) -> m () + editDirectory :: UUID -> (DirContent -> DirContent) -> m () instance ApplyMonadState ObjectMap where - type ApplyMonadStateOperations ObjectMap = ApplyMonadObjectMap + type ApplyMonadStateOperations ObjectMap = ApplyMonadObjectMap -instance (Functor m, Monad m) => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where - type ApplyMonadBase (StateT (ObjectMap m) m) = m +instance (Monad m) => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where + type ApplyMonadBase (StateT (ObjectMap m) m) = m -instance (Functor m, Monad m) => ApplyMonadObjectMap (StateT (ObjectMap m) m) where - editFile i edit = editObject i edit' - where edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash - edit' (Just (Directory x)) = Directory x -- error? - edit' Nothing = Blob (return $ edit "") NoHash - editDirectory i edit = editObject i edit' - where edit' (Just (Directory x)) = Directory $ edit x - edit' (Just (Blob x y)) = Blob x y -- error? - edit' Nothing = Directory $ edit M.empty +instance (Monad m) => ApplyMonadObjectMap (StateT (ObjectMap m) m) where + editFile i edit = editObject i edit' + where + edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash + edit' Nothing = Blob (return $ edit "") NoHash + edit' (Just d@(Directory m)) = + trace ("\neditFile called with Directory object: " ++ show (i,m) ++ "\n") d + editDirectory i edit = editObject i edit' + where + edit' (Just (Directory x)) = Directory $ edit x + edit' Nothing = Directory $ edit M.empty + edit' (Just b@(Blob _ h)) = + trace ("\neditDirectory called with File object: " ++ show (i,h) ++ "\n") b -instance (Functor m, Monad m) => ApplyMonadTrans ObjectMap m where +instance (Monad m) => ApplyMonadTrans ObjectMap m where type ApplyMonadOver ObjectMap m = StateT (ObjectMap m) m runApplyMonad = runStateT - diff --git a/src/Darcs/Patch/Prim/FileUUID/Commute.hs b/src/Darcs/Patch/Prim/FileUUID/Commute.hs --- a/src/Darcs/Patch/Prim/FileUUID/Commute.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Commute.hs @@ -1,73 +1,62 @@ -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-overlapping-patterns #-} -{-# LANGUAGE CPP #-} -module Darcs.Patch.Prim.FileUUID.Commute - ( CommuteMonad(..) ) - where +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Darcs.Patch.Prim.FileUUID.Commute () where import Prelude () import Darcs.Prelude -import Data.List ( intersect ) - -import qualified Data.ByteString as BS (length) +import qualified Data.ByteString as B (length) import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), touches ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..) ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL -#include "impossible.h" -class Monad m => CommuteMonad m where - commuteFail :: m a - -- TODO we eventually have to get rid of runCommute with this signature, - -- since m might involve IO at some point, which we can't "run"; - -- alternatively, for IO it could always yield Nothing, having a separate - -- IO-specific function to "run" commutes in IO - -instance CommuteMonad Maybe where - commuteFail = Nothing +-- For FileUUID it is easier to list the cases that do /not/ commute +depends :: (Prim :> Prim) wX wY -> Bool +depends (Manifest i1 l1 :> Demanifest i2 l2) + -- cannot commute add with remove of same object, regardless of location + | i1 == i2 = True + -- cannot commute add with remove of any two things at the same location + | l1 == l2 = True +depends (Demanifest i1 l1 :> Manifest i2 l2) + -- cannot commute remove with add of same object, regardless of location + | i1 == i2 = True + -- cannot commute remove with add of any two things at the same location + | l1 == l2 = True +depends (_ :> _) = False instance Commute Prim where - commute = commute' - -class Commute' p where - commute' :: (CommuteMonad m) => (p :> p) wX wY -> m ((p :> p) wX wY) - -typematch :: Prim wX wY -> Prim wY wZ -> Bool -typematch _ _ = True -- TODO - -instance Commute' Prim where - commute' (a :> b) | null (touches a `intersect` touches b) = return (unsafeCoerceP b :> unsafeCoerceP a) - | not (a `typematch` b) = commuteFail - | otherwise = commuteOverlapping (a :> b) - --- Commute patches that have actual overlap in terms of touched objects, and their types allow -commuteOverlapping :: (CommuteMonad m) => (Prim :> Prim) wX wY -> m ((Prim :> Prim) wX wY) -commuteOverlapping (BinaryHunk a x :> BinaryHunk _ y) = - do (y' :> x') <- commuteHunk (x :> y) - return $ unsafeCoerceP (BinaryHunk a y' :> BinaryHunk a x') -commuteOverlapping (TextHunk a x :> TextHunk _ y) = - do (y' :> x') <- commuteHunk (x :> y) - return $ unsafeCoerceP (TextHunk a y' :> TextHunk a x') -commuteOverlapping _ = commuteFail + commute pair + | depends pair = Nothing + commute (Hunk f1 h1 :> Hunk f2 h2) + | f1 == f2 = + case commuteHunk (h1 :> h2) of + Just (h2' :> h1') -> Just (Hunk f2 h2' :> Hunk f1 h1') + Nothing -> Nothing + commute (a :> b) = + Just (unsafeCoerceP b :> unsafeCoerceP a) -commuteHunk :: (CommuteMonad m) => (Hunk :> Hunk) wX wY -> m ((Hunk :> Hunk) wY wX) -commuteHunk (Hunk off1 old1 new1 :> Hunk off2 old2 new2) - | off1 + lengthnew1 < off2 = - return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 - | off2 + lengthold2 < off1 = - return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 - | off1 + lengthnew1 == off2 && - lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 - | off2 + lengthold2 == off1 && - lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 - | otherwise = commuteFail - where lengthnew1 = BS.length new1 - lengthnew2 = BS.length new2 - lengthold1 = BS.length old1 - lengthold2 = BS.length old2 -commuteHunk _ = impossible +commuteHunk :: (Hunk :> Hunk) wX wY -> Maybe ((Hunk :> Hunk) wX wY) +commuteHunk (H off1 old1 new1 :> H off2 old2 new2) + | off1 + len_new1 < off2 = yes (off2 - len_new1 + len_old1, off1) + | off2 + len_old2 < off1 = yes (off2, off1 + len_new2 - len_old2) + | len_old2 /= 0 + , len_old1 /= 0 + , len_new2 /= 0 + , len_new1 /= 0 + , off1 + len_new1 == off2 = yes (off2 - len_new1 + len_old1, off1) + | len_old2 /= 0 + , len_old1 /= 0 + , len_new2 /= 0 + , len_new1 /= 0 + , off2 + len_old2 == off1 = yes (off2, off1 + len_new2 - len_old2) + | otherwise = no + where + len_old1 = B.length old1 + len_new1 = B.length new1 + len_old2 = B.length old2 + len_new2 = B.length new2 + yes (off2', off1') = Just (H off2' old2 new2 :> H off1' old1 new1) + no = Nothing diff --git a/src/Darcs/Patch/Prim/FileUUID/Core.hs b/src/Darcs/Patch/Prim/FileUUID/Core.hs --- a/src/Darcs/Patch/Prim/FileUUID/Core.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings, StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-} -- Copyright (C) 2011 Petr Rockai -- @@ -24,128 +24,127 @@ module Darcs.Patch.Prim.FileUUID.Core - ( Prim(..), Hunk(..), UUID(..), Location, Object(..), touches, hunkEdit ) - where + ( Prim(..) + , Hunk(..) + , HunkMove(..) + -- re-exports + , Object(..) + , UUID(..) + , Location(..) + , Name + , FileContent + ) where import Prelude () import Darcs.Prelude -import qualified Data.ByteString as BS - -import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) +import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.FileHunk( IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) ) import Darcs.Patch.Prim.FileUUID.ObjectMap --- TODO: elaborate +-- ----------------------------------------------------------------------------- +-- Hunk -data Hunk wX wY where - Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk wX wY - deriving Show +data Hunk wX wY = H !Int !FileContent !FileContent + deriving (Eq, Show) instance Show1 (Hunk wX) where - showDict1 = ShowDictClass + showDict1 = ShowDictClass instance Show2 Hunk where - showDict2 = ShowDictClass + showDict2 = ShowDictClass invertHunk :: Hunk wX wY -> Hunk wY wX -invertHunk (Hunk off old new) = Hunk off new old +invertHunk (H off old new) = H off new old -hunkEdit :: Hunk wX wY -> BS.ByteString -> BS.ByteString -hunkEdit (Hunk off old new) bs = case splice bs (off) (off + BS.length old) of - x | x == old -> BS.concat [ BS.take off bs, new, BS.drop (off + BS.length old) bs ] - | otherwise -> error $ "error applying hunk: " ++ show off ++ " " ++ show old ++ " " - ++ show new ++ " to " ++ show bs - where splice bs' x y = BS.drop x $ BS.take y bs' +instance Eq2 Hunk where + unsafeCompare p q = unsafeCoerceP p == q -instance MyEq Hunk where - unsafeCompare (Hunk i x y) (Hunk i' x' y') = i == i' && x == x' && y == y' +-- ----------------------------------------------------------------------------- +-- HunkMove -data Prim wX wY where - BinaryHunk :: !UUID -> Hunk wX wY -> Prim wX wY - TextHunk :: !UUID -> Hunk wX wY -> Prim wX wY +data HunkMove wX wY = HM !UUID !Int !UUID !Int !FileContent + deriving (Eq, Show) - -- TODO: String is not the right type here. However, what it represents is - -- a single file *name* (not a path). No slashes allowed, no "." and ".." - -- allowed either. - Manifest :: !UUID -> Location -> Prim wX wY - Demanifest :: !UUID -> Location -> Prim wX wY - Move :: !UUID -> Location -> Location -> Prim wX wY - Identity :: Prim wX wX +invertHunkMove :: HunkMove wX wY -> HunkMove wY wX +invertHunkMove (HM sid soff tid toff content) = HM tid toff sid soff content +instance Eq2 HunkMove where + unsafeCompare (HM sid1 soff1 tid1 toff1 c1) (HM sid2 soff2 tid2 toff2 c2) = + sid1 == sid2 && soff1 == soff2 && tid1 == tid2 && toff1 == toff2 && c1 == c2 + +-- ----------------------------------------------------------------------------- +-- Prim + +data Prim wX wY where + Hunk :: !UUID -> !(Hunk wX wY) -> Prim wX wY + HunkMove :: !(HunkMove wX wY) -> Prim wX wY + Manifest :: !UUID -> !Location -> Prim wX wY + Demanifest :: !UUID -> !Location -> Prim wX wY + Identity :: Prim wX wX + +deriving instance Eq (Prim wX wY) deriving instance Show (Prim wX wY) instance Show1 (Prim wX) where - showDict1 = ShowDictClass + showDict1 = ShowDictClass instance Show2 Prim where - showDict2 = ShowDictClass - -touches :: Prim wX wY -> [UUID] -touches (BinaryHunk x _) = [x] -touches (TextHunk x _) = [x] -touches (Manifest _ (x, _)) = [x] -touches (Demanifest _ (x, _)) = [x] -touches (Move _ (x, _) (y, _)) = [x, y] -touches Identity = [] + showDict2 = ShowDictClass -- TODO: PrimClassify doesn't make sense for FileUUID prims instance PrimClassify Prim where - primIsAddfile _ = False - primIsRmfile _ = False - primIsAdddir _ = False - primIsRmdir _ = False - primIsHunk _ = False - primIsMove _ = False - primIsBinary _ = False - primIsTokReplace _ = False - primIsSetpref _ = False - is_filepatch _ = Nothing + primIsAddfile _ = False + primIsRmfile _ = False + primIsAdddir _ = False + primIsRmdir _ = False + primIsHunk _ = False + primIsMove _ = False + primIsBinary _ = False + primIsTokReplace _ = False + primIsSetpref _ = False + is_filepatch _ = Nothing -- TODO: PrimConstruct makes no sense for FileUUID prims instance PrimConstruct Prim where - addfile _ = error "PrimConstruct addfile" - rmfile _ = error "PrimConstruct rmfile" - adddir _ = error "PrimConstruct adddir" - rmdir _ = error "PrimConstruct rmdir" - move _ _ = error "PrimConstruct move" - changepref _ _ _ = error "PrimConstruct changepref" - hunk _ _ _ _ = error "PrimConstruct hunk" - tokreplace _ _ _ _ = error "PrimConstruct tokreplace" - binary _ _ _ = error "PrimConstruct binary" - primFromHunk _ = error "PrimConstruct primFromHunk" - anIdentity = Identity + addfile _ = error "PrimConstruct addfile" + rmfile _ = error "PrimConstruct rmfile" + adddir _ = error "PrimConstruct adddir" + rmdir _ = error "PrimConstruct rmdir" + move _ _ = error "PrimConstruct move" + changepref _ _ _ = error "PrimConstruct changepref" + hunk _ _ _ _ = error "PrimConstruct hunk" + tokreplace _ _ _ _ = error "PrimConstruct tokreplace" + binary _ _ _ = error "PrimConstruct binary" + primFromHunk _ = error "PrimConstruct primFromHunk" + anIdentity = Identity instance IsHunk Prim where - isHunk _ = Nothing + isHunk _ = Nothing instance Invert Prim where - invert (BinaryHunk x h) = BinaryHunk x $ invertHunk h - invert (TextHunk x h) = TextHunk x $ invertHunk h - invert (Manifest x y) = Demanifest x y - invert (Demanifest x y) = Manifest x y - invert (Move x y z) = Move x z y - invert Identity = Identity + invert (Hunk x h) = Hunk x $ invertHunk h + invert (HunkMove hm) = HunkMove $ invertHunkMove hm + invert (Manifest x y) = Demanifest x y + invert (Demanifest x y) = Manifest x y + invert Identity = Identity instance PatchInspect Prim where - -- We don't need this for FileUUID. Slashes are not allowed in Manifest and - -- Demanifest patches and nothing else uses working-copy paths. - listTouchedFiles _ = [] - - -- TODO (used for --match 'hunk ...', presumably) - hunkMatches _ _ = False + -- We don't need this for FileUUID. Slashes are not allowed in Manifest and + -- Demanifest patches and nothing else uses working-copy paths. + listTouchedFiles _ = [] -instance MyEq Prim where - unsafeCompare (BinaryHunk a b) (BinaryHunk c d) = a == c && b `unsafeCompare` d - unsafeCompare (TextHunk a b) (TextHunk c d) = a == c && b `unsafeCompare` d - unsafeCompare (Manifest a b) (Manifest c d) = a == c && b == d - unsafeCompare (Demanifest a b) (Demanifest c d) = a == c && b == d - unsafeCompare Identity Identity = True - unsafeCompare _ _ = False + -- TODO (used for --match 'hunk ...', presumably) + hunkMatches _ _ = False -instance Eq (Prim wX wY) where - (==) = unsafeCompare +instance Eq2 Prim where + unsafeCompare (Hunk a b) (Hunk c d) = a == c && b `unsafeCompare` d + unsafeCompare (Manifest a b) (Manifest c d) = a == c && b == d + unsafeCompare (Demanifest a b) (Demanifest c d) = a == c && b == d + unsafeCompare Identity Identity = True + unsafeCompare _ _ = False diff --git a/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs b/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs --- a/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs +++ b/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs @@ -20,24 +20,47 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -module Darcs.Patch.Prim.FileUUID.ObjectMap( UUID(..), Location, Object(..), - ObjectMap(..), DirContent ) where +module Darcs.Patch.Prim.FileUUID.ObjectMap + ( UUID(..), Location(..), Object(..) + , ObjectMap(..), DirContent, FileContent + , isBlob, isDirectory + , Name -- re-export + ) where import Prelude () import Darcs.Prelude -import Darcs.Util.Hash( Hash ) -import qualified Data.ByteString as BS (ByteString) +import Darcs.Util.Hash ( Hash ) +import Darcs.Util.Path ( Name ) +import qualified Data.ByteString as B (ByteString) import qualified Data.Map as M +type FileContent = B.ByteString -newtype UUID = UUID BS.ByteString deriving (Eq, Ord, Show) -type Location = (UUID, BS.ByteString) -type DirContent = M.Map BS.ByteString UUID -data Object (m :: * -> *) = Directory DirContent - | Blob (m BS.ByteString) !Hash +newtype UUID = UUID B.ByteString deriving (Eq, Ord, Show) -data ObjectMap (m :: * -> *) = ObjectMap { getObject :: UUID -> m (Maybe (Object m)) - , putObject :: UUID -> Object m -> m (ObjectMap m) - , listObjects :: m [UUID] - } +-- | An object is located by giving the 'UUID' of the parent +-- 'Directory' and a 'Name'. +data Location = L !UUID !Name + deriving (Eq, Show) + +-- TODO use HashMap instead? +type DirContent = M.Map Name UUID + +data Object (m :: * -> *) + = Directory DirContent + | Blob (m FileContent) !Hash + +isBlob :: Object m -> Bool +isBlob Blob{} = True +isBlob Directory{} = False + +isDirectory :: Object m -> Bool +isDirectory Directory{} = True +isDirectory Blob{} = False + +data ObjectMap (m :: * -> *) = ObjectMap + { getObject :: UUID -> m (Maybe (Object m)) + , putObject :: UUID -> Object m -> m (ObjectMap m) + , listObjects :: m [UUID] + } diff --git a/src/Darcs/Patch/Prim/FileUUID/Read.hs b/src/Darcs/Patch/Prim/FileUUID/Read.hs --- a/src/Darcs/Patch/Prim/FileUUID/Read.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Read.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ViewPatterns, OverloadedStrings #-} +{-# LANGUAGE ViewPatterns, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.FileUUID.Read () where @@ -8,39 +8,43 @@ import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.ReadMonads import Darcs.Patch.Prim.Class( PrimRead(..) ) -import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..) ) +import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..), Location(..) ) import Darcs.Patch.Prim.FileUUID.ObjectMap import Darcs.Patch.Witnesses.Sealed( seal ) +import Darcs.Util.Path ( unsafeMakeName ) import Control.Monad ( liftM, liftM2 ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Char ( chr ) -#include "impossible.h" - instance PrimRead Prim where - readPrim _ = do skipSpace - choice $ map (liftM seal) [ - identity, - hunk "hunk" TextHunk, - hunk "binhunk" BinaryHunk, - manifest "manifest" Manifest, - manifest "demanifest" Demanifest ] - - where manifest kind ctor = liftM2 ctor (patch kind) location - identity = lexString "identity" >> return Identity - patch x = string x >> uuid - uuid = UUID <$> myLex' - filename = encoded - encoded = decodeWhite <$> myLex' - hunktext = skipSpace >> choice [ string "." >> encoded, string "!" >> return B.empty ] - location = liftM2 (,) uuid filename - hunk kind ctor = do uid <- patch kind - offset <- int - old <- hunktext - new <- hunktext - return $ ctor uid (Hunk offset old new) + readPrim _ = do + skipSpace + choice $ map (liftM seal) + [ identity + , hunk "hunk" Hunk + , manifest "manifest" Manifest + , manifest "demanifest" Demanifest + ] + where + manifest kind ctor = liftM2 ctor (patch kind) location + identity = lexString "identity" >> return Identity + patch x = string x >> uuid + uuid = UUID <$> myLex' + filename = unsafeMakeName . decodeWhite <$> myLex' + content = do + lexString "content" + len <- int + _ <- char '\n' + Darcs.Patch.ReadMonads.take len + location = liftM2 L uuid filename + hunk kind ctor = do + uid <- patch kind + offset <- int + old <- content + new <- content + return $ ctor uid (H offset old new) instance ReadPatch Prim where readPatch' = readPrim undefined diff --git a/src/Darcs/Patch/Prim/FileUUID/Show.hs b/src/Darcs/Patch/Prim/FileUUID/Show.hs --- a/src/Darcs/Patch/Prim/FileUUID/Show.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Show.hs @@ -1,70 +1,118 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.Patch.Prim.FileUUID.Show - ( showHunk ) + ( displayHunk ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( pi ) - -import Data.Char ( isSpace, ord ) import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) -import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims ) +import Darcs.Patch.Show + ( ShowPatchBasic(..), ShowPatch(..) + , ShowContextPatch(..), ShowPatchFor(..) ) +import Darcs.Patch.Summary ( plainSummaryPrim ) import Darcs.Patch.Prim.Class ( PrimShow(..) ) -import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), UUID(..) ) +import Darcs.Patch.Prim.FileUUID.Core + ( Prim(..), Hunk(..), HunkMove(..), UUID(..), Location(..), FileContent ) import Darcs.Patch.Prim.FileUUID.Details () -import Darcs.Util.Printer ( text, packedString, blueText, (<+>), (<>), Doc ) - -#include "impossible.h" +import Darcs.Util.ByteString ( linesPS ) +import Darcs.Util.Path ( Name, encodeWhiteName ) +import Darcs.Util.Printer + ( text, packedString, blueText, prefix + , (<+>), (<>), ($$), Doc, vcat + ) -- TODO this instance shouldn't really be necessary, as Prims aren't used generically instance PatchListFormat Prim +fileNameFormat :: ShowPatchFor -> FileNameFormat +fileNameFormat ForDisplay = UserFormat +fileNameFormat ForStorage = NewFormat + instance ShowPatchBasic Prim where - showPatch = showPrim OldFormat + showPatch fmt = showPrim (fileNameFormat fmt) +-- dummy instance, does not actually show any context +instance ShowContextPatch Prim where + -- showContextPatch f = showPrimCtx (fileNameFormat f) + showContextPatch f p = return $ showPatch f p + instance ShowPatch Prim where - showContextPatch p = return $ showPatch p - summary = plainSummaryPrim - summaryFL = plainSummaryPrims False [] - thing _ = "change" + summary = plainSummaryPrim + -- summaryFL = plainSummaryPrims False + thing _ = "change" instance PrimShow Prim where - showPrim _ (TextHunk u h) = showHunk "hunk" u h - showPrim _ (BinaryHunk u h) = showHunk "binhunk" u h - showPrim _ (Manifest f (d,p)) = showManifest "manifest" d f p - showPrim _ (Demanifest f (d,p)) = showManifest "demanifest" d f p + showPrim UserFormat (Hunk u h) = displayHunk (Just u) h + showPrim _ (Hunk u h) = storeHunk u h + showPrim UserFormat (HunkMove hm) = displayHunkMove hm + showPrim _ (HunkMove hm) = storeHunkMove hm + showPrim _ (Manifest f (L d p)) = showManifest "manifest" d f p + showPrim _ (Demanifest f (L d p)) = showManifest "demanifest" d f p showPrim _ Identity = blueText "identity" - showPrim _ (Move{}) = bug "show for move not implemented" + showPrimCtx _ _ = bug "show with context not implemented" -showManifest :: String -> UUID -> UUID -> BC.ByteString -> Doc -showManifest txt dir file path = blueText txt <+> - formatUUID file <+> - formatUUID dir <+> - packedString (encodeWhite path) +showManifest :: String -> UUID -> UUID -> Name -> Doc +showManifest txt dir file name = + blueText txt <+> + formatUUID file <+> + formatUUID dir <+> + packedString (encodeWhiteName name) -showHunk :: String -> UUID -> Hunk wX wY -> Doc -showHunk txt uid (Hunk off old new) = blueText txt <+> - formatUUID uid <+> - text (show off) <+> - hunktext old <+> - hunktext new - where hunktext bit | B.null bit = text "!" - | otherwise = text "." <> packedString (encodeWhite bit) +displayHunk :: Maybe UUID -> Hunk wX wY -> Doc +displayHunk uid (H off old new) = + blueText "hunk" <+> + maybe (text "") formatUUID uid <+> + text (show off) $$ + displayFileContent "-" old $$ + displayFileContent "+" new -formatUUID :: UUID -> Doc -formatUUID (UUID x) = packedString x +storeHunk :: UUID -> Hunk wX wY -> Doc +storeHunk uid (H off old new) = + text "hunk" <+> + formatUUID uid <+> + text (show off) $$ + storeFileContent old $$ + storeFileContent new --- XXX a bytestring version of encodeWhite from Darcs.FileName -encodeWhite :: B.ByteString -> B.ByteString -encodeWhite = BC.concatMap encode - where encode c - | isSpace c || c == '\\' = B.concat [ "\\", BC.pack $ show $ ord c, "\\" ] - | otherwise = BC.singleton c +displayHunkMove :: HunkMove wX wY -> Doc +displayHunkMove (HM sid soff tid toff c) = + blueText "hunkmove" <+> + formatUUID sid <+> + text (show soff) <+> + formatUUID tid <+> + text (show toff) $$ + displayFileContent "|" c +storeHunkMove :: HunkMove wX wY -> Doc +storeHunkMove (HM sid soff tid toff c) = + text "hunkmove" <+> + formatUUID sid <+> + text (show soff) <+> + formatUUID tid <+> + text (show toff) $$ + storeFileContent c + +-- TODO add some heuristics to recognize binary content +displayFileContent :: String -> FileContent -> Doc +displayFileContent pre = vcat . map (prefix pre) . showLines . linesPS + where + context = blueText "[...]" + showLines [] = [] + showLines [x] + | B.null x = [] + | otherwise = [context <> packedString x <> context] + showLines (x:xs) = + [context <> packedString x] ++ + map packedString (init xs) ++ + [packedString (last xs) <> context] + +storeFileContent :: FileContent -> Doc +storeFileContent c = + text "content" <+> text (show (B.length c)) $$ packedString c + +formatUUID :: UUID -> Doc +formatUUID (UUID x) = packedString x diff --git a/src/Darcs/Patch/Prim/V1.hs b/src/Darcs/Patch/Prim/V1.hs --- a/src/Darcs/Patch/Prim/V1.hs +++ b/src/Darcs/Patch/Prim/V1.hs @@ -1,9 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1 ( Prim ) where -import Prelude () -import Darcs.Prelude - import Darcs.Patch.Prim.V1.Apply () import Darcs.Patch.Prim.V1.Coalesce () import Darcs.Patch.Prim.V1.Commute () @@ -12,13 +9,6 @@ import Darcs.Patch.Prim.V1.Read () import Darcs.Patch.Prim.V1.Show () -import Darcs.Patch.Prim.Class ( PrimPatch, PrimPatchBase(..), FromPrim(..) ) -import Darcs.Patch.Patchy ( Patchy ) - -instance PrimPatch Prim -instance Patchy Prim -instance PrimPatchBase Prim where - type PrimOf Prim = Prim +import Darcs.Patch.Prim.Class ( PrimPatchCommon ) -instance FromPrim Prim where - fromPrim = id +instance PrimPatchCommon Prim diff --git a/src/Darcs/Patch/Prim/V1/Apply.hs b/src/Darcs/Patch/Prim/V1/Apply.hs --- a/src/Darcs/Patch/Prim/V1/Apply.hs +++ b/src/Darcs/Patch/Prim/V1/Apply.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Apply () where import Prelude () @@ -14,24 +13,23 @@ DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Prim.V1.Show ( showHunk ) -import Darcs.Util.Path ( fn2fp ) -import Darcs.Patch.Format ( FileNameFormat(..) ) -import Darcs.Patch.TokenReplace ( tryTokInternal ) +import Darcs.Util.Path ( FileName, fn2fp ) +import Darcs.Patch.Format ( FileNameFormat(UserFormat) ) +import Darcs.Patch.TokenReplace ( tryTokReplace ) -import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) ) +import Darcs.Patch.ApplyMonad ( ApplyMonadTree(..) ) import Darcs.Util.Tree( Tree ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart ) -import Darcs.Util.ByteString ( unlinesPS, breakAfterNthNewline, breakBeforeNthNewline, ) -import Darcs.Util.Printer( renderString, RenderMode(..) ) +import Darcs.Util.ByteString ( unlinesPS ) +import Darcs.Util.Printer( renderString ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI import qualified Data.ByteString as B ( ByteString, empty, null, concat ) -import qualified Data.ByteString.Char8 as BC (pack, singleton, unpack) -import Data.List ( intersperse ) - -#include "impossible.h" +import qualified Data.ByteString.Char8 as BC (pack, unpack, unlines) type FileContents = B.ByteString @@ -39,13 +37,13 @@ type ApplyState Prim = Tree apply (FP f RmFile) = mRemoveFile f apply (FP f AddFile) = mCreateFile f - apply p@(FP _ (Hunk{})) = applyPrimFL (p :>: NilFL) - apply (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace - where doreplace ls = - case mapM (tryTokInternal t (BC.pack o) (BC.pack n)) ls of + apply (FP f (Hunk l o n)) = mModifyFilePS f $ applyHunk f (l, o, n) + apply (FP f (TokReplace t o n)) = mModifyFilePS f doreplace + where doreplace fc = + case tryTokReplace t (BC.pack o) (BC.pack n) fc of Nothing -> fail $ "replace patch to " ++ fn2fp f ++ " couldn't apply." - Just ls' -> return $ map B.concat ls' + Just fc' -> return fc' apply (FP f (Binary o n)) = mModifyFilePS f doapply where doapply oldf = if o == oldf then return n @@ -96,61 +94,129 @@ do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs mModifyFilePS f $ hunkmod foo applyPrimFL ps' - where f_hunk (FP f' (Hunk{})) | f == f' = True + where f_hunk (FP f' (Hunk{})) = f == f' f_hunk _ = False - hunkmod :: ApplyMonad Tree m => FL FilePatchType wX wY + -- TODO there should be a HOF that abstracts + -- over this recursion scheme + hunkmod :: Monad m => FL FilePatchType wX wY -> B.ByteString -> m B.ByteString - hunkmod NilFL ps = return ps - hunkmod (Hunk line old new:>:hs) ps - = case applyHunkLines [(line,old,new)] ps of - Just ps' -> hunkmod hs ps' - Nothing -> fail $ "### Error applying:\n" ++ - renderString Encode - (showHunk NewFormat f line old new) ++ - "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack ps + hunkmod NilFL content = return content + hunkmod (Hunk line old new:>:hs) content = + applyHunk f (line, old, new) content >>= hunkmod hs hunkmod _ _ = impossible - applyPrimFL (p:>:ps) = do apply p - applyPrimFL ps + applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps -applyHunks :: [(Int, [B.ByteString], [B.ByteString])] - -> B.ByteString -> Maybe [B.ByteString] -applyHunks [] ps = Just [ps] -applyHunks ((l, [], n):hs) ps - = case breakBeforeNthNewline (l - 2) ps of - (prfix, after_prefix) -> do rest <- applyHunks hs after_prefix - return $ intersperse nl (prfix:n) ++ rest - where nl = BC.singleton '\n' -applyHunks ((l, o, n):hs) ps - = case breakBeforeNthNewline (l - 2) ps of - (prfix, after_prefix) -> - case breakBeforeNthNewline (length o) after_prefix of - (oo, _) | oo /= unlinesPS (B.empty:o) -> fail "applyHunks error" - (_, suffix) -> - do rest <- applyHunks hs suffix - return $ intersperse nl (prfix:n) ++ rest - where nl = BC.singleton '\n' +applyHunk :: Monad m + => FileName + -> (Int, [B.ByteString], [B.ByteString]) + -> FileContents + -> m FileContents +applyHunk f h fc = + case applyHunkLines h fc of + Right fc' -> return fc' + Left msg -> + fail $ + "### Error applying:\n" ++ renderHunk h ++ + "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack fc ++ + "### Reason: " ++ msg + where + renderHunk (l, o, n) = renderString (showHunk UserFormat f l o n) -applyHunkLines :: [(Int, [B.ByteString], [B.ByteString])] - -> FileContents -> Maybe FileContents -applyHunkLines [] c = Just c -applyHunkLines [(1, [], n)] ps | B.null ps = Just $ unlinesPS (n++[B.empty]) -applyHunkLines hs@((l, o, n):hs') ps = - do pss <- case l of - 1 -> case breakAfterNthNewline (length o) ps of - Nothing -> if ps == unlinesPS o - then return $ intersperse nl n - else fail "applyHunkLines: Unexpected hunks" - Just (shouldbeo, suffix) - | shouldbeo /= unlinesPS (o++[B.empty]) -> - fail "applyHunkLines: Bad patch!" - | null n -> - do x <- applyHunkLines hs' suffix - return [x] - | otherwise -> - do rest <- applyHunks hs' suffix - return $ intersperse nl n ++ nl:rest - _ | l < 0 -> bug "Prim.applyHunkLines: After -ve lines?" - | otherwise -> applyHunks hs ps - let result = B.concat pss - return result - where nl = BC.singleton '\n' +{- The way darcs handles newlines is not easy to understand. + +Everything seems pretty logical and conventional as long as files end in a +newline. In this case, the lines in a hunk can be regarded as newline +terminated, too. However, this view breaks down if we consider files that +are not newline terminated. + +Here is a different view that covers the general case and explains, +conceptually, the algorithm below. + +* Ever line (in a hunk or file) is regarded as being /preceded/ by a newline + character. + +* Every file starts out containing a single newline character, that is, a + single empty line. A first empty line at the start of a file (if present) + is /invisible/. + +* When lines are appended to a file by a hunk, they are inserted /before/ a + final empty line, if there is one. This results in a file that remains + being terminated by a newline. + +* In particular, when we start with an empty file and add a line, we push + the invisible newline back, making it visible, and the newline that + initiates our new content becomes invisible instead. This results in a + newline terminated file, as above. + +* However, if there is a newline at the end of a file (remember that this + includes the case of an empty file), a hunk can /remove/ it by removing an + empty line before adding anything. This results in a file that is /not/ + newline terminated. + +The invisible newline character at the front is, of course, not present +anywhere in the representation of files, it is just a conceptual tool. + +The algorithm below is highly optimized to minimize allocation of +intermediate ByteStrings. -} + +applyHunkLines :: (Int, [B.ByteString], [B.ByteString]) + -> FileContents + -> Either String FileContents +applyHunkLines (line, old, new) content + | line == 1 = + {- This case is subtle because here we have to deal with any invisible + newline at the front of a file without it actually being present. We + first try to drop everything up to the (length old)'th newline. + + If this fails, we know that the content was not newline terminated. So + we replace everything with the new content, interspersing but not + terminating the lines with newline characters. + + If it succeeds, we insert the new content, interspersing /and/ + terminating the lines with newline characters before appending the + rest of the content. -} + case breakAfterNthNewline (length old) content of + Nothing + -- old content is not newline terminated + | content == unlinesPS old -> Right $ unlinesPS new + | otherwise -> Left "Hunk wants to remove content that isn't there" + Just (should_be_old, suffix) + -- old content is newline terminated + | should_be_old == BC.unlines old -> + Right $ unlinesPS $ new ++ [suffix] + | otherwise -> + Left "Hunk wants to remove content that isn't there" + | line >= 2 = do + {- This is the simpler case. We can be sure that we have at least one + newline character at the point where we modify the file. This means we + can apply the conceptual view literally, i.e. replace old content with + new content /before/ this newline, where the lines in the old and new + content are /preceded/ by newline characters. -} + (pre, start) <- breakBeforeNthNewline (line-2) content + let hunkContent ls = unlinesPS (B.empty:ls) + post <- dropPrefix (hunkContent old) start + return $ B.concat [pre, hunkContent new, post] + | otherwise = Left "Hunk has zero or negative line number" + where + dropPrefix x y + | x `B.isPrefixOf` y = Right $ B.drop (B.length x) y + | otherwise = + Left $ "Hunk wants to remove content that isn't there" + +breakAfterNthNewline :: Int -> B.ByteString -> Maybe (B.ByteString, B.ByteString) +breakAfterNthNewline 0 the_ps = Just (B.empty, the_ps) +breakAfterNthNewline n _ | n < 0 = error "precondition of breakAfterNthNewline" +breakAfterNthNewline n the_ps = go n (B.elemIndices (BI.c2w '\n') the_ps) + where + go _ [] = Nothing -- we have fewer than n newlines + go 1 (i:_) = Just $ B.splitAt (i + 1) the_ps + go !m (_:is) = go (m - 1) is + +breakBeforeNthNewline :: Int -> B.ByteString -> Either String (B.ByteString, B.ByteString) +breakBeforeNthNewline n _ | n < 0 = error "precondition of breakBeforeNthNewline" +breakBeforeNthNewline n the_ps = go n (B.elemIndices (BI.c2w '\n') the_ps) + where + go 0 [] = Right (the_ps, B.empty) + go 0 (i:_) = Right $ B.splitAt i the_ps + go !m (_:is) = go (m - 1) is + go _ [] = Left "Line number does not exist" diff --git a/src/Darcs/Patch/Prim/V1/Coalesce.hs b/src/Darcs/Patch/Prim/V1/Coalesce.hs --- a/src/Darcs/Patch/Prim/V1/Coalesce.hs +++ b/src/Darcs/Patch/Prim/V1/Coalesce.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Coalesce () where @@ -23,7 +22,7 @@ , comparePrim, isIdentity ) import Darcs.Patch.Prim.V1.Show () -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) , reverseRL, mapFL, mapFL_FL @@ -41,8 +40,6 @@ import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( FileName, fp2fn ) -#include "impossible.h" - -- | 'coalesceFwd' @p1 :> p2@ tries to combine @p1@ and @p2@ into a single -- patch without intermediary changes. For example, two hunk patches -- modifying adjacent lines can be coalesced into a bigger hunk patch. @@ -81,9 +78,11 @@ -data Simple wX wY = SFP !(FilePatchType wX wY) | SDP !(DirPatchType wX wY) - | SCP String String String - deriving ( Show ) +data Simple wX wY + = SFP !(FilePatchType wX wY) + | SDP !(DirPatchType wX wY) + | SCP String String String + deriving ( Show ) toSimple :: Prim wX wY -> Maybe (FileName, Simple wX wY) toSimple (FP a b) = Just (a, SFP b) diff --git a/src/Darcs/Patch/Prim/V1/Commute.hs b/src/Darcs/Patch/Prim/V1/Commute.hs --- a/src/Darcs/Patch/Prim/V1/Commute.hs +++ b/src/Darcs/Patch/Prim/V1/Commute.hs @@ -1,10 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Commute ( Perhaps(..) - , subcommutes, WrappedCommuteFunction(..) - ) - where + , toPerhaps + , CommuteFunction + , speedyCommute + , cleverCommute + , commuteFiledir + , commuteFilepatches + ) where import Prelude () import Darcs.Prelude @@ -13,8 +16,8 @@ import Control.Monad ( MonadPlus, msum, mzero, mplus ) import Control.Applicative ( Alternative(..) ) -import qualified Data.ByteString as B (ByteString, concat) -import qualified Data.ByteString.Char8 as BC (pack) +import qualified Data.ByteString as B ( ByteString ) +import qualified Data.ByteString.Char8 as BC ( pack ) import Darcs.Util.Path ( FileName, fn2fp, movedirfilename ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) @@ -24,9 +27,7 @@ import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL -import Darcs.Patch.TokenReplace ( tryTokInternal ) - -#include "impossible.h" +import Darcs.Patch.TokenReplace ( tryTokReplace ) isInDirectory :: FileName -> FileName -> Bool isInDirectory d f = iid (fn2fp d) (fn2fp f) @@ -162,16 +163,7 @@ commuteFiledir _ = Unknown type CommuteFunction = forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY) -newtype WrappedCommuteFunction = WrappedCommuteFunction { runWrappedCommuteFunction :: CommuteFunction } -subcommutes :: [(String, WrappedCommuteFunction)] -subcommutes = - [("speedyCommute", WrappedCommuteFunction speedyCommute), - ("commuteFiledir", WrappedCommuteFunction (cleverCommute commuteFiledir)), - ("commuteFilepatches", WrappedCommuteFunction (cleverCommute commuteFilepatches)), - ("commutex", WrappedCommuteFunction (toPerhaps . commute)) - ] - commuteFilepatches :: CommuteFunction commuteFilepatches (FP f1 p1 :> FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :> p2) commuteFilepatches _ = Unknown @@ -179,21 +171,25 @@ commuteFP :: FileName -> (FilePatchType :> FilePatchType) wX wY -> Perhaps ((Prim :> Prim) wX wY) commuteFP f (p1 :> Hunk line1 [] []) = - seq f $ Succeeded (FP f (Hunk line1 [] []) :> FP f (unsafeCoerceP p1)) + Succeeded (FP f (Hunk line1 [] []) :> FP f (unsafeCoerceP p1)) commuteFP f (Hunk line1 [] [] :> p2) = - seq f $ Succeeded (FP f (unsafeCoerceP p2) :> FP f (Hunk line1 [] [])) -commuteFP f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) = seq f $ - toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) -commuteFP f (Hunk line1 old1 new1 :> TokReplace t o n) = seq f $ - case tryTokReplace t o n old1 of + Succeeded (FP f (unsafeCoerceP p2) :> FP f (Hunk line1 [] [])) +commuteFP f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) = + case commuteHunkLines line1 (length old1) (length new1) line2 (length old2) (length new2) of + Just (line2', line1') -> + Succeeded (FP f (Hunk line2' old2 new2) :> FP f (Hunk line1' old1 new1)) + Nothing -> Failed +commuteFP f (Hunk line1 old1 new1 :> TokReplace t o n) = + let po = BC.pack o; pn = BC.pack n in + case tryTokReplaces t po pn old1 of Nothing -> Failed Just old1' -> - case tryTokReplace t o n new1 of + case tryTokReplaces t po pn new1 of Nothing -> Failed Just new1' -> Succeeded (FP f (TokReplace t o n) :> FP f (Hunk line1 old1' new1')) commuteFP f (TokReplace t1 o1 n1 :> TokReplace t2 o2 n2) - | seq f $ t1 /= t2 = Failed + | t1 /= t2 = Failed | o1 == o2 = Failed | n1 == o2 = Failed | o1 == n2 = Failed @@ -202,31 +198,23 @@ FP f (TokReplace t1 o1 n1)) commuteFP _ _ = Unknown -commuteHunk :: FileName -> (FilePatchType :> FilePatchType) wX wY - -> Maybe ((Prim :> Prim) wX wY) -commuteHunk f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) - | seq f $ line1 + lengthnew1 < line2 = - Just (FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2) :> - FP f (Hunk line1 old1 new1)) - | line2 + lengthold2 < line1 = - Just (FP f (Hunk line2 old2 new2) :> - FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1)) - | line1 + lengthnew1 == line2 && - lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - Just (FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2) :> - FP f (Hunk line1 old1 new1)) - | line2 + lengthold2 == line1 && - lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - Just (FP f (Hunk line2 old2 new2) :> - FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1)) - | otherwise = seq f Nothing - where lengthnew1 = length new1 - lengthnew2 = length new2 - lengthold1 = length old1 - lengthold2 = length old2 -commuteHunk _ _ = impossible +commuteHunkLines :: Int -> Int -> Int -> Int -> Int -> Int + -> Maybe (Int, Int) +commuteHunkLines line1 len_old1 len_new1 line2 len_old2 len_new2 + | line1 + len_new1 < line2 = Just (line2 - len_new1 + len_old1, line1) + | line2 + len_old2 < line1 = Just (line2, line1 + len_new2 - len_old2) + | len_old2 /= 0 + , len_old1 /= 0 + , len_new2 /= 0 + , len_new1 /= 0 + , line1 + len_new1 == line2 = Just (line2 - len_new1 + len_old1, line1) + | len_old2 /= 0 + , len_old1 /= 0 + , len_new2 /= 0 + , len_new1 /= 0 + , line2 + len_old2 == line1 = Just (line2, line1 + len_new2 - len_old2) + | otherwise = Nothing -tryTokReplace :: String -> String -> String - -> [B.ByteString] -> Maybe [B.ByteString] -tryTokReplace t o n = - mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n)) +tryTokReplaces :: String -> B.ByteString -> B.ByteString + -> [B.ByteString] -> Maybe [B.ByteString] +tryTokReplaces t o n = mapM (tryTokReplace t o n) diff --git a/src/Darcs/Patch/Prim/V1/Core.hs b/src/Darcs/Patch/Prim/V1/Core.hs --- a/src/Darcs/Patch/Prim/V1/Core.hs +++ b/src/Darcs/Patch/Prim/V1/Core.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..), @@ -29,12 +26,10 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( pi ) - import qualified Data.ByteString as B (ByteString) import Darcs.Util.Path ( FileName, fn2fp, fp2fn, normPath ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) @@ -49,19 +44,21 @@ FP :: !FileName -> !(FilePatchType wX wY) -> Prim wX wY ChangePref :: !String -> !String -> !String -> Prim wX wY -data FilePatchType wX wY = RmFile | AddFile - | Hunk !Int [B.ByteString] [B.ByteString] - | TokReplace !String !String !String - | Binary B.ByteString B.ByteString - deriving (Eq,Ord) +data FilePatchType wX wY + = RmFile + | AddFile + | Hunk !Int [B.ByteString] [B.ByteString] + | TokReplace !String !String !String + | Binary B.ByteString B.ByteString + deriving (Eq,Ord) data DirPatchType wX wY = RmDir | AddDir deriving (Eq,Ord) -instance MyEq FilePatchType where +instance Eq2 FilePatchType where unsafeCompare a b = a == unsafeCoerceP b -instance MyEq DirPatchType where +instance Eq2 DirPatchType where unsafeCompare a b = a == unsafeCoerceP b isIdentity :: Prim wX wY -> EqCheck wX wY @@ -153,7 +150,7 @@ instance PatchDebug Prim -instance MyEq Prim where +instance Eq2 Prim where unsafeCompare (Move a b) (Move c d) = a == c && b == d unsafeCompare (DP d1 p1) (DP d2 p2) = d1 == d2 && p1 `unsafeCompare` p2 diff --git a/src/Darcs/Patch/Prim/V1/Read.hs b/src/Darcs/Patch/Prim/V1/Read.hs --- a/src/Darcs/Patch/Prim/V1/Read.hs +++ b/src/Darcs/Patch/Prim/V1/Read.hs @@ -6,17 +6,19 @@ import Darcs.Patch.Prim.Class ( PrimRead(..), hunk, binary ) import Darcs.Patch.Prim.V1.Core - ( Prim(..), - DirPatchType(..), FilePatchType(..) ) + ( Prim(..) + , DirPatchType(..) + , FilePatchType(..) + ) import Darcs.Util.Path ( fn2fp ) -import Darcs.Patch.Format ( FileNameFormat(..) ) -import Darcs.Patch.Read ( ReadPatch(..), readFileName ) -import Darcs.Patch.ReadMonads (ParserM, takeTillChar, - string, int, - option, choice, - anyChar, char, myLex', - skipSpace, skipWhile, linesStartingWith) +import Darcs.Patch.Format ( FileNameFormat ) +import Darcs.Patch.Read ( readFileName ) +import Darcs.Patch.ReadMonads + ( ParserM, takeTillChar, string, int + , option, choice, anyChar, char, myLex' + , skipSpace, skipWhile, linesStartingWith + ) import Darcs.Patch.Witnesses.Sealed ( seal ) @@ -27,20 +29,17 @@ import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -instance ReadPatch Prim where - readPatch' = readPrim OldFormat - instance PrimRead Prim where - readPrim x + readPrim fmt = skipSpace >> choice - [ return' $ readHunk x - , return' $ readAddFile x - , return' $ readAddDir x - , return' $ readMove x - , return' $ readRmFile x - , return' $ readRmDir x - , return' $ readTok x - , return' $ readBinary x + [ return' $ readHunk fmt + , return' $ readAddFile fmt + , return' $ readAddDir fmt + , return' $ readMove fmt + , return' $ readRmFile fmt + , return' $ readRmDir fmt + , return' $ readTok fmt + , return' $ readBinary fmt , return' readChangePref ] where @@ -74,30 +73,31 @@ changepref = BC.pack "changepref" readHunk :: ParserM m => FileNameFormat -> m (Prim wX wY) -readHunk x = do +readHunk fmt = do string hunk' fi <- myLex' l <- int have_nl <- skipNewline if have_nl - then do _ <- linesStartingWith ' ' -- skipping context - old <- linesStartingWith '-' - new <- linesStartingWith '+' - _ <- linesStartingWith ' ' -- skipping context - return $ hunk (fn2fp $ readFileName x fi) l old new - else return $ hunk (fn2fp $ readFileName x fi) l [] [] + then do + _ <- linesStartingWith ' ' -- skipping context + old <- linesStartingWith '-' + new <- linesStartingWith '+' + _ <- linesStartingWith ' ' -- skipping context + return $ hunk (fn2fp $ readFileName fmt fi) l old new + else return $ hunk (fn2fp $ readFileName fmt fi) l [] [] skipNewline :: ParserM m => m Bool skipNewline = option False (char '\n' >> return True) readTok :: ParserM m => FileNameFormat -> m (Prim wX wY) -readTok x = do +readTok fmt = do string replace f <- myLex' regstr <- myLex' o <- myLex' n <- myLex' - return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr)) + return $ FP (readFileName fmt f) $ TokReplace (BC.unpack (drop_brackets regstr)) (BC.unpack o) (BC.unpack n) where drop_brackets = B.init . B.tail @@ -114,7 +114,7 @@ -- > *HEXHEXHEX -- > ... readBinary :: ParserM m => FileNameFormat -> m (Prim wX wY) -readBinary x = do +readBinary fmt = do string binary' fi <- myLex' _ <- myLex' @@ -123,44 +123,48 @@ _ <- myLex' skipSpace new <- linesStartingWith '*' - return $ binary (fn2fp $ readFileName x fi) + return $ binary (fn2fp $ readFileName fmt fi) (fromHex2PS $ B.concat old) (fromHex2PS $ B.concat new) readAddFile :: ParserM m => FileNameFormat -> m (Prim wX wY) -readAddFile x = do string addfile - f <- myLex' - return $ FP (readFileName x f) AddFile +readAddFile fmt = do + string addfile + f <- myLex' + return $ FP (readFileName fmt f) AddFile readRmFile :: ParserM m => FileNameFormat -> m (Prim wX wY) -readRmFile x = do string rmfile - f <- myLex' - return $ FP (readFileName x f) RmFile +readRmFile fmt = do + string rmfile + f <- myLex' + return $ FP (readFileName fmt f) RmFile readMove :: ParserM m => FileNameFormat -> m (Prim wX wY) -readMove x = do string move - d <- myLex' - d' <- myLex' - return $ Move (readFileName x d) (readFileName x d') +readMove fmt = do + string move + d <- myLex' + d' <- myLex' + return $ Move (readFileName fmt d) (readFileName fmt d') readChangePref :: ParserM m => m (Prim wX wY) -readChangePref - = do string changepref - p <- myLex' - skipWhile (== ' ') - _ <- anyChar -- skip newline - f <- takeTillChar '\n' - _ <- anyChar -- skip newline - t <- takeTillChar '\n' - return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) +readChangePref = do + string changepref + p <- myLex' + skipWhile (== ' ') + _ <- anyChar -- skip newline + f <- takeTillChar '\n' + _ <- anyChar -- skip newline + t <- takeTillChar '\n' + return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) readAddDir :: ParserM m => FileNameFormat -> m (Prim wX wY) -readAddDir x = do string adddir - f <- myLex' - return $ DP (readFileName x f) AddDir +readAddDir fmt = do + string adddir + f <- myLex' + return $ DP (readFileName fmt f) AddDir readRmDir :: ParserM m => FileNameFormat -> m (Prim wX wY) -readRmDir x = do string rmdir - f <- myLex' - return $ DP (readFileName x f) RmDir - +readRmDir fmt = do + string rmdir + f <- myLex' + return $ DP (readFileName fmt f) RmDir diff --git a/src/Darcs/Patch/Prim/V1/Show.hs b/src/Darcs/Patch/Prim/V1/Show.hs --- a/src/Darcs/Patch/Prim/V1/Show.hs +++ b/src/Darcs/Patch/Prim/V1/Show.hs @@ -7,47 +7,31 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( pi ) - import Darcs.Util.ByteString ( fromPS2Hex ) import qualified Data.ByteString as B (ByteString, length, take, drop) import qualified Data.ByteString.Char8 as BC (head) -import Darcs.Util.Tree( Tree ) - -import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showFileHunk ) -import Darcs.Util.Path ( FileName ) -import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName ) -import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims ) -import Darcs.Patch.Viewing ( showContextHunk ) +import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Patch.FileHunk ( FileHunk(..), showFileHunk ) +import Darcs.Patch.Format ( FileNameFormat ) +import Darcs.Patch.Show ( formatFileName ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Patch.Prim.Class ( PrimShow(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.Prim.V1.Details () +import Darcs.Patch.Viewing ( showContextHunk ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) ) + +import Darcs.Util.Path ( FileName ) import Darcs.Util.Printer ( Doc, vcat, text, userchunk, invisibleText, invisiblePS, blueText, ($$), (<+>), (<>), ) import Darcs.Util.Show ( appPrec, BSWrapper(..) ) +import Darcs.Util.Tree ( Tree ) --- TODO this instance shouldn't really be necessary, as Prims aren't used generically -instance PatchListFormat Prim - -instance ShowPatchBasic Prim where - showPatch = showPrim OldFormat - -instance (ApplyState Prim ~ Tree) => ShowPatch Prim where - showContextPatch (isHunk -> Just fh) = showContextHunk fh - showContextPatch p = return $ showPatch p - summary = plainSummaryPrim - summaryFL = plainSummaryPrims False [] - thing _ = "change" - instance Show (Prim wX wY) where showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " . showsPrec (appPrec + 1) fn1 . showString " " . @@ -96,25 +80,27 @@ showsPrec _ RmDir = showString "RmDir" showsPrec _ AddDir = showString "AddDir" -instance PrimShow Prim where - showPrim x (FP f AddFile) = showAddFile x f - showPrim x (FP f RmFile) = showRmFile x f - showPrim x (FP f (Hunk line old new)) = showHunk x f line old new - showPrim x (FP f (TokReplace t old new)) = showTok x f t old new - showPrim x (FP f (Binary old new)) = showBinary x f old new - showPrim x (DP d AddDir) = showAddDir x d - showPrim x (DP d RmDir) = showRmDir x d - showPrim x (Move f f') = showMove x f f' +instance ApplyState Prim ~ Tree => PrimShow Prim where + showPrim fmt (FP f AddFile) = showAddFile fmt f + showPrim fmt (FP f RmFile) = showRmFile fmt f + showPrim fmt (FP f (Hunk line old new)) = showHunk fmt f line old new + showPrim fmt (FP f (TokReplace t old new)) = showTok fmt f t old new + showPrim fmt (FP f (Binary old new)) = showBinary fmt f old new + showPrim fmt (DP d AddDir) = showAddDir fmt d + showPrim fmt (DP d RmDir) = showRmDir fmt d + showPrim fmt (Move f f') = showMove fmt f f' showPrim _ (ChangePref p f t) = showChangePref p f t + showPrimCtx fmt (FP f (Hunk line old new)) = showContextHunk fmt (FileHunk f line old new) + showPrimCtx fmt p = return $ showPrim fmt p showAddFile :: FileNameFormat -> FileName -> Doc -showAddFile x f = blueText "addfile" <+> formatFileName x f +showAddFile fmt f = blueText "addfile" <+> formatFileName fmt f showRmFile :: FileNameFormat -> FileName -> Doc -showRmFile x f = blueText "rmfile" <+> formatFileName x f +showRmFile fmt f = blueText "rmfile" <+> formatFileName fmt f showMove :: FileNameFormat -> FileName -> FileName -> Doc -showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x d' +showMove fmt d d' = blueText "move" <+> formatFileName fmt d <+> formatFileName fmt d' showChangePref :: String -> String -> String -> Doc showChangePref p f t = blueText "changepref" <+> text p @@ -122,23 +108,23 @@ $$ userchunk t showAddDir :: FileNameFormat -> FileName -> Doc -showAddDir x d = blueText "adddir" <+> formatFileName x d +showAddDir fmt d = blueText "adddir" <+> formatFileName fmt d showRmDir :: FileNameFormat -> FileName -> Doc -showRmDir x d = blueText "rmdir" <+> formatFileName x d +showRmDir fmt d = blueText "rmdir" <+> formatFileName fmt d showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc -showHunk x f line old new = showFileHunk x (FileHunk f line old new) +showHunk fmt f line old new = showFileHunk fmt (FileHunk f line old new) showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc -showTok x f t o n = blueText "replace" <+> formatFileName x f +showTok fmt f t o n = blueText "replace" <+> formatFileName fmt f <+> text "[" <> userchunk t <> text "]" <+> userchunk o <+> userchunk n showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc -showBinary x f o n = - blueText "binary" <+> formatFileName x f +showBinary fmt f o n = + blueText "binary" <+> formatFileName fmt f $$ invisibleText "oldhex" $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex o) $$ invisibleText "newhex" diff --git a/src/Darcs/Patch/Progress.hs b/src/Darcs/Patch/Progress.hs --- a/src/Darcs/Patch/Progress.hs +++ b/src/Darcs/Patch/Progress.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP, GADTs #-} - module Darcs.Patch.Progress ( progressRL , progressFL 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 @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Patch.Read ( ReadPatch(..), readPatch, readPatchPartial, bracketedFL, peekfor, @@ -26,11 +24,11 @@ import Prelude () import Darcs.Prelude -import Darcs.Util.ByteString ( dropSpace ) +import Darcs.Util.ByteString ( dropSpace, unpackPSFromUTF8, decodeLocale ) import qualified Data.ByteString as B (ByteString, null) import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL ) -import Darcs.Util.Path ( FileName, fp2fn, ps2fn, decodeWhite ) +import Darcs.Util.Path ( FileName, fp2fn, decodeWhite ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) ) import Darcs.Patch.ReadMonads (ParserM, parseStrictly, @@ -42,9 +40,9 @@ import Control.Applicative ( (<|>) ) import Control.Monad ( mzero ) -import qualified Data.ByteString.Char8 as BC ( ByteString, unpack ) - +import qualified Data.ByteString.Char8 as BC ( ByteString, pack ) +-- | This class is used to decode patches from their binary representation. class ReadPatch p where readPatch' :: ParserM m => m (Sealed (p wX)) @@ -116,6 +114,8 @@ , ifnot ] {-# INLINE peekfor #-} +-- See also Darcs.Patch.Show.formatFileName. readFileName :: FileNameFormat -> B.ByteString -> FileName -readFileName OldFormat = ps2fn -readFileName NewFormat = fp2fn . decodeWhite . BC.unpack +readFileName OldFormat = fp2fn . decodeWhite . decodeLocale . BC.pack . unpackPSFromUTF8 +readFileName NewFormat = fp2fn . decodeWhite . decodeLocale +readFileName UserFormat = error "readFileName called with UserFormat" diff --git a/src/Darcs/Patch/Rebase.hs b/src/Darcs/Patch/Rebase.hs --- a/src/Darcs/Patch/Rebase.hs +++ b/src/Darcs/Patch/Rebase.hs @@ -6,6 +6,7 @@ , takeHeadRebaseFL , takeAnyRebase , takeAnyRebaseAndTrailingPatches + , dropAnyRebase ) where import Prelude () @@ -14,7 +15,13 @@ import Darcs.Patch.Named.Wrapped ( WrappedNamed(RebaseP) ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Patch.Rebase.Container ( Suspended(..) ) -import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) +import Darcs.Patch.RepoType + ( RepoType(..) + , RebaseType(..) + , IsRepoType(..) + , SRepoType(..) + , SRebaseType(..) + ) import Darcs.Patch.Set ( PatchSet(..) ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed @@ -77,56 +84,76 @@ -} --- |given the repository contents, get the rebase container patch, and its contents --- The rebase patch can be anywhere in the repository and is returned without being --- commuted to the end. +-- | Given the repository contents, get the rebase container patch, and its +-- contents. The rebase patch can be anywhere in the repository and is returned +-- without being commuted to the end. takeAnyRebase :: PatchSet ('RepoType 'IsRebase) p wA wB -> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p), Sealed2 (Suspended p)) takeAnyRebase (PatchSet _ NilRL) = -- it should never be behind a tag so we can stop now - error "internal error: no suspended patch found" + bug "internal error: no suspended patch found" takeAnyRebase (PatchSet pss (ps :<: p)) | RebaseP _ rs <- hopefully p = (Sealed2 p, Sealed2 rs) | otherwise = takeAnyRebase (PatchSet pss ps) --- |given the repository contents, get the rebase container patch, its contents, and the --- rest of the repository contents. Commutes the patch to the end of the repository --- if necessary. The rebase patch must be at the head of the repository. +-- | Given the repository contents, get the rebase container patch, its +-- contents, and the rest of the repository contents. The rebase patch can be +-- anywhere in the repository and is returned without being commuted to the end. takeAnyRebaseAndTrailingPatches :: PatchSet ('RepoType 'IsRebase) p wA wB - -> FlippedSeal (PatchInfoAnd ('RepoType 'IsRebase) p :> RL (PatchInfoAnd ('RepoType 'IsRebase) p)) wB + -> FlippedSeal (PatchInfoAnd ('RepoType 'IsRebase) p :> + RL (PatchInfoAnd ('RepoType 'IsRebase) p)) wB takeAnyRebaseAndTrailingPatches (PatchSet _ NilRL) = -- it should never be behind a tag so we can stop now - error "internal error: no suspended patch found" + bug "internal error: no suspended patch found" takeAnyRebaseAndTrailingPatches (PatchSet pss (ps :<: p)) | RebaseP _ _ <- hopefully p = FlippedSeal (p :> NilRL) | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet pss ps) of FlippedSeal (r :> ps') -> FlippedSeal (r :> (ps' :<: p)) --- |given the repository contents, get the rebase container patch, its contents, and the --- rest of the repository contents. The rebase patch must be at the head of the repository. +-- | Remove the rebase patch from a 'PatchSet'. +dropAnyRebase :: forall rt p wA wB. IsRepoType rt + => PatchSet rt p wA wB -> PatchSet rt p wA wB +dropAnyRebase ps@(PatchSet tags patches) = + case singletonRepoType::SRepoType rt of + SRepoType SNoRebase -> ps + SRepoType SIsRebase -> PatchSet tags (dropRebaseRL patches) + +-- | Remove the rebase patch from an 'RL' of patches. +dropRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB + -> RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB +dropRebaseRL NilRL = bug "internal error: no suspended patch found" +dropRebaseRL (ps :<: p) + | RebaseP _ _ <- hopefully p = ps + | otherwise = dropRebaseRL ps :<: p + +-- | Given the repository contents, get the rebase container patch, its +-- contents, and the rest of the repository contents. The rebase patch must be +-- at the head of the repository. takeHeadRebase :: PatchSet ('RepoType 'IsRebase) p wA wB -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB, PatchSet ('RepoType 'IsRebase) p wA wB) -takeHeadRebase (PatchSet _ NilRL) = error "internal error: must have a rebase container patch at end of repository" takeHeadRebase (PatchSet pss (ps :<: p)) | RebaseP _ rs <- hopefully p = (p, rs, PatchSet pss ps) - | otherwise = error "internal error: must have a rebase container patch at end of repository" +takeHeadRebase _ = + bug "internal error: must have a rebase container patch at end of repository" +-- | Same as 'takeHeadRebase' but for an 'RL' of patches. takeHeadRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB, RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB) -takeHeadRebaseRL NilRL = error "internal error: must have a suspended patch at end of repository" takeHeadRebaseRL (ps :<: p) | RebaseP _ rs <- hopefully p = (p, rs, ps) - | otherwise = error "internal error: must have a suspended patch at end of repository" +takeHeadRebaseRL _ = + bug "internal error: must have a suspended patch at end of repository" +-- | Same as 'takeHeadRebase' but for an 'FL' of patches. takeHeadRebaseFL :: FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB, FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB) -takeHeadRebaseFL ps = let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c) - +takeHeadRebaseFL ps = + let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c) diff --git a/src/Darcs/Patch/Rebase/Container.hs b/src/Darcs/Patch/Rebase/Container.hs --- a/src/Darcs/Patch/Rebase/Container.hs +++ b/src/Darcs/Patch/Rebase/Container.hs @@ -14,11 +14,12 @@ import Darcs.Patch.Format ( PatchListFormat(..) ) import Darcs.Patch.Invert ( invert ) import Darcs.Patch.Named ( Named ) -import Darcs.Patch.Patchy ( Commute(..), Apply(..), - ShowPatch(..), ReadPatch(..), - PatchInspect(..) - ) -import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..) ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( ShowPatch(..) ) +import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim(..), FromPrim(..) ) import Darcs.Patch.Read ( bracketedFL ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups ) import Darcs.Patch.Rebase.Item ( RebaseItem(..) ) @@ -91,24 +92,18 @@ resolveConflicts _ = [] conflictedEffect _ = [] -instance Apply p => Apply (Suspended p) where +instance Apply (Suspended p) where type ApplyState (Suspended p) = ApplyState p apply _ = return () instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where - showPatch (Items ps) + showPatch f (Items ps) = blueText "rebase" <+> text "0.0" <+> blueText "{" - $$ vcat (mapFL showPatch ps) + $$ vcat (mapFL (showPatch f) ps) $$ blueText "}" instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (Suspended p) where - - showContextPatch s = return $ showPatch s - - description s = showPatch s - summary (Items ps) = summaryFL ps - summaryFL ps = vcat (mapFL summary ps) instance PrimPatchBase p => PrimPatchBase (Suspended p) where @@ -129,13 +124,13 @@ [] -> Nothing xs -> Just (vcat xs) -instance Apply p => Repair (Suspended p) where +instance Repair (Suspended p) where applyAndTryToFix (Items ps) = -- TODO: ideally we would apply ps in a sandbox to check the individual patches -- are consistent with each other. return . fmap (unlines *** Items) $ repairInternal ps -instance Apply p => RepairToFL (Suspended p) where +instance RepairToFL (Suspended p) where applyAndTryToFixFL s = fmap (second $ (:>: NilFL)) <$> applyAndTryToFix s -- Just repair the internals of the patch, without applying it to anything diff --git a/src/Darcs/Patch/Rebase/Fixup.hs b/src/Darcs/Patch/Rebase/Fixup.hs --- a/src/Darcs/Patch/Rebase/Fixup.hs +++ b/src/Darcs/Patch/Rebase/Fixup.hs @@ -20,13 +20,13 @@ import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Named ( Named(..), commuterNamedId, commuterIdNamed ) -import Darcs.Patch.Prim ( PrimPatchBase, PrimOf ) +import Darcs.Patch.Prim ( PrimPatchBase(..), PrimPatch ) import Darcs.Patch.Rebase.Name ( RebaseName(..) , commuteNamedName, commuteNameNamed , commutePrimName, commuteNamePrim ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, (:>)(..), (+>+) ) import Darcs.Patch.Witnesses.Show @@ -37,10 +37,10 @@ -- |A single rebase fixup, needed to ensure that the actual patches -- being stored in the rebase state have the correct context. data RebaseFixup p wX wY where - PrimFixup :: PrimOf p wX wY -> RebaseFixup p wX wY + PrimFixup :: PrimPatch (PrimOf p) => PrimOf p wX wY -> RebaseFixup p wX wY NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY -namedToFixups :: Effect p => Named p wX wY -> FL (RebaseFixup p) wX wY +namedToFixups :: (PrimPatch (PrimOf p), Effect p) => Named p wX wY -> FL (RebaseFixup p) wX wY namedToFixups (NamedP p _ contents) = NameFixup (AddName p) :>: mapFL_FL PrimFixup (effect contents) instance Show2 (PrimOf p) => Show (RebaseFixup p wX wY) where @@ -58,7 +58,7 @@ instance PrimPatchBase p => PrimPatchBase (RebaseFixup p) where type PrimOf (RebaseFixup p) = PrimOf p -instance (PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseFixup p) where +instance (PrimPatchBase p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseFixup p) where type ApplyState (RebaseFixup p) = ApplyState p apply (PrimFixup p) = apply p apply (NameFixup p) = apply p @@ -67,7 +67,7 @@ effect (PrimFixup p) = p :>: NilFL effect (NameFixup p) = effect p -instance MyEq (PrimOf p) => MyEq (RebaseFixup p) where +instance Eq2 (PrimOf p) => Eq2 (RebaseFixup p) where PrimFixup p1 `unsafeCompare` PrimFixup p2 = p1 `unsafeCompare` p2 PrimFixup _ `unsafeCompare` _ = False _ `unsafeCompare` PrimFixup _ = False diff --git a/src/Darcs/Patch/Rebase/Item.hs b/src/Darcs/Patch/Rebase/Item.hs --- a/src/Darcs/Patch/Rebase/Item.hs +++ b/src/Darcs/Patch/Rebase/Item.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Rebase.Item ( RebaseItem(..) , simplifyPush, simplifyPushes @@ -14,11 +14,14 @@ import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat(..) ) import Darcs.Patch.Named ( Named(..), commuterIdNamed ) -import Darcs.Patch.Patchy ( Invert(..), Commute(..), Apply(..) - , ShowPatch(..), ReadPatch(..) - , PatchInspect(..) - ) -import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( ShowPatch(..) ) +import Darcs.Patch.Prim + ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) @@ -27,6 +30,7 @@ ) import Darcs.Patch.Repair ( Check(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Patch.Summary ( plainSummaryPrim ) import Darcs.Patch.ReadMonads ( ParserM, lexString ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered @@ -43,8 +47,6 @@ import qualified Data.ByteString as B ( ByteString ) import qualified Data.ByteString.Char8 as BC ( pack ) -#include "impossible.h" - -- |A single item in the rebase state consists of either -- a patch that is being edited, or a fixup that adjusts -- the context so that a subsequent patch that is being edited @@ -145,17 +147,16 @@ simplifyPushes _ NilFL ps = Sealed ps simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps) - instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where - showPatch (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch p $$ blueText ")" - showPatch (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch p $$ blueText ")" - showPatch (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch p $$ blueText ")" + showPatch f (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch f p $$ blueText ")" + showPatch f (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch f p $$ blueText ")" where + showPatch f (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")" instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (RebaseItem p) where summary (ToEdit p) = summary p - summary (Fixup (PrimFixup p)) = summary p + summary (Fixup (PrimFixup p)) = plainSummaryPrim p summary (Fixup (NameFixup n)) = summary n summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts diff --git a/src/Darcs/Patch/Rebase/Name.hs b/src/Darcs/Patch/Rebase/Name.hs --- a/src/Darcs/Patch/Rebase/Name.hs +++ b/src/Darcs/Patch/Rebase/Name.hs @@ -2,7 +2,6 @@ -- -- BSD3 -{-# LANGUAGE CPP #-} module Darcs.Patch.Rebase.Name ( RebaseName(..) , commuteNamePrim, commutePrimName @@ -18,15 +17,16 @@ import Darcs.Patch.Info ( PatchInfo, isInverted, showPatchInfo, readPatchInfo ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Named ( Named(..) ) -import Darcs.Patch.Patchy - ( Invert(..), Commute(..), Patchy, Apply(..) - , ShowPatch(..), ReadPatch(..) - ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( ShowPatch(..) ) import Darcs.Patch.Permutations ( inverseCommuter ) -import Darcs.Patch.Prim ( PrimPatchBase, PrimOf ) +import Darcs.Patch.Prim ( PrimPatchBase(..) ) import Darcs.Patch.ReadMonads ( lexString ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Show @@ -40,8 +40,6 @@ import Control.Applicative ( (<|>) ) import qualified Data.ByteString.Char8 as BC ( pack ) -#include "impossible.h" - -- Note: in principle this is a general concept not limited to -- rebase, and we might be able to generalise this type and -- refactor named patches to use it too. @@ -63,9 +61,9 @@ showDict2 = ShowDictClass instance ShowPatchBasic (RebaseName p) where - showPatch (AddName n) = blueText "addname" $$ showPatchInfo n - showPatch (DelName n) = blueText "delname" $$ showPatchInfo n - showPatch (Rename old new) = blueText "rename" $$ showPatchInfo old $$ showPatchInfo new + showPatch f (AddName n) = blueText "addname" $$ showPatchInfo f n + showPatch f (DelName n) = blueText "delname" $$ showPatchInfo f n + showPatch f (Rename old new) = blueText "rename" $$ showPatchInfo f old $$ showPatchInfo f new instance ShowPatch (RebaseName p) where summary _ = empty -- TODO improve this? @@ -130,19 +128,17 @@ listTouchedFiles _ = [] hunkMatches _ _ = False -instance Apply p => Apply (RebaseName p) where +instance Apply (RebaseName p) where type ApplyState (RebaseName p) = ApplyState p apply _ = return () -instance Apply p => Patchy (RebaseName p) - instance PrimPatchBase p => PrimPatchBase (RebaseName p) where type PrimOf (RebaseName p) = PrimOf p instance Effect (RebaseName p) where effect _ = unsafeCoerceP NilFL -instance MyEq (RebaseName p) where +instance Eq2 (RebaseName p) where AddName n1 `unsafeCompare` AddName n2 = n1 == n2 AddName _ `unsafeCompare` _ = False _ `unsafeCompare` AddName _ = False @@ -158,12 +154,12 @@ -- |Commute a name patch and a primitive patch. They trivially -- commute so this just involves changing the witnesses. -commuteNamePrim :: PrimPatchBase p => (RebaseName p :> PrimOf p) wX wY -> (PrimOf p :> RebaseName p) wX wY +commuteNamePrim :: (RebaseName p :> PrimOf p) wX wY -> (PrimOf p :> RebaseName p) wX wY commuteNamePrim (n :> f) = unsafeCoerceP f :> unsafeCoerceP n -- |Commute a primitive patch and a name patch. They trivially -- commute so this just involves changing the witnesses. -commutePrimName :: PrimPatchBase p => (PrimOf p :> RebaseName p) wX wY -> (RebaseName p :> PrimOf p) wX wY +commutePrimName :: (PrimOf p :> RebaseName p) wX wY -> (RebaseName p :> PrimOf p) wX wY commutePrimName (f :> n) = unsafeCoerceP n :> unsafeCoerceP f -- |Commute a name patch and a named patch. In most cases this is diff --git a/src/Darcs/Patch/Rebase/Viewing.hs b/src/Darcs/Patch/Rebase/Viewing.hs --- a/src/Darcs/Patch/Rebase/Viewing.hs +++ b/src/Darcs/Patch/Rebase/Viewing.hs @@ -1,7 +1,7 @@ -- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 -{-# LANGUAGE CPP, GADTs, UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Rebase.Viewing ( RebaseSelect(..) , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect @@ -44,12 +44,14 @@ ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) -import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..), - ShowPatch(..), ReadPatch(..), - PatchInspect(..) - ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( ShowPatch(..) ) import Darcs.Patch.Prim - ( PrimPatch, PrimPatchBase, PrimOf, FromPrim(..), FromPrims(..) + ( PrimPatch, PrimPatchBase(..), FromPrim(..), FromPrims(..) ) import Darcs.Patch.Rebase.Container ( Suspended(..) ) import Darcs.Patch.Rebase.Fixup @@ -60,7 +62,7 @@ import Darcs.Patch.Rebase.Item ( RebaseItem(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) ) import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..), ShowContextPatch(..) ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered @@ -77,8 +79,6 @@ import Data.List ( nub, (\\) ) import Data.Maybe ( fromMaybe ) -#include "impossible.h" - -- |Encapsulate a single patch in the rebase state together with its fixups. -- Used during interactive selection to make sure that each item presented -- to the user corresponds to a patch. @@ -142,14 +142,6 @@ instance PrimPatchBase p => PrimPatchBase (RebaseSelect p) where type PrimOf (RebaseSelect p) = PrimOf p -instance (PrimPatchBase p, PatchListFormat p, Conflict p, FromPrim p, Effect p, CommuteNoConflicts p, IsHunk p, Patchy p, ApplyState p ~ ApplyState (PrimOf p)) - => Patchy (RebaseSelect p) - -instance ( PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p) - , Invert p - ) - => Patchy (RebaseChange p) - instance PatchDebug p => PatchDebug (RebaseSelect p) instance PatchDebug p => PatchDebug (RebaseChange p) @@ -168,7 +160,7 @@ apply (RCFwd fixups contents) = apply fixups >> apply contents apply (RCRev fixups contents) = apply (invert contents) >> apply (invertFL fixups) -instance (PrimPatchBase p, FromPrim p, Conflict p, CommuteNoConflicts p, Invert p) => Conflict (RebaseSelect p) where +instance (PrimPatchBase p, Conflict p, CommuteNoConflicts p, Invert p) => Conflict (RebaseSelect p) where resolveConflicts (RSFwd _ toedit) = resolveConflicts toedit resolveConflicts (RSRev{}) = impossible @@ -227,14 +219,19 @@ invertRL . reverseFL . effect $ RCFwd fixups changes instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseSelect p) where - showPatch (RSFwd fixups toedit) = - showPatch (Items (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL)) - showPatch (RSRev {}) = impossible + showPatch f (RSFwd fixups toedit) = + showPatch f (Items (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL)) + showPatch _ (RSRev {}) = impossible -instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) +-- TODO this is a dummy instance that does not actually show context +instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowContextPatch (RebaseSelect p) where + showContextPatch f p = return $ showPatch f p + +instance (PrimPatchBase p, ShowPatchBasic p) => ShowPatchBasic (RebaseChange p) where - showPatch (RCFwd fixups contents) = - vcat (mapFL showPatch contents) $$ + showPatch ForStorage _ = impossible + showPatch ForDisplay (RCFwd fixups contents) = + vcat (mapFL (showPatch ForDisplay) contents) $$ (if nullFL fixups then empty else @@ -244,9 +241,9 @@ vcat (mapRL showFixup (invertFL fixups)) ) where - showFixup (PrimFixup p) = showPatch p - showFixup (NameFixup n) = showPatch n - showPatch (RCRev {}) = impossible + showFixup (PrimFixup p) = showPatch ForDisplay p + showFixup (NameFixup n) = showPatch ForDisplay n + showPatch _ (RCRev {}) = impossible instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (RebaseSelect p) where @@ -267,8 +264,14 @@ summary = plainSummary summaryFL = plainSummary +-- TODO this is a dummy instance that does not actually show context +instance + ( PrimPatchBase p, ShowPatchBasic p) + => ShowContextPatch (RebaseChange p) where -instance ReadPatch p => ReadPatch (RebaseSelect p) where + showContextPatch f p = return $ showPatch f p + +instance ReadPatch (RebaseSelect p) where readPatch' = error "can't read RebaseSelect patches" instance ReadPatch (RebaseChange p) where @@ -320,7 +323,7 @@ type PrimOf (RebaseChange p) = PrimOf p -instance Invert p => Invert (RebaseSelect p) where +instance Invert (RebaseSelect p) where invert (RSFwd fixups edit) = RSRev fixups edit invert (RSRev fixups edit) = RSFwd fixups edit @@ -328,7 +331,7 @@ invert (RCFwd fixups contents) = RCRev fixups contents invert (RCRev fixups contents) = RCFwd fixups contents -instance (PrimPatchBase p, Commute p, MyEq p) => MyEq (RebaseSelect p) where +instance (PrimPatchBase p, Commute p, Eq2 p) => Eq2 (RebaseSelect p) where RSFwd fixups1 edit1 =\/= RSFwd fixups2 edit2 | IsEq <- fixups1 =\/= fixups2, IsEq <- edit1 =\/= edit2 = IsEq RSRev fixups1 edit1 =\/= RSRev fixups2 edit2 @@ -460,7 +463,7 @@ let newdeps = map (\dep -> if new == dep then old else dep) deps in WithDroppedDeps (NamedP pn newdeps (unsafeCoerceP body)) ddeps :> Rename old new -forceCommutePrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) +forceCommutePrim :: (Merge p, Invert p, Effect p, FromPrim p) => (PrimOf p :> WDDNamed p) wX wY -> (WDDNamed p :> FL (PrimOf p)) wX wY forceCommutePrim (p :> q) = @@ -468,7 +471,7 @@ q' :/\: invp' -> q' :> effect (invert invp') -forceCommutesPrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) +forceCommutesPrim :: (Merge p, Invert p, Effect p, FromPrim p) => (PrimOf p :> FL (WDDNamed p)) wX wY -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY forceCommutesPrim (p :> NilFL) = NilFL :> (p :>: NilFL) @@ -477,7 +480,7 @@ q' :> p' -> case forceCommutessPrim ( p' :> qs) of qs' :> p'' -> (q' :>: qs') :> p'' -forceCommutessPrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) +forceCommutessPrim :: (Merge p, Invert p, Effect p, FromPrim p) => (FL (PrimOf p) :> FL (WDDNamed p)) wX wY -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY forceCommutessPrim (NilFL :> qs) = qs :> NilFL @@ -487,7 +490,7 @@ case forceCommutesPrim (p :> qs') of qs'' :> p' -> qs'' :> (p' +>+ ps') -forceCommutess :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) +forceCommutess :: (Merge p, Invert p, Effect p, FromPrim p) => (FL (RebaseFixup p) :> FL (WDDNamed p)) wX wY -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY forceCommutess (NilFL :> qs) = qs :> NilFL @@ -506,7 +509,7 @@ -- the main repository, together with residual fixups that need -- to go back into the rebase state (unless the rebase is now finished). -- Any fixups associated with the patch will turn into conflicts. -extractRebaseSelect :: (Commute p, Merge p, Invert p, Effect p, FromPrim p, PrimPatchBase p) +extractRebaseSelect :: (Merge p, Invert p, Effect p, FromPrim p, PrimPatchBase p) => FL (RebaseSelect p) wX wY -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY extractRebaseSelect NilFL = NilFL :> NilFL @@ -522,7 +525,7 @@ -- signature to be compatible with extractRebaseSelect -- | Like 'extractRebaseSelect', but any fixups are "reified" into a separate patch. reifyRebaseSelect :: forall p wX wY - . (PrimPatchBase p, Commute p, Merge p, Invert p, Effect p, FromPrim p) + . (PrimPatchBase p, FromPrim p) => FL (RebaseSelect p) wX wY -> IO ((FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY) reifyRebaseSelect rs = do res <- concatFL <$> mapFL_FL_M reifyOne rs @@ -553,7 +556,7 @@ instance CommuteNoConflicts (RebaseChange p) where commuteNoConflicts _ = impossible -instance IsHunk p => IsHunk (RebaseChange p) where +instance IsHunk (RebaseChange p) where -- RebaseChange is a compound patch, so it doesn't really make sense to -- ask whether it's a hunk. TODO: get rid of the need for this. isHunk _ = Nothing diff --git a/src/Darcs/Patch/RepoPatch.hs b/src/Darcs/Patch/RepoPatch.hs --- a/src/Darcs/Patch/RepoPatch.hs +++ b/src/Darcs/Patch/RepoPatch.hs @@ -1,25 +1,27 @@ module Darcs.Patch.RepoPatch ( RepoPatch ) where +import Darcs.Patch.Annotate ( Annotate ) +import Darcs.Patch.Apply ( Apply, ApplyState ) +import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect ) +import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Merge ( Merge ) -import Darcs.Patch.Patchy ( Patchy ) -import Darcs.Patch.Patchy.Instances () import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Repair ( RepairToFL, Check ) -import Darcs.Patch.Show ( ShowPatch ) +import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) -class (Patchy p, Merge p, Effect p, IsHunk p, - PatchInspect p, ReadPatch p, ShowPatch p, +class (Apply p, Commute p, Invert p, Merge p, Effect p, IsHunk p, + PatchInspect p, ReadPatch p, ShowPatch p, ShowContextPatch p, FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, - PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p), - Matchable p + PrimPatchBase p, IsHunk (PrimOf p), + Matchable p, Annotate p, ApplyState p ~ ApplyState (PrimOf p) ) => RepoPatch p 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 @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, EmptyDataDecls, StandaloneDeriving #-} +{-# LANGUAGE EmptyDataDecls, StandaloneDeriving #-} module Darcs.Patch.Set ( PatchSet(..) @@ -26,8 +26,8 @@ , tags , emptyPatchSet , appendPSFL - , newset2RL - , newset2FL + , patchSet2RL + , patchSet2FL , patchSetfMap ) where @@ -89,18 +89,18 @@ showDict2 = ShowDictClass --- |'newset2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of +-- |'patchSet2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of -- patches. -newset2RL :: PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX -newset2RL (PatchSet ts ps) = concatRL (mapRL_RL ts2rl ts) +<+ ps +patchSet2RL :: PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX +patchSet2RL (PatchSet ts ps) = concatRL (mapRL_RL ts2rl ts) +<+ ps where ts2rl :: Tagged rt p wY wZ -> RL (PatchInfoAnd rt p) wY wZ ts2rl (Tagged t _ ps2) = ps2 :<: t --- |'newset2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of +-- |'patchSet2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of -- patches. -newset2FL :: PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX -newset2FL = reverseRL . newset2RL +patchSet2FL :: PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX +patchSet2FL = reverseRL . patchSet2RL -- |'appendPSFL' takes a 'PatchSet' and a 'FL' of patches that "follow" the -- PatchSet, and concatenates the patches into the PatchSet. @@ -128,4 +128,4 @@ taggedTagInfo (Tagged t _ _) = info t patchSetfMap:: (forall wW wZ . PatchInfoAnd rt p wW wZ -> IO a) -> PatchSet rt p wW' wZ' -> IO [a] -patchSetfMap f = sequence . mapRL f . newset2RL +patchSetfMap f = sequence . mapRL f . patchSet2RL diff --git a/src/Darcs/Patch/Show.hs b/src/Darcs/Patch/Show.hs --- a/src/Darcs/Patch/Show.hs +++ b/src/Darcs/Patch/Show.hs @@ -15,59 +15,59 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Patch.Show ( ShowPatchBasic(..) + , displayPatch + , ShowPatchFor(..) , ShowPatch(..) - , showNamedPrefix + , ShowContextPatch(..) , formatFileName ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( pi ) +import qualified Data.ByteString.Char8 as BC ( unpack ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Format ( FileNameFormat(..) ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfo ) -import Darcs.Patch.Witnesses.Ordered ( FL ) +import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) +import Darcs.Util.ByteString ( packStringToUTF8, encodeLocale ) import Darcs.Util.English ( plural, Noun(Noun) ) -import Darcs.Util.Path ( FileName, fn2ps, encodeWhite, fn2fp ) -import Darcs.Util.Printer ( Doc, vcat, blueText, ($$), text, packedString ) +import Darcs.Util.Path ( FileName, encodeWhite, fn2fp ) +import Darcs.Util.Printer ( Doc, vcat, text, packedString ) -showNamedPrefix :: PatchInfo -> [PatchInfo] -> Doc -showNamedPrefix n d = showPatchInfo n - $$ blueText "<" - $$ vcat (map showPatchInfo d) - $$ blueText ">" +data ShowPatchFor = ForDisplay | ForStorage -class ShowPatchBasic p where - showPatch :: p wX wY -> Doc +displayPatch :: ShowPatchBasic p => p wX wY -> Doc +displayPatch p = showPatch ForDisplay p -class ShowPatchBasic p => ShowPatch p where - showNicely :: p wX wY -> Doc - showNicely = showPatch +class ShowPatchBasic p where + showPatch :: ShowPatchFor -> p wX wY -> Doc +class ShowPatchBasic p => ShowContextPatch p where -- | showContextPatch is used to add context to a patch, as diff -- -u does. Thus, it differs from showPatch only for hunks. It is -- used for instance before putting it into a bundle. As this -- unified context is not included in patch representation, this -- requires access to the tree. - showContextPatch :: (Monad m, - ApplyMonad (ApplyState p) m) - => p wX wY -> m Doc - showContextPatch p = return $ showPatch p + showContextPatch :: (ApplyMonad (ApplyState p) m) + => ShowPatchFor -> p wX wY -> m Doc +-- This class is used only for user interaction, not for storage +class ShowPatchBasic p => ShowPatch p where + showNicely :: p wX wY -> Doc + showNicely = showPatch ForDisplay + description :: p wX wY -> Doc - description = showPatch + description = showPatch ForDisplay summary :: p wX wY -> Doc summaryFL :: FL p wX wY -> Doc + summaryFL = vcat . mapFL summary thing :: p wX wY -> String thing _ = "patch" @@ -75,6 +75,19 @@ things :: p wX wY -> String things x = plural (Noun $ thing x) "" +-- | Format a 'FileName' to a 'Doc' according to the given 'FileNameFormat'. +-- +-- NOTE: This is not only used for display but also to format patch files. This is +-- why we have to do the white space encoding here. +-- See 'Darcs.Repository.Hashed.writePatchIfNecessary'. +-- +-- Besides white space encoding, for 'NewFormat' we just pack it into a 'Doc'. For +-- 'OldFormat' we must emulate the non-standard darcs-1 encoding of file paths: it +-- is an UTF8 encoding of the raw byte stream, interpreted as code points. +-- +-- See also 'Darcs.Patch.Show.readFileName'. formatFileName :: FileNameFormat -> FileName -> Doc -formatFileName OldFormat = packedString . fn2ps +formatFileName OldFormat = packedString . packStringToUTF8 . BC.unpack . + encodeLocale . encodeWhite . fn2fp formatFileName NewFormat = text . encodeWhite . fn2fp +formatFileName UserFormat = text . fn2fp diff --git a/src/Darcs/Patch/Split.hs b/src/Darcs/Patch/Split.hs --- a/src/Darcs/Patch/Split.hs +++ b/src/Darcs/Patch/Split.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RankNTypes, GADTs, ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Copyright (C) 2009 Ganesh Sittampalam -- @@ -22,7 +22,13 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -module Darcs.Patch.Split ( Splitter(..), rawSplitter, noSplitter, primSplitter, reversePrimSplitter ) where +module Darcs.Patch.Split + ( Splitter(..) + , rawSplitter + , noSplitter + , primSplitter + , reversePrimSplitter + ) where import Prelude () import Darcs.Prelude @@ -33,14 +39,16 @@ import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) -import Darcs.Patch.Patchy ( ReadPatch(..), showPatch, ShowPatch(..), Invert(..) ) -import Darcs.Patch.Invert (invertFL) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( showPatch, ShowPatch(..) ) +import Darcs.Patch.Invert( Invert(..), invertFL ) import Darcs.Patch.Prim ( PrimPatch, canonize, canonizeFL, primFromHunk ) import Darcs.Patch.ReadMonads ( parseStrictly ) import Darcs.Patch.Read () +import Darcs.Patch.Show ( ShowPatchFor(ForDisplay) ) import Darcs.Patch.Viewing () -import Darcs.Util.Printer ( renderPS, RenderMode(..) ) +import Darcs.Util.Printer ( renderPS ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import qualified Data.ByteString as B @@ -63,23 +71,20 @@ -- 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 wX wY . p wX wY - -> Maybe (B.ByteString, - B.ByteString -> Maybe (FL p wX wY)) - -- 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 wX wY . FL p wX wY - -> FL p wX wY - } +data Splitter p = Splitter + { applySplitter :: forall wX wY. p wX wY + -> Maybe (B.ByteString, B.ByteString -> Maybe (FL p wX wY)) + -- 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 wX wY. FL p wX wY -> FL p wX wY + } {- Some facts that probably ought to be true about splitters: should make some QC properties @@ -94,22 +99,21 @@ withEditedHead :: Invert p => p wX wY -> p wX wZ -> FL p wX wY 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. +-- |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 Standard . showPatch $ p, - \str -> case parseStrictly readPatch' str of - Just (Sealed res, _) -> Just (withEditedHead p res) - _ -> Nothing - ) - ,canonizeSplit = id - } +rawSplitter = Splitter + { applySplitter = \p -> + Just (renderPS . showPatch ForDisplay $ p + ,\str -> case parseStrictly readPatch' str of + 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. +-- |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 } @@ -118,16 +122,17 @@ -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY)) doPrimSplit da = doPrimSplit_ da True explanation where - explanation = map BC.pack - [ "Interactive hunk edit:" - , " - Edit the section marked 'AFTER'" - , " - Arbitrary editing is supported" - , " - This will only affect the patch, not your working tree" - , " - Hints:" - , " - To split added text, delete the part you want to postpone" - , " - To split removed text, copy back the part you want to retain" - , "" - ] + explanation = + map BC.pack + [ "Interactive hunk edit:" + , " - Edit the section marked 'AFTER'" + , " - Arbitrary editing is supported" + , " - This will only affect the patch, not your working tree" + , " - Hints:" + , " - To split added text, delete the part you want to postpone" + , " - To split removed text, copy back the part you want to retain" + , "" + ] doPrimSplit_ :: (PrimPatch prim, IsHunk p) => D.DiffAlgorithm @@ -161,9 +166,8 @@ (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. +-- |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 :: PrimPatch p => D.DiffAlgorithm -> Splitter p primSplitter da = Splitter { applySplitter = doPrimSplit da , canonizeSplit = canonizeFL da } @@ -178,16 +182,17 @@ return (text, parser') where reverseExplanation = - map BC.pack [ "Interactive hunk edit:" - , " - Edit the section marked 'AFTER' (representing the state to which you'll revert)" - , " - Arbitrary editing is supported" - , " - Your working tree will be returned to the 'AFTER' state" - , " - Do not touch the 'BEFORE' section" - , " - Hints:" - , " - To revert only a part of a text addition, delete the part you want to get rid of" - , " - To revert only a part of a removal, copy back the part you want to retain" - , "" - ] + map BC.pack + [ "Interactive hunk edit:" + , " - Edit the section marked 'AFTER' (representing the state to which you'll revert)" + , " - Arbitrary editing is supported" + , " - Your working tree will be returned to the 'AFTER' state" + , " - Do not touch the 'BEFORE' section" + , " - Hints:" + , " - To revert only a part of a text addition, delete the part you want to get rid of" + , " - To revert only a part of a removal, copy back the part you want to retain" + , "" + ] reversePrimSplitter :: PrimPatch prim => D.DiffAlgorithm -> Splitter prim reversePrimSplitter da = Splitter { applySplitter = doReversePrimSplit da diff --git a/src/Darcs/Patch/Summary.hs b/src/Darcs/Patch/Summary.hs --- a/src/Darcs/Patch/Summary.hs +++ b/src/Darcs/Patch/Summary.hs @@ -6,10 +6,11 @@ import Prelude () import Darcs.Prelude -import Darcs.Util.Path ( fn2fp, FileName ) +import Darcs.Util.Path ( fn2fp ) import Darcs.Patch.Conflict ( Conflict(..), IsConflictedPrim(IsC), ConflictState(..) ) -import Darcs.Patch.Effect ( Effect ) +import Darcs.Patch.Format ( FileNameFormat(UserFormat) ) import Darcs.Patch.Prim.Class ( PrimDetails(..), PrimPatchBase ) +import Darcs.Patch.Show ( formatFileName ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) @@ -22,18 +23,14 @@ plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc plainSummaryPrim = vcat . map (summChunkToLine False) . genSummary . (:[]) . IsC Okay -plainSummaryPrims :: PrimDetails prim => Bool -> [FileName] -> FL prim wX wY -> Doc -plainSummaryPrims machineReadable conflicting = - vcat . map (summChunkToLine machineReadable . markConflict) . genSummary . mapFL (IsC Okay) - where - markConflict (SummChunk sf@(SummFile _ sfFn _ _ _) _) - | sfFn `elem` conflicting = SummChunk sf Conflicted - markConflict sc = sc +plainSummaryPrims :: PrimDetails prim => Bool -> FL prim wX wY -> Doc +plainSummaryPrims machineReadable = + vcat . map (summChunkToLine machineReadable) . genSummary . mapFL (IsC Okay) -plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e wX wY -> Doc +plainSummary :: (Conflict e, PrimPatchBase e) => e wX wY -> Doc plainSummary = vcat . map (summChunkToLine False) . genSummary . conflictedEffect -xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p wX wY -> Doc +xmlSummary :: (Conflict p, PrimPatchBase p) => p wX wY -> Doc xmlSummary p = text "" $$ (vcat . map summChunkToXML . genSummary . conflictedEffect $ p) $$ text "" @@ -62,7 +59,7 @@ 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 + Just d3 -> combine $ SummChunk d3 (combineConflictStates c1 c2) : ss combine (x:ss) = x : combine ss combine [] = [] -- @@ -71,11 +68,11 @@ 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 + combineConflictStates Conflicted _ = Conflicted + combineConflictStates _ Conflicted = Conflicted + combineConflictStates Duplicated _ = Duplicated + combineConflictStates _ Duplicated = Duplicated + combineConflictStates 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 @@ -101,7 +98,7 @@ 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 + xfn = escapeXML . dropDotSlash . fn2fp -- xad 0 = empty xad a = text "" @@ -113,18 +110,18 @@ summChunkToLine :: Bool -> SummChunk -> Doc summChunkToLine machineReadable (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) + SummRmDir f -> lconf c "R" $ formatFileName UserFormat f <> text "/" + SummAddDir f -> lconf c "A" $ formatFileName UserFormat f <> text "/" + SummFile SummRm f _ _ _ -> lconf c "R" $ formatFileName UserFormat f + SummFile SummAdd f _ _ _ -> lconf c "A" $ formatFileName UserFormat f SummFile SummMod f r a x - | machineReadable -> lconf c "M" $ text (fn2fp f) - | otherwise -> lconf c "M" $ text (fn2fp f) <+> rm r <+> ad a <+> rp x + | machineReadable -> lconf c "M" $ formatFileName UserFormat f + | otherwise -> lconf c "M" $ formatFileName UserFormat f <+> rm r <+> ad a <+> rp x SummMv f1 f2 - | machineReadable -> text "F " <> text (fn2fp f1) - $$ text "T " <> text (fn2fp f2) - | otherwise -> text " " <> text (fn2fp f1) - <> text " -> " <> text (fn2fp f2) + | machineReadable -> text "F " <> formatFileName UserFormat f1 + $$ text "T " <> formatFileName UserFormat f2 + | otherwise -> text " " <> formatFileName UserFormat f1 + <> text " -> " <> formatFileName UserFormat f2 SummNone -> case c of Okay -> empty _ -> lconf c "" empty diff --git a/src/Darcs/Patch/TokenReplace.hs b/src/Darcs/Patch/TokenReplace.hs --- a/src/Darcs/Patch/TokenReplace.hs +++ b/src/Darcs/Patch/TokenReplace.hs @@ -1,8 +1,7 @@ module Darcs.Patch.TokenReplace - ( - tryTokInternal + ( tryTokReplace , forceTokReplace - , breakOutToken + , annotateReplace , breakToTokens , defaultToks ) where @@ -12,61 +11,91 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Data.Maybe ( isNothing ) -import Darcs.Util.ByteString ( substrPS, linesPS, unlinesPS ) import Darcs.Patch.RegChars ( regChars ) --- | breakOutToken takes a String of token chars and an input ByteString, and --- returns the ByteString triple of (beforeToken, token, afterToken). +-- | @breakOutToken tokChars input@ splits the @input@ 'ByteString' into +-- @'Just' (before, token, after)@, where @token@ is the first non-empty +-- substring consisting only of 'Char's in @tokChars@, or 'Nothing' if no token +-- was found. The 'Char's in @tokChars@ should not have code points larger than +-- 255 (0xff). breakOutToken :: String -> BC.ByteString - -> (BC.ByteString, BC.ByteString, BC.ByteString) -breakOutToken tokChars input = - let isTokChar = regChars tokChars - (before, tokAndRest) = BC.break isTokChar input - (tok, remaining) = BC.break (not . isTokChar) tokAndRest in - (before, tok, remaining) - --- | tryTokInternal takes a String of token chars, an oldToken ByteString, a --- newToken ByteString and returns the list of token-delimited ByteStrings, --- with any tokens matching oldToken being replaced by newToken. If newToken is --- already in the input, we return Nothing. -tryTokInternal :: String -> B.ByteString -> B.ByteString -> B.ByteString - -> Maybe [B.ByteString] -tryTokInternal _ oldToken newToken input - | isNothing (substrPS oldToken input) && - isNothing (substrPS newToken input) = Just [ input ] -tryTokInternal tokChars oldToken newToken input = - let (before, tok, remaining) = breakOutToken tokChars input in - case tryTokInternal tokChars oldToken newToken remaining of - Nothing -> Nothing - Just rest | tok == oldToken -> Just $ before : newToken : rest - | tok == newToken -> Nothing - | otherwise -> Just $ before : tok : rest - --- | forceTokReplace replaces all occurrences of the old token with the new --- token, throughout the input ByteString. -forceTokReplace :: String -> B.ByteString -> B.ByteString -> B.ByteString - -> B.ByteString -forceTokReplace tokChars oldToken newToken = forceReplaceLines + -> Maybe (BC.ByteString, BC.ByteString, BC.ByteString) +breakOutToken tokChars input + | not (B.null tok) = Just (before, tok, remaining) + | otherwise = Nothing where - forceReplaceLines = unlinesPS . map forceReplace . linesPS - breakOutAllTokens input | B.null input = [] - breakOutAllTokens input = - let (before, tok, remaining) = breakOutToken tokChars input in - before : tok : breakOutAllTokens remaining + isTokChar = regChars tokChars + (before, tokAndRest) = BC.break isTokChar input + (tok, remaining) = BC.break (not . isTokChar) tokAndRest - forceReplace = B.concat . map replaceMatchingToken . breakOutAllTokens +-- | @tryTokReplace tokChars old new input@ tries to find the token @old@ and +-- replace it with the token @new@ everywhere in the @input@, returning 'Just' +-- the modified @input@, unless the token @new@ is already in the @input@ in +-- which case 'Nothing' is returned. A token is a sequence of bytes that match +-- the class defined by @tokChars@. This function is supposed to work +-- efficiently with large @input@s i.e. whole files. +tryTokReplace :: String -> B.ByteString -> B.ByteString + -> B.ByteString -> Maybe B.ByteString +tryTokReplace tokChars old new + | B.null old = bug "tryTokInternal called with empty old token" + | BC.any (not . isTokChar) old = bug "tryTokInternal called with old non-token" + | BC.any (not . isTokChar) new = bug "tryTokInternal called with new non-token" + | otherwise = fmap B.concat . loop 0 + where + isTokChar = regChars tokChars + loop !from input = + case BC.findIndex isTokChar (B.drop from input) of + Nothing -> Just [input] + Just start -> + case BC.span isTokChar (B.drop (from + start) input) of + (tok, rest) + | tok == old -> + (B.take (from + start) input :).(new :) <$> loop 0 rest + | tok == new -> Nothing + | otherwise -> + loop (from + start + B.length tok) input - replaceMatchingToken input | input == oldToken = newToken - | otherwise = input +-- | @forceTokReplace tokChars old new input@ replaces all occurrences of +-- the @old@ token with the @new@ one, throughout the @input@. +forceTokReplace :: String -> B.ByteString -> B.ByteString + -> B.ByteString -> B.ByteString +forceTokReplace tokChars old new + | B.null old = bug "tryTokInternal called with empty old token" + | BC.any (not . isTokChar) old = bug "tryTokInternal called with old non-token" + | BC.any (not . isTokChar) new = bug "tryTokInternal called with new non-token" + | otherwise = B.concat . loop 0 + where + isTokChar = regChars tokChars + len = B.length old + loop !from input = + case B.breakSubstring old (B.drop from input) of + (before, match) + | B.null match -> [input] -- not found + | B.null before || not (isTokChar (BC.last before)) + , B.length match == len || not (isTokChar (BC.index match len)) -> + -- found and is token + B.take (from + B.length before) input : new : + loop 0 (B.drop len match) + | otherwise -> + -- found but not a token + loop (from + B.length before + len) input --- break a single bytestring into tokens +-- | Check if a token replace operation touches the given line. +annotateReplace :: String -> B.ByteString -> B.ByteString -> B.ByteString -> Bool +annotateReplace tokChars old new input = + case breakOutToken tokChars input of + Just (_, tok, remaining) -> + (tok == old || annotateReplace tokChars old new remaining) + Nothing -> False + +-- | Break a 'Bytestring' into tokens, according to 'defaultToks', +-- discarding non-tokens. breakToTokens :: BC.ByteString -> [BC.ByteString] -breakToTokens input | B.null input = [] breakToTokens input = - let (_, tok, remaining) = breakOutToken defaultToks input in - tok : breakToTokens remaining + case breakOutToken defaultToks input of + Nothing -> [] + Just (_, tok, remaining) -> tok : breakToTokens remaining defaultToks :: String defaultToks = "A-Za-z_0-9" 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 @@ -15,98 +15,122 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - -module Darcs.Patch.TouchesFiles ( lookTouch, chooseTouching, choosePreTouching, - selectTouching, - deselectNotTouching, selectNotTouching, - ) where +module Darcs.Patch.TouchesFiles + ( lookTouch + , chooseTouching + , choosePreTouching + , selectTouching + , deselectNotTouching + , selectNotTouching + ) where -import Prelude () import Darcs.Prelude +import Prelude () -import Data.List ( isSuffixOf, nub ) +import Data.List (isSuffixOf, nub) -import Darcs.Patch.Choices ( PatchChoices, Label, LabelledPatch, - patchChoices, label, getChoices, - forceFirsts, forceLasts, lpPatch, - ) -import Darcs.Patch ( Patchy, invert ) -import Darcs.Patch.Apply ( ApplyState, applyToFilePaths, effectOnFilePaths ) -import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) -import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) -import Darcs.Util.Tree( Tree ) +import Darcs.Patch.Apply + (Apply, ApplyState, applyToFilePaths, effectOnFilePaths) +import Darcs.Patch.Choices + (PatchChoices, Label, LabelledPatch, patchChoices, label, + getChoices, forceFirsts, forceLasts, unLabel) +import Darcs.Patch.Commute (Commute) +import Darcs.Patch.Inspect (PatchInspect) +import Darcs.Patch.Invert (invert, Invert) +import Darcs.Patch.Witnesses.Ordered + (FL(..), (:>)(..), mapFL_FL, (+>+)) +import Darcs.Patch.Witnesses.Sealed (Sealed, seal) +import Darcs.Util.Tree (Tree) -labelTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Bool - -> [FilePath] -> FL (LabelledPatch p) wX wY -> [Label] +labelTouching + :: (Apply p, PatchInspect p, ApplyState p ~ Tree) + => Bool -> [FilePath] -> FL (LabelledPatch p) wX wY -> [Label] labelTouching _ _ NilFL = [] labelTouching wantTouching fs (lp :>: lps) = - case lookTouchOnlyEffect fs (lpPatch lp) of - (doesTouch, fs') -> - let rest = labelTouching wantTouching fs' lps - in (if doesTouch == wantTouching then (label lp :) else id) rest + case lookTouchOnlyEffect fs (unLabel lp) of + (doesTouch, fs') -> + let rest = labelTouching wantTouching fs' lps + in (if doesTouch == wantTouching + then (label lp :) + else id) + rest -labelNotTouchingFM :: (PatchInspect p, Patchy p, ApplyState p ~ Tree) - => [FilePath] -> PatchChoices p wX wY -> [Label] -labelNotTouchingFM files pc = case getChoices pc of +labelNotTouchingFM + :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) + => [FilePath] -> PatchChoices p wX wY -> [Label] +labelNotTouchingFM files pc = + case getChoices pc of fc :> mc :> _ -> labelTouching False (map fix files) (fc +>+ mc) -selectTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) - => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY +selectTouching + :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) + => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectTouching Nothing pc = pc selectTouching (Just files) pc = forceFirsts xs pc - where xs = case getChoices pc of - _ :> mc :> lc -> labelTouching True (map fix files) (mc +>+ lc) + where + xs = + case getChoices pc of + _ :> mc :> lc -> labelTouching True (map fix files) (mc +>+ lc) -deselectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) - => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY +deselectNotTouching + :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) + => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY deselectNotTouching Nothing pc = pc -deselectNotTouching (Just files) pc = forceLasts (labelNotTouchingFM files pc) pc +deselectNotTouching (Just files) pc = + forceLasts (labelNotTouchingFM files pc) pc -selectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) - => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY +selectNotTouching + :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) + => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectNotTouching Nothing pc = pc selectNotTouching (Just files) pc = forceFirsts (labelNotTouchingFM files pc) pc fix :: FilePath -> FilePath -fix f | "/" `isSuffixOf` f = fix $ init f +fix f + | "/" `isSuffixOf` f = fix $ init f fix "" = "." fix "." = "." fix f = "./" ++ f -chooseTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) - => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) +chooseTouching + :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) + => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) chooseTouching Nothing p = seal p -chooseTouching files p = case getChoices $ selectTouching files $ patchChoices p of - fc :> _ :> _ -> seal $ mapFL_FL lpPatch fc +chooseTouching files p = + case getChoices $ selectTouching files $ patchChoices p of + fc :> _ :> _ -> seal $ mapFL_FL unLabel fc -choosePreTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) - => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) -choosePreTouching files patch = chooseTouching filesBeforePatch patch where +choosePreTouching + :: (Apply p, Commute p, Invert p, PatchInspect p, ApplyState p ~ Tree) + => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) +choosePreTouching files patch = chooseTouching filesBeforePatch patch + where filesBeforePatch = effectOnFilePaths (invert patch) <$> files -lookTouchOnlyEffect :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => [FilePath] -> p wX wY - -> (Bool, [FilePath]) -lookTouchOnlyEffect fs p = (wasTouched, fs') where +lookTouchOnlyEffect + :: (Apply p, ApplyState p ~ Tree) + => [FilePath] -> p wX wY -> (Bool, [FilePath]) +lookTouchOnlyEffect fs p = (wasTouched, fs') + where (wasTouched, _, fs', _) = lookTouch Nothing fs p - -lookTouch :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)] - -> [FilePath] -> p wX wY - -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)]) +lookTouch + :: (Apply p, ApplyState p ~ Tree) + => Maybe [(FilePath, FilePath)] + -> [FilePath] + -> p wX wY + -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)]) lookTouch renames fs p = (anyTouched, touchedFs, fs', renames') - where - touchedFs = nub . concatMap fsAffectedBy $ affected - fsAffectedBy af = filter (affectedBy af) fs - anyTouched = length touchedFs > 0 - affectedBy :: FilePath -> FilePath -> Bool - touched `affectedBy` f = touched == f - || touched `isSubPathOf` f - || f `isSubPathOf` touched - isSubPathOf :: FilePath -> FilePath -> Bool - path `isSubPathOf` parent = case splitAt (length parent) path of - (path', '/':_) -> path' == parent - _ -> False - (affected, fs', renames') = applyToFilePaths p renames fs + where + touchedFs = nub . concatMap fsAffectedBy $ affected + fsAffectedBy af = filter (affectedBy af) fs + anyTouched = length touchedFs > 0 + affectedBy :: FilePath -> FilePath -> Bool + touched `affectedBy` f = + touched == f || touched `isSubPathOf` f || f `isSubPathOf` touched + isSubPathOf :: FilePath -> FilePath -> Bool + path `isSubPathOf` parent = + case splitAt (length parent) path of + (path', '/':_) -> path' == parent + _ -> False + (affected, fs', renames') = applyToFilePaths p renames fs diff --git a/src/Darcs/Patch/V1.hs b/src/Darcs/Patch/V1.hs --- a/src/Darcs/Patch/V1.hs +++ b/src/Darcs/Patch/V1.hs @@ -1,8 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1 ( RepoPatchV1 ) where +import Darcs.Patch.Annotate ( Annotate ) import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch ) @@ -13,6 +13,5 @@ import Darcs.Patch.V1.Show () import Darcs.Patch.V1.Viewing () -instance PrimPatch prim => Patchy (RepoPatchV1 prim) instance PrimPatch prim => Matchable (RepoPatchV1 prim) -instance PrimPatch prim => RepoPatch (RepoPatchV1 prim) +instance (PrimPatch prim, Annotate prim) => RepoPatch (RepoPatchV1 prim) diff --git a/src/Darcs/Patch/V1/Apply.hs b/src/Darcs/Patch/V1/Apply.hs --- a/src/Darcs/Patch/V1/Apply.hs +++ b/src/Darcs/Patch/V1/Apply.hs @@ -4,6 +4,7 @@ import Prelude () import Darcs.Prelude +import Darcs.Patch.Annotate ( Annotate(..) ) import Darcs.Patch.Apply ( ApplyState, Apply, apply ) import Darcs.Patch.Prim ( PrimPatch, applyPrimFL ) import Darcs.Patch.Repair ( RepairToFL, applyAndTryToFixFL, @@ -12,7 +13,6 @@ import Darcs.Patch.V1.Commute () import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) - import Darcs.Patch.Witnesses.Ordered ( mapFL_FL ) @@ -23,3 +23,6 @@ instance PrimPatch prim => RepairToFL (RepoPatchV1 prim) where applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x applyAndTryToFixFL x = do apply x; return Nothing + +instance (PrimPatch prim, Annotate prim) => Annotate (RepoPatchV1 prim) where + annotate = annotate . effect diff --git a/src/Darcs/Patch/V1/Commute.hs b/src/Darcs/Patch/V1/Commute.hs --- a/src/Darcs/Patch/V1/Commute.hs +++ b/src/Darcs/Patch/V1/Commute.hs @@ -16,9 +16,7 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} - module Darcs.Patch.V1.Commute ( merge, @@ -36,9 +34,12 @@ import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId ) import Darcs.Util.Path ( FileName ) +import Darcs.Util.Printer ( errorDoc ) import Darcs.Patch.Invert ( invertRL ) -import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Patchy ( Commute(..), PatchInspect(..), Invert(..) ) +import Darcs.Patch.Merge ( Merge(..), naturalMerge ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.V1.Core ( RepoPatchV1(..), isMerger, mergerUndo ) @@ -57,11 +58,10 @@ import Darcs.Patch.V1.Show ( showPatch_ ) import Data.List ( nub, nubBy ) import Data.List.Ordered ( nubSort ) -#include "impossible.h" import Darcs.Patch.Witnesses.Sealed ( Sealed(..) , mapSeal, unseal, FlippedSeal(..), mapFlipped , unsafeUnseal, unsafeUnsealFlipped ) -import Darcs.Patch.Witnesses.Eq ( EqCheck(..), MyEq(..) ) +import Darcs.Patch.Witnesses.Eq ( EqCheck(..), Eq2(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart , unsafeCoercePEnd ) @@ -182,7 +182,7 @@ -- "after" @z@), but we need to return both arms. We therefore commute -- @z@ and @y'@, to obtain a @z'@, which applies "after" @y'' == y@. Sealed y' -> case commute (z :> y') of - Nothing -> bugDoc $ text "merge_patches bug" + Nothing -> errorDoc $ text "merge_patches bug" $$ showPatch_ y $$ showPatch_ z $$ showPatch_ y' @@ -272,17 +272,6 @@ qs' :> p'' <- commuteFLId commuter (p' :> qs) return ((q' :>: qs') :> p'') --- | elegantMerge attempts to perform the "intuitive" merge of two patches, --- from a common starting context @wX@. -elegantMerge :: PrimPatch prim - => (RepoPatchV1 prim :\/: RepoPatchV1 prim) wX wY - -> Maybe ((RepoPatchV1 prim :/\: RepoPatchV1 prim) wX wY) -elegantMerge (p1 :\/: p2) = do - p1' :> ip2' <- commute (invert p2 :> p1) - p1o :> _ <- commute (p2 :> p1') - guard $ unsafeCompare p1o p1 -- should be a redundant check - return $ invert ip2' :/\: p1' - {- A note about mergers and type witnesses --------------------------------------- @@ -313,7 +302,7 @@ -- rebuild it? actualMerge :: PrimPatch prim => (RepoPatchV1 prim :\/: RepoPatchV1 prim) wX wY -> Sealed (RepoPatchV1 prim wY) -actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of +actualMerge (p1 :\/: p2) = case naturalMerge (p1:\/:p2) of Just (_ :/\: p1') -> Sealed p1' Nothing -> merger "0.0" p2 p1 @@ -352,7 +341,7 @@ Just p1s' -> mapFlipped (:<:p2) $ reconcileUnwindings p p1s' tp2s Nothing -> - bugDoc $ text "in function reconcileUnwindings" + errorDoc $ text "in function reconcileUnwindings" $$ text "Original patch:" $$ showPatch_ p _ -> bug "in reconcileUnwindings" @@ -381,7 +370,8 @@ case commuteFLId commuteNoMerger (p :> passedby) of Just (_ :> p'@(Merger _ _ p1 p2)) -> map Sealed (nubBy unsafeCompare $ - effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p')) + effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : + map (unsafeCoercePStart . unsafeUnseal) (unravel p')) : rcs (p :>: passedby) ps Nothing -> rcs (p :>: passedby) ps _ -> impossible @@ -395,7 +385,7 @@ -- This type seems wrong - the most natural type for the result would seem to be --- [Sealed (FL Prim wX)], given the type of unwind. +-- [Sealed (FL prim wX)], given the type of unwind. -- However downstream code in darcs convert assumes the wY type, and I was unable -- to figure out whether this could/should reasonably be changed -- Ganesh 13/4/10 publicUnravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wY)] @@ -463,11 +453,11 @@ newUr p (ps :<: Merger _ _ p1 p2) = case filter (\(_:<:pp) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of ((ps':<:_):_) -> newUr p (ps':<:unsafeCoercePStart p1) ++ newUr p (ps':<:unsafeCoercePStart p2) - _ -> bugDoc $ text "in function newUr" - $$ text "Original patch:" - $$ showPatch_ p - $$ text "Unwound:" - $$ vcat (unseal (mapRL showPatch_) $ unwind p) + _ -> errorDoc $ text "in function newUr" + $$ text "Original patch:" + $$ showPatch_ p + $$ text "Unwound:" + $$ vcat (unseal (mapRL showPatch_) $ unwind p) newUr op ps = case filter (\(_:<:p) -> isMerger p) $ headPermutationsRL ps of @@ -481,13 +471,13 @@ = Merger undo unwindings p1 p2 invert (PP p) = PP (invert p) -instance MyEq prim => MyEq (RepoPatchV1 prim) where +instance Eq2 prim => Eq2 (RepoPatchV1 prim) where unsafeCompare = eqPatches -instance MyEq prim => Eq (RepoPatchV1 prim wX wY) where +instance Eq2 prim => Eq (RepoPatchV1 prim wX wY) where (==) = unsafeCompare -eqPatches :: MyEq prim => RepoPatchV1 prim wX wY -> RepoPatchV1 prim wW wZ -> Bool +eqPatches :: Eq2 prim => RepoPatchV1 prim wX wY -> RepoPatchV1 prim wW wZ -> Bool eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) = eqPatches p1a p2a && diff --git a/src/Darcs/Patch/V1/Core.hs b/src/Darcs/Patch/V1/Core.hs --- a/src/Darcs/Patch/V1/Core.hs +++ b/src/Darcs/Patch/V1/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} module Darcs.Patch.V1.Core ( RepoPatchV1(..), isMerger, mergerUndo @@ -7,9 +7,14 @@ import Prelude () import Darcs.Prelude -import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV1) ) +import Darcs.Patch.Format + ( PatchListFormat(..) + , ListFormat(ListFormatV1) + ) import Darcs.Patch.Debug ( PatchDebug(..) ) -import Darcs.Patch.Prim ( FromPrim(..), PrimOf, PrimPatchBase, PrimPatch ) +import Darcs.Patch.Prim + ( FromPrim(..), PrimPatchBase(..), PrimPatch + ) import Darcs.Patch.Repair ( Check ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL ) @@ -19,8 +24,6 @@ , appPrec, showsPrec2 ) -#include "impossible.h" - -- This haddock could be put on the individual bits of Merger instead -- once haddock supports doc comments on GADT constructors {- | @@ -95,3 +98,4 @@ -- no checks instance PatchDebug prim => PatchDebug (RepoPatchV1 prim) + diff --git a/src/Darcs/Patch/V1/Prim.hs b/src/Darcs/Patch/V1/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/V1/Prim.hs @@ -0,0 +1,116 @@ +-- it is stupid that we need UndecidableInstances just to call another +-- type function (see instance Apply below which requires this) +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Darcs.Patch.V1.Prim ( Prim(..) ) where + +import Prelude () +import Darcs.Prelude + +import Data.Coerce ( coerce ) + +import Darcs.Patch.Annotate ( Annotate(..) ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute ) +import Darcs.Patch.FileHunk ( IsHunk(..) ) +import Darcs.Patch.Format + ( PatchListFormat(..) + , ListFormat(ListFormatV1) + , FileNameFormat(OldFormat,UserFormat) ) +import Darcs.Patch.Inspect ( PatchInspect ) +import Darcs.Patch.Invert ( Invert ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Repair ( RepairToFL(..) ) +import Darcs.Patch.Show + ( ShowPatchBasic(..) + , ShowPatchFor(..) + , ShowPatch(..) + , ShowContextPatch(..) + ) +import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims ) + +import Darcs.Patch.Witnesses.Eq ( Eq2 ) +import Darcs.Patch.Witnesses.Show + ( Show1(..), Show2(..) + , ShowDict(ShowDictClass) + , appPrec, showsPrec2 + ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) + +import Darcs.Patch.Prim.Class + ( PrimConstruct(..), PrimCanonize(..) + , PrimClassify(..), PrimDetails(..) + , PrimShow(..), PrimRead(..) + , PrimApply(..) + , PrimPatch, PrimPatchBase(..) + , FromPrim(..), ToFromPrim(..) + , PrimPatchCommon + ) +import qualified Darcs.Patch.Prim.V1 as Base ( Prim ) + +newtype Prim x y = Prim { unPrim :: Base.Prim x y } deriving + ( Annotate + , Commute + , Invert + , IsHunk + , Eq2 + , PatchInspect + , PrimApply + , PrimCanonize + , PrimClassify + , PrimConstruct + , PrimDetails + , PrimPatchCommon + ) + +instance PrimPatch Prim + +instance Show (Prim wX wY) where + showsPrec d (Prim p) = + showParen (d > appPrec) $ showString "Prim " . showsPrec2 (appPrec + 1) p + +instance Show1 (Prim wX) where + showDict1 = ShowDictClass + +instance Show2 Prim where + showDict2 = ShowDictClass + +instance PrimPatchBase Prim where + type PrimOf Prim = Prim + +instance FromPrim Prim where + fromPrim = id + +instance ToFromPrim Prim where + toPrim = Just + +instance ReadPatch Prim where + readPatch' = do + Sealed p <- readPrim OldFormat + return (Sealed (Prim p)) + +fileNameFormat :: ShowPatchFor -> FileNameFormat +fileNameFormat ForDisplay = UserFormat +fileNameFormat ForStorage = OldFormat + +instance ShowPatchBasic Prim where + showPatch fmt = showPrim (fileNameFormat fmt) . unPrim + +instance ShowContextPatch Prim where + showContextPatch f = showPrimCtx (fileNameFormat f) . unPrim + +instance ShowPatch Prim where + summary = plainSummaryPrim . unPrim + summaryFL = plainSummaryPrims False + thing _ = "change" + +instance PatchListFormat Prim where + patchListFormat = ListFormatV1 + +instance Apply Prim where + type ApplyState Prim = ApplyState Base.Prim + apply = apply . unPrim + +instance RepairToFL Prim where + applyAndTryToFixFL = fmap coerce . applyAndTryToFixFL . unPrim diff --git a/src/Darcs/Patch/V1/Show.hs b/src/Darcs/Patch/V1/Show.hs --- a/src/Darcs/Patch/V1/Show.hs +++ b/src/Darcs/Patch/V1/Show.hs @@ -4,23 +4,28 @@ import Prelude () import Darcs.Prelude -import Darcs.Patch.Format ( FileNameFormat(..) ) -import Darcs.Patch.Prim ( showPrim, PrimPatch ) - +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..) ) import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) -import Darcs.Util.Printer ( Doc, - text, blueText, - ($$), (<+>) ) +import Darcs.Util.Printer ( Doc, text, blueText, ($$), (<+>) ) -showPatch_ :: PrimPatch prim => RepoPatchV1 prim wA wB -> Doc -showPatch_ (PP p) = showPrim OldFormat p -showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2 -showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2 -showMerger :: PrimPatch prim => String -> RepoPatchV1 prim wA wB -> RepoPatchV1 prim wD wE -> Doc -showMerger merger_name p1 p2 = +showPatch_ :: ShowPatchBasic prim => prim wX wY -> Doc +showPatch_ = showPatch ForDisplay + +showMerger :: ShowPatchBasic prim + => ShowPatchFor + -> String + -> RepoPatchV1 prim wA wB + -> RepoPatchV1 prim wD wE + -> Doc +showMerger f merger_name p1 p2 = blueText merger_name <+> text "0.0" <+> blueText "(" - $$ showPatch_ p1 - $$ showPatch_ p2 + $$ showPatch f p1 + $$ showPatch f p2 $$ blueText ")" + +instance ShowPatchBasic prim => ShowPatchBasic (RepoPatchV1 prim) where + showPatch f (PP p) = showPatch f p + showPatch f (Merger _ _ p1 p2) = showMerger f "merger" p1 p2 + showPatch f (Regrem _ _ p1 p2) = showMerger f "regrem" p1 p2 diff --git a/src/Darcs/Patch/V1/Viewing.hs b/src/Darcs/Patch/V1/Viewing.hs --- a/src/Darcs/Patch/V1/Viewing.hs +++ b/src/Darcs/Patch/V1/Viewing.hs @@ -1,25 +1,19 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Viewing () where -import Prelude () -import Darcs.Prelude - import Darcs.Patch.Prim ( PrimPatch ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) +import Darcs.Patch.Show ( ShowPatch(..), ShowContextPatch(..), showPatch ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) -import Darcs.Patch.V1.Show ( showPatch_ ) - +import Darcs.Patch.V1.Show () -instance PrimPatch prim => ShowPatchBasic (RepoPatchV1 prim) where - showPatch = showPatch_ +instance PrimPatch prim => ShowContextPatch (RepoPatchV1 prim) where + showContextPatch f (PP p) = showContextPatch f p + showContextPatch f p = return $ showPatch f p instance PrimPatch prim => ShowPatch (RepoPatchV1 prim) where - showContextPatch (PP p) = showContextPatch p - showContextPatch p = return $ showPatch p summary = plainSummary summaryFL = plainSummary thing _ = "change" - diff --git a/src/Darcs/Patch/V2.hs b/src/Darcs/Patch/V2.hs --- a/src/Darcs/Patch/V2.hs +++ b/src/Darcs/Patch/V2.hs @@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.V2 ( RepoPatchV2, prim2repopatchV2 ) where +module Darcs.Patch.V2 ( RepoPatchV2 ) where +import Darcs.Patch.Annotate ( Annotate ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch ) - -import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, prim2repopatchV2 ) +import Darcs.Patch.V2.RepoPatch ( RepoPatchV2 ) instance PrimPatch prim => Matchable (RepoPatchV2 prim) -instance PrimPatch prim => RepoPatch (RepoPatchV2 prim) +instance (PrimPatch prim, Annotate prim) => RepoPatch (RepoPatchV2 prim) diff --git a/src/Darcs/Patch/V2/Non.hs b/src/Darcs/Patch/V2/Non.hs --- a/src/Darcs/Patch/V2/Non.hs +++ b/src/Darcs/Patch/V2/Non.hs @@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} -{-# LANGUAGE CPP, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} module Darcs.Patch.V2.Non @@ -44,18 +44,22 @@ import Data.List ( delete ) import Control.Monad ( liftM, mzero ) +import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( commuteFL ) import Darcs.Patch.Effect ( Effect(..) ) -import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) +import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Invert ( Invert, invertFL, invertRL ) -import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), - PrimOf, PrimPatchBase, - showPrim, sortCoalesceFL, - readPrim ) -import Darcs.Patch.Patchy ( Patchy, showPatch, ReadPatch(..), - Commute(..), invert ) +import Darcs.Patch.Prim + ( FromPrim(..), ToFromPrim(..) + , PrimOf, PrimPatchBase + , sortCoalesceFL + ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Invert ( Invert(invert) ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Show ( showPatch ) import Darcs.Patch.ReadMonads ( ParserM, lexChar ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (+>+), mapRL_RL , (:>)(..), reverseFL, reverseRL ) @@ -64,7 +68,7 @@ , showsPrec2 ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Read ( peekfor ) -import Darcs.Patch.Show ( ShowPatchBasic ) +import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor ) import Darcs.Patch.Viewing () import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL ) import Darcs.Util.Printer ( Doc, empty, vcat, hiddenPrefix, blueText, ($$) ) @@ -90,16 +94,18 @@ -- |showNons creates a Doc representing a list of Nons. showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) - => [Non p wX] -> Doc -showNons [] = empty -showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}" + => ShowPatchFor -> [Non p wX] -> Doc +showNons _ [] = empty +showNons f xs = blueText "{{" $$ vcat (map (showNon f) xs) $$ blueText "}}" -- |showNon creates a Doc representing a Non. -showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p wX +showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) + => ShowPatchFor + -> Non p wX -> Doc -showNon (Non c p) = hiddenPrefix "|" (showPatch c) - $$ hiddenPrefix "|" (blueText ":") - $$ showPrim NewFormat p +showNon f (Non c p) = hiddenPrefix "|" (showPatch f c) + $$ hiddenPrefix "|" (blueText ":") + $$ showPatch f p -- |readNons is a parser that attempts to read a list of Nons. readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) @@ -108,20 +114,20 @@ where rns = peekfor (BC.pack "}}") (return []) $ do Sealed ps <- readPatch' lexChar ':' - Sealed p <- readPrim NewFormat + Sealed p <- readPatch' (Non ps p :) `liftM` rns -- |readNon is a parser that attempts to read a single Non. readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m (Non p wX) readNon = do Sealed ps <- readPatch' - let doReadPrim = do Sealed p <- readPrim NewFormat + let doReadPrim = do Sealed p <- readPatch' return $ Non ps p peekfor (BC.singleton ':') doReadPrim mzero -- |Nons are equal if their context patches are equal, and they have an equal -- prim patch. -instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p wX) where +instance (Commute p, Eq2 p, Eq2 (PrimOf p)) => Eq (Non p wX) where Non (cx :: FL p wX wY1) (x :: PrimOf p wY1 wZ1) == Non (cy :: FL p wX wY2) (y :: PrimOf p wY2 wZ2) = case cx =\/= cy of @@ -138,7 +144,7 @@ -- returns some variant @cy'@. If commutation suceeds, the variant is just -- straightforwardly the commuted version. If commutation fails, the variant -- consists of @x@ prepended to the context of @cy@. -commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p wX wY -> Non p wY +commuteOrAddToCtx :: (Commute p, ToFromPrim p) => p wX wY -> Non p wY -> Non p wX commuteOrAddToCtx p n | Just n' <- p >* n = n' commuteOrAddToCtx p (Non c x) = Non (p:>:c) x @@ -155,7 +161,7 @@ -- > x1 [c1'' c2'' y''] x2' x3' -- -- and return @[x1 c1'' c2'' y'']@ -commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p wX wY -> Non p wY +commuteOrAddToCtxRL :: (Apply p, Commute p, Invert p, ToFromPrim p) => RL p wX wY -> Non p wY -> Non p wX commuteOrAddToCtxRL NilRL n = n commuteOrAddToCtxRL (ps:<:p) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n @@ -175,7 +181,7 @@ -- |commutePrimsOrAddToCtx takes a WL of prims and attempts to commute them -- past a Non. -commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) wX wY +commutePrimsOrAddToCtx :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY -> Non p wX commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromPrim $ toRL q) @@ -194,14 +200,14 @@ -- modify p2, so that it doesn't have any of a1' in its context. -- remNons really only works right if the relevant nons are conflicting... -remNons :: (Nonable p, Effect p, Patchy p, MyEq p, ToFromPrim p, PrimPatchBase p, - MyEq (PrimOf p)) => [Non p wX] -> Non p wX -> Non p wX +remNons :: (Nonable p, Effect p, Apply p, Commute p, Invert p, Eq2 p, ToFromPrim p, PrimPatchBase p) + => [Non p wX] -> Non p wX -> Non p wX remNons ns n@(Non c x) = case remNonHelper ns c of NilFL :> c' -> Non c' x _ -> n where - remNonHelper :: (Nonable p, Effect p, Patchy p, MyEq p, ToFromPrim p, - PrimPatchBase p, MyEq (PrimOf p)) => [Non p wX] + remNonHelper :: (Nonable p, Effect p, Apply p, Commute p, Invert p, Eq2 p, ToFromPrim p, + PrimPatchBase p) => [Non p wX] -> FL p wX wY -> (FL (PrimOf p) :> FL p) wX wY remNonHelper [] x = NilFL :> x remNonHelper _ NilFL = NilFL :> NilFL @@ -223,26 +229,26 @@ -- -- TODO: understand if there is any case where p is equal to the prim patch of -- the Non, in which case, we return the original Non, is that right? -commuteOrRemFromCtx :: (Patchy p, MyEq p, ToFromPrim p) => p wX wY -> Non p wX +commuteOrRemFromCtx :: (Commute p, Invert p, Eq2 p, ToFromPrim p) => p wX wY -> Non p wX -> Maybe (Non p wY) commuteOrRemFromCtx p n | n'@(Just _) <- n *> p = n' commuteOrRemFromCtx p (Non pc x) = removeFL p pc >>= \c -> return (Non c x) -- |commuteOrRemFromCtxFL attempts to remove a FL of patches from a Non, -- returning Nothing if any of the individual removes fail. -commuteOrRemFromCtxFL :: (Patchy p, MyEq p, ToFromPrim p) => FL p wX wY -> Non p wX +commuteOrRemFromCtxFL :: (Apply p, Commute p, Invert p, Eq2 p, ToFromPrim p) => FL p wX wY -> Non p wX -> Maybe (Non p wY) commuteOrRemFromCtxFL NilFL n = Just n commuteOrRemFromCtxFL (p:>:ps) n = do n' <- commuteOrRemFromCtx p n commuteOrRemFromCtxFL ps n' -- |(*>) attemts to modify a Non by commuting it past a given patch. -(*>) :: (Patchy p, ToFromPrim p) => Non p wX -> p wX wY +(*>) :: (Commute p, Invert p, ToFromPrim p) => Non p wX -> p wX wY -> Maybe (Non p wY) n *> p = invert p >* n -- |(>*) attempts to modify a Non, by commuting a given patch past it. -(>*) :: (Patchy p, ToFromPrim p) => p wX wY -> Non p wY +(>*) :: (Commute p, ToFromPrim p) => p wX wY -> Non p wY -> Maybe (Non p wX) y >* (Non c x) = do c' :> y' <- commuteFL (y :> c) @@ -251,16 +257,16 @@ return (Non c' x') -- |(*>>) attempts to modify a Non by commuting it past a given WL of patches. -(*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p wX +(*>>) :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p, PrimPatchBase p) => Non p wX -> l (PrimOf p) wX wY -> Maybe (Non p wY) n *>> p = invertWL p >>* n -- |(>>*) attempts to modify a Non by commuting a given WL of patches past it. -(>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY +(>>*) :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY -> Maybe (Non p wX) ps >>* n = commuteRLPastNon (toRL ps) n where - commuteRLPastNon :: (Patchy p, ToFromPrim p) => RL (PrimOf p) wX wY + commuteRLPastNon :: (Apply p, Commute p, Invert p, ToFromPrim p) => RL (PrimOf p) wX wY -> Non p wY -> Maybe (Non p wX) commuteRLPastNon NilRL n = Just n commuteRLPastNon (xs:<:x) n = fromPrim x >* n >>= commuteRLPastNon xs diff --git a/src/Darcs/Patch/V2/Prim.hs b/src/Darcs/Patch/V2/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/V2/Prim.hs @@ -0,0 +1,120 @@ +-- it is stupid that we need UndecidableInstances just to call another +-- type function (see instance Apply below which requires this) +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Darcs.Patch.V2.Prim ( Prim(..) ) where + +import Prelude () +import Darcs.Prelude + +import Data.Coerce (coerce ) + +import Darcs.Patch.Annotate ( Annotate ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute ) +import Darcs.Patch.FileHunk ( IsHunk ) +import Darcs.Patch.Format + ( PatchListFormat(..) + , ListFormat(ListFormatV2) + , FileNameFormat(NewFormat,UserFormat) ) +import Darcs.Patch.Inspect ( PatchInspect ) +import Darcs.Patch.Invert ( Invert ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.Repair ( RepairToFL(..) ) +import Darcs.Patch.Show + ( ShowPatchBasic(..) + , ShowPatchFor(..) + , ShowPatch(..) + , ShowContextPatch(..) + ) +import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims ) + +import Darcs.Patch.Witnesses.Eq ( Eq2 ) +import Darcs.Patch.Witnesses.Show + ( Show1(..), Show2(..) + , ShowDict(ShowDictClass) + , appPrec, showsPrec2 + ) +import Darcs.Patch.Witnesses.Sealed ( mapSeal ) + +import Darcs.Patch.Prim.Class + ( PrimConstruct(..), PrimCanonize(..) + , PrimClassify(..), PrimDetails(..) + , PrimShow(..), PrimRead(..) + , PrimApply(..) + , PrimPatch, PrimPatchBase(..) + , FromPrim(..), ToFromPrim(..) + , PrimPatchCommon + ) +import qualified Darcs.Patch.Prim.V1 as Base ( Prim ) + +newtype Prim x y = Prim { unPrim :: Base.Prim x y } deriving + ( Annotate + , Commute + , Invert + , IsHunk + , Eq2 + , PatchInspect + , PrimApply + , PrimCanonize + , PrimClassify + , PrimConstruct + , PrimDetails + , PrimPatchCommon + ) + +instance PrimPatch Prim + +instance Show (Prim wX wY) where + showsPrec d (Prim p) = + showParen (d > appPrec) $ showString "Prim " . showsPrec2 (appPrec + 1) p + +instance Show1 (Prim wX) where + showDict1 = ShowDictClass + +instance Show2 Prim where + showDict2 = ShowDictClass + +instance PrimPatchBase Prim where + type PrimOf Prim = Prim + +instance FromPrim Prim where + fromPrim = id + +instance ToFromPrim Prim where + toPrim = Just + +instance ReadPatch Prim where + readPatch' = fmap (mapSeal Prim) (readPrim NewFormat) + +fileNameFormat :: ShowPatchFor -> FileNameFormat +fileNameFormat ForDisplay = UserFormat +fileNameFormat ForStorage = NewFormat + +instance ShowPatchBasic Prim where + showPatch f = showPrim (fileNameFormat f) . unPrim + +instance ShowContextPatch Prim where + showContextPatch f = showPrimCtx (fileNameFormat f) . unPrim + +instance ShowPatch Prim where + summary = plainSummaryPrim . unPrim + summaryFL = plainSummaryPrims False + thing _ = "change" + +-- This instance is here so that FL Prim and RL Prim also get +-- ShowPatch instances, see Darcs.Patch.Viewing +instance PatchListFormat Prim where + -- In principle we could use ListFormatDefault when prim /= V1 Prim patches, + -- as those are the only case where we need to support a legacy on-disk + -- format. In practice we don't expect RepoPatchV2 to be used with any other + -- argument anyway, so it doesn't matter. + patchListFormat = ListFormatV2 + +instance Apply Prim where + type ApplyState Prim = ApplyState Base.Prim + apply = apply . unPrim + +instance RepairToFL Prim where + applyAndTryToFixFL = fmap coerce . applyAndTryToFixFL . unPrim diff --git a/src/Darcs/Patch/V2/RepoPatch.hs b/src/Darcs/Patch/V2/RepoPatch.hs --- a/src/Darcs/Patch/V2/RepoPatch.hs +++ b/src/Darcs/Patch/V2/RepoPatch.hs @@ -16,12 +16,9 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} -{-# LANGUAGE CPP #-} - module Darcs.Patch.V2.RepoPatch ( RepoPatchV2(..) - , prim2repopatchV2 , isConsistent , isForward , isDuplicate @@ -35,43 +32,45 @@ import qualified Data.ByteString.Char8 as BC ( ByteString, pack ) import Data.Maybe ( fromMaybe ) import Data.List ( partition, nub ) +import Data.List.Ordered ( nubSort ) +import Darcs.Patch.Annotate ( Annotate(..) ) import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL - , commuteRLFL ) + , commuteRLFL, Commute(..) ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) , IsConflictedPrim(..), ConflictState(..) , mangleUnravelled ) import Darcs.Patch.Debug import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) -import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..) - , FileNameFormat(NewFormat) ) -import Darcs.Patch.Invert ( invertFL, invertRL ) -import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), showPrim, showPrimFL - , readPrim, PrimOf, PrimPatchBase, PrimPatch ) -import Darcs.Patch.Read ( bracketedFL ) +import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV2) ) +import Darcs.Patch.Invert ( invertFL, invertRL, Invert(..) ) +import Darcs.Patch.Merge ( Merge(..), naturalMerge ) +import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..) + , PrimPatchBase(..), PrimPatch ) +import Darcs.Patch.Read ( bracketedFL, ReadPatch(..) ) import Darcs.Patch.ReadMonads ( skipSpace, string, choice ) import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) ) -import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..), PatchInspect(..) - , ReadPatch(..), ShowPatch(..), Invert(..) ) +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL , genCommuteWhatWeCanRL, removeRL, removeFL , removeSubsequenceFL ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Patch.Show + ( ShowPatch(..), ShowPatchBasic(..), ShowContextPatch(..), ShowPatchFor(..) + , displayPatch ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon , readNons, readNon, commutePrimsOrAddToCtx , commuteOrAddToCtx, commuteOrAddToCtxRL , commuteOrRemFromCtx, commuteOrRemFromCtxFL , remNons, (*>), (>*), (*>>), (>>*) ) -import Data.List.Ordered ( nubSort ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), (+<+) - , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..) - , reverseRL, lengthFL, lengthRL, nullFL ) + , mapFL, mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..) + , reverseRL, lengthFL, lengthRL, nullFL, initsFL ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal , unseal ) @@ -79,11 +78,9 @@ ( Show1(..), Show2(..), ShowDict(..) , showsPrec2, appPrec ) -import Darcs.Util.Printer.Color ( errorDoc, assertDoc ) -import Darcs.Util.Printer ( Doc, blueText, redText, (<+>), ($$) ) - -#include "impossible.h" +import Darcs.Util.Printer.Color ( errorDoc, assertDoc ) +import Darcs.Util.Printer ( Doc, blueText, redText, (<+>), ($$), vcat ) -- |'RepoPatchV2' is used to represents prim patches that are duplicates of, or -- conflict with, another prim patch in the repository. @@ -141,7 +138,7 @@ p@(Etacilpud _) -> justRedP "An inverse duplicate" p _ -> Nothing where - justRedP msg p = Just $ redText msg $$ showPatch p + justRedP msg p = Just $ redText msg $$ displayPatch p -- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers) -- to Darcs V2 patches (Conflictors). @@ -155,7 +152,7 @@ Just NilRL -> bug "found no patches in mergeUnravelled" Just (_ :<: z) -> Just $ FlippedSeal z where - notNullS :: PrimPatch prim => Sealed ((FL prim) wX) -> Bool + notNullS :: Sealed ((FL prim) wX) -> Bool notNullS (Sealed NilFL) = False notNullS _ = True @@ -191,7 +188,7 @@ qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) joinEffects :: forall p wX wY . (Effect p, Invert (PrimOf p), - Commute (PrimOf p), MyEq (PrimOf p)) => p wX wY + Commute (PrimOf p), Eq2 (PrimOf p)) => p wX wY -> FL (PrimOf p) wX wY joinEffects = joinInverses . effect where joinInverses :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wB @@ -204,7 +201,7 @@ -> RepoPatchV2 prim wX wY assertConsistent x = flip assertDoc x $ do e <- isConsistent x - Just (redText "Inconsistent patch:" $$ showPatch x $$ e) + Just (redText "Inconsistent patch:" $$ displayPatch x $$ e) -- | @mergeAfterConflicting@ takes as input a sequence of conflicting patches -- @xxx@ (which therefore have no effect) and a sequence of primitive patches @@ -267,7 +264,7 @@ case mergeConflictingNons ix of Nothing -> errorDoc $ redText "mergeConflictingNons failed in geteff: ix" $$ - showNons ix $$ redText "xx" $$ showPatch xx + displayNons ix $$ redText "xx" $$ displayPatch xx Just rix -> case mergeAfterConflicting rix xx of Just (a, x) -> @@ -276,9 +273,9 @@ Nothing -> errorDoc $ redText "mergeAfterConflicting failed in geteff" $$ - redText "where ix" $$ showNons ix $$ - redText "and xx" $$ showPatch xx $$ - redText "and rix" $$ showPatch rix + redText "where ix" $$ displayNons ix $$ + redText "and xx" $$ displayPatch xx $$ + redText "and rix" $$ displayPatch rix xx2nons :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY -> [Non (RepoPatchV2 prim) wX] @@ -309,18 +306,18 @@ Just $ redText "m doesn't conflict with mm in isConsistent" | any (\x -> any (x `conflictsWith`) nmm) im = Just $ redText "mm conflicts with im in isConsistent where nmm is" $$ - showNons nmm + displayNons nmm | Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$ - showNons (toNons deps) $$ + displayNons (toNons deps) $$ redText "compared with deps itself:" $$ - showPatch deps + displayPatch deps | otherwise = case allConflictsWith m im of (im1, []) | im1 `eqSet` im -> Nothing (_, imnc) -> Just $ redText ("m doesn't conflict with im in " ++ "isConsistent. unconflicting:") $$ - showNons imnc + displayNons imnc where (nmm, rmm) = geteff im mm everyoneConflicts :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> Bool @@ -329,10 +326,6 @@ ([], _) -> False (_, xs') -> everyoneConflicts xs' -prim2repopatchV2 :: prim wX wY -> RepoPatchV2 prim wX wY -prim2repopatchV2 = Normal - -instance PrimPatch prim => Patchy (RepoPatchV2 prim) instance PatchDebug prim => PatchDebug (RepoPatchV2 prim) mergeWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX @@ -470,13 +463,13 @@ isInconsistent = isConsistent instance FromPrim (RepoPatchV2 prim) where - fromPrim = prim2repopatchV2 + fromPrim = Normal instance ToFromPrim (RepoPatchV2 prim) where toPrim (Normal p) = Just p toPrim _ = Nothing -instance PrimPatch prim => MyEq (RepoPatchV2 prim) where +instance PrimPatch prim => Eq2 (RepoPatchV2 prim) where (Duplicate x) =\/= (Duplicate y) | x == y = IsEq (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq (Normal x) =\/= (Normal y) = x =\/= y @@ -519,8 +512,8 @@ -> Non (RepoPatchV2 prim) wX -> Bool nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x -toNons :: forall p wX wY . (Conflict p, Patchy p, PatchListFormat p, - ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p), ShowPatchBasic p) +toNons :: forall p wX wY . (Commute p, PatchListFormat p, + Nonable p, ShowPatchBasic (PrimOf p), ShowPatchBasic p) => FL p wX wY -> [Non p wX] toNons xs = map lastNon $ initsFL xs where lastNon :: Sealed ((p :> FL p) wX) -> Non p wX @@ -533,9 +526,9 @@ errorDoc $ redText "Weird case in toNons" $$ redText "please report this bug!" $$ (case xxx of - z :> zs -> showPatch (z :>: zs)) $$ - redText "ds are" $$ showPatch ds $$ - redText "pp is" $$ showPatch pp + z :> zs -> displayPatch (z :>: zs)) $$ + redText "ds are" $$ displayPatch ds $$ + redText "pp is" $$ displayPatch pp reverseFoo :: (p :> FL p) wX wZ -> (RL p :> p) wX wZ reverseFoo (p :> ps) = rf NilRL p ps @@ -548,12 +541,6 @@ lastNon_aux :: (p :> FL p) wX wZ -> (RL p :> p :> RL p) wX wZ lastNon_aux = commuteWhatWeCanRL . reverseFoo -initsFL :: Patchy p => FL p wX wY -> [Sealed ((p :> FL p) wX)] -initsFL NilFL = [] -initsFL (x :>: xs) = - Sealed (x :> NilFL) : - map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs) - filterConflictsFL :: PrimPatch prim => Non (RepoPatchV2 prim) wX -> FL prim wX wY -> (FL prim :> FL prim) wX wY filterConflictsFL _ NilFL = NilFL :> NilFL @@ -651,17 +638,11 @@ -- Handle using the swap merge and the previous case. merge m@(_ :\/: Duplicate _) = swapMerge m - -- When merging x and y, we do a bunch of what look like "consistency" - -- check merges. If the resulting y'' and y are equal, then we succeed. - -- If the first case fails, we check for equal patches (which wouldn't - -- commute) and return a Duplicate on both sides of the merge, in that - -- case. merge (x :\/: y) - | Just (y' :> ix') <- - commute (invert (assertConsistent x) :> assertConsistent y) - , Just (y'' :> _) <- commute (x :> y') - , IsEq <- y'' =\/= y = - assertConsistent y' :/\: invert (assertConsistent ix') + -- First try the natural (non-conflicting) merge. + | Just (y' :/\: x') <- + naturalMerge ((assertConsistent x) :\/: (assertConsistent y)) + = assertConsistent y' :/\: assertConsistent x' -- If we detect equal patches, we have a duplicate. | IsEq <- x =\/= y , n <- commuteOrAddToCtx (invert x) $ non x = @@ -768,12 +749,12 @@ (x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys) | otherwise = x : (xs +++ xys) -swapMerge :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY - -> (RepoPatchV2 prim :/\: RepoPatchV2 prim) wX wY +swapMerge :: Merge p => (p :\/: p) wX wY + -> (p :/\: p) wX wY swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x' -invertCommute :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY - -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY) +invertCommute :: (Invert p, Commute p) => (p :> p) wX wY + -> Maybe ((p :> p) wX wY) invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x) return (invert iy' :> invert ix') @@ -785,7 +766,7 @@ -- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out -- of both @xs@ and @ys@ along with the remnants of both lists -pullCommon :: (Patchy p, MyEq p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY +pullCommon :: (Commute p, Eq2 p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY pullCommon NilFL ys = Common NilFL NilFL ys pullCommon xs NilFL = Common NilFL xs NilFL pullCommon (x :>: xs) xys | Just ys <- removeFL x xys = @@ -803,7 +784,7 @@ -- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted -- out of both @xs@ and @ys@ along with the remnants of both lists -pullCommonRL :: (Patchy p, MyEq p) => RL p wX wO -> RL p wY wO -> CommonRL p wX wY wO +pullCommonRL :: (Commute p, Eq2 p) => RL p wX wO -> RL p wY wO -> CommonRL p wX wY wO pullCommonRL NilRL ys = CommonRL NilRL ys NilRL pullCommonRL xs NilRL = CommonRL xs NilRL NilRL pullCommonRL (xs :<: x) xys | Just ys <- removeRL x xys = @@ -829,6 +810,9 @@ mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p applyAndTryToFixFL x = do apply x; return Nothing +instance (PrimPatch prim, Annotate prim) => Annotate (RepoPatchV2 prim) where + annotate = annotate . effect + instance PatchListFormat (RepoPatchV2 prim) where -- In principle we could use ListFormatDefault when prim /= V1 Prim patches, -- as those are the only case where we need to support a legacy on-disk @@ -843,27 +827,29 @@ rotcilfnoc = "rotcilfnoc" instance PrimPatch prim => ShowPatchBasic (RepoPatchV2 prim) where - showPatch (Duplicate d) = blueText duplicate $$ showNon d - showPatch (Etacilpud d) = blueText etacilpud $$ showNon d - showPatch (Normal p) = showPrim NewFormat p - showPatch (Conflictor i NilFL p) = - blueText conflictor <+> showNons i <+> blueText "[]" $$ showNon p - showPatch (Conflictor i cs p) = - blueText conflictor <+> showNons i <+> blueText "[" $$ - showPrimFL NewFormat cs $$ + showPatch f (Duplicate d) = blueText duplicate $$ showNon f d + showPatch f (Etacilpud d) = blueText etacilpud $$ showNon f d + showPatch f (Normal p) = showPatch f p + showPatch f (Conflictor i NilFL p) = + blueText conflictor <+> showNons f i <+> blueText "[]" $$ showNon f p + showPatch f (Conflictor i cs p) = + blueText conflictor <+> showNons f i <+> blueText "[" $$ + showFL f cs $$ blueText "]" $$ - showNon p - showPatch (InvConflictor i NilFL p) = - blueText rotcilfnoc <+> showNons i <+> blueText "[]" $$ showNon p - showPatch (InvConflictor i cs p) = - blueText rotcilfnoc <+> showNons i <+> blueText "[" $$ - showPrimFL NewFormat cs $$ + showNon f p + showPatch f (InvConflictor i NilFL p) = + blueText rotcilfnoc <+> showNons f i <+> blueText "[]" $$ showNon f p + showPatch f (InvConflictor i cs p) = + blueText rotcilfnoc <+> showNons f i <+> blueText "[" $$ + showFL f cs $$ blueText "]" $$ - showNon p + showNon f p +instance PrimPatch prim => ShowContextPatch (RepoPatchV2 prim) where + showContextPatch f (Normal p) = showContextPatch f p + showContextPatch f p = return $ showPatch f p + instance PrimPatch prim => ShowPatch (RepoPatchV2 prim) where - showContextPatch (Normal p) = showContextPatch p - showContextPatch c = return $ showPatch c summary = plainSummary summaryFL = plainSummary thing _ = "change" @@ -874,7 +860,7 @@ let str = string . BC.pack readConflictorPs = do i <- readNons - ps <- bracketedFL (readPrim NewFormat) '[' ']' + ps <- bracketedFL readPatch' '[' ']' p <- readNon return (i, ps, p) choice [ do str duplicate @@ -889,29 +875,29 @@ , do str rotcilfnoc (i, Sealed ps, p) <- readConflictorPs return $ Sealed $ InvConflictor i ps p - , do Sealed p <- readPrim NewFormat + , do Sealed p <- readPatch' return $ Sealed $ Normal p ] instance Show2 prim => Show (RepoPatchV2 prim wX wY) where showsPrec d (Normal prim) = - showParen (d > appPrec) $ showString "Darcs.Patch.V2.RepoPatch.Normal " . showsPrec2 (appPrec + 1) prim + showParen (d > appPrec) $ showString "Normal " . showsPrec2 (appPrec + 1) prim showsPrec d (Duplicate x) = - showParen (d > appPrec) $ showString "Darcs.Patch.V2.RepoPatch.Duplicate " . showsPrec (appPrec + 1) x + showParen (d > appPrec) $ showString "Duplicate " . showsPrec (appPrec + 1) x showsPrec d (Etacilpud x) = - showParen (d > appPrec) $ showString "Darcs.Patch.V2.Etacilpud " . showsPrec (appPrec + 1) x + showParen (d > appPrec) $ showString "Etacilpud " . showsPrec (appPrec + 1) x showsPrec d (Conflictor ix xx x) = showParen (d > appPrec) $ - showString "Darcs.Patch.V2.RepoPatch.Conflictor " . showsPrec (appPrec + 1) ix . + showString "Conflictor " . showsPrec (appPrec + 1) ix . showString " " . showsPrec (appPrec + 1) xx . showString " " . showsPrec (appPrec + 1) x showsPrec d (InvConflictor ix xx x) = showParen (d > appPrec) $ - showString "Darcs.Patch.V2.RepoPatch.InvConflictor " . showsPrec (appPrec + 1) ix . + showString "InvConflictor " . showsPrec (appPrec + 1) ix . showString " " . showsPrec (appPrec + 1) xx . showString " " . showsPrec (appPrec + 1) x @@ -943,3 +929,10 @@ instance IsHunk prim => IsHunk (RepoPatchV2 prim) where isHunk rp = do Normal p <- return rp isHunk p + +displayNons :: (PatchListFormat p, ShowPatchBasic p, PrimPatchBase p) => + [Non p wX] -> Doc +displayNons p = showNons ForDisplay p + +showFL :: ShowPatchBasic p => ShowPatchFor -> FL p wX wY -> Doc +showFL f = vcat . mapFL (showPatch f) 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 @@ -16,18 +16,16 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} -{-# LANGUAGE CPP #-} module Darcs.Patch.Viewing ( showContextHunk - , showContextSeries ) where import Prelude () import Darcs.Prelude import Control.Applicative( (<$>) ) -import qualified Data.ByteString as BS ( null ) +import qualified Data.ByteString as B ( null ) import Prelude hiding ( pi, readFile ) import Darcs.Util.Tree ( Tree ) import Darcs.Util.Tree.Monad ( virtualTreeMonad ) @@ -38,24 +36,26 @@ import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName ) +import Darcs.Patch.Show + ( ShowPatchBasic(..), ShowPatch(..) + , formatFileName, ShowPatchFor(..), ShowContextPatch(..) ) import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), mapFL, mapFL_FL, reverseRL, concatFL ) import Darcs.Util.ByteString ( linesPS ) import Darcs.Util.Printer ( Doc, empty, vcat, text, blueText, Color(Cyan, Magenta), lineColor, ($$), (<+>), prefix, userchunkPS ) -showContextSeries :: forall p m wX wY . (Apply p, ShowPatch p, IsHunk p, +showContextSeries :: forall p m wX wY . (Apply p, ShowContextPatch p, IsHunk p, ApplyMonad (ApplyState p) m) - => FL p wX wY -> m Doc -showContextSeries = scs Nothing + => ShowPatchFor -> FileNameFormat -> FL p wX wY -> m Doc +showContextSeries use fmt = scs Nothing where scs :: forall wWw wXx wYy . Maybe (FileHunk wWw wXx) -> FL p wXx wYy -> m Doc scs pold (p :>: ps) = do (_, s') <- nestedApply (apply p) =<< getApplyState case isHunk p of Nothing -> do - a <- showContextPatch p + a <- showContextPatch use p b <- nestedApply (scs Nothing ps) s' return $ a $$ fst b Just fh -> case ps of @@ -69,29 +69,30 @@ cool :: Maybe (FileHunk wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD) -> (ApplyState p) (ApplyMonadBase m) -> (ApplyMonadBase m) Doc cool pold fh ps s = - fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s) + fst <$> virtualTreeMonad (coolContextHunk fmt pold fh ps) (toTree s) -showContextHunk :: (ApplyMonad Tree m) => FileHunk wX wY -> m Doc -showContextHunk h = coolContextHunk Nothing h Nothing +showContextHunk :: (ApplyMonad Tree m) => FileNameFormat -> FileHunk wX wY -> m Doc +showContextHunk fmt h = coolContextHunk fmt Nothing h Nothing coolContextHunk :: (ApplyMonad Tree m) - => Maybe (FileHunk wA wB) -> FileHunk wB wC + => FileNameFormat + -> Maybe (FileHunk wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD) -> m Doc -coolContextHunk prev fh@(FileHunk f l o n) next = do +coolContextHunk fmt prev fh@(FileHunk f l o n) next = do have <- mDoesFileExist f content <- if have then Just `fmap` mReadFilePS f else return Nothing case linesPS `fmap` content of - -- This is a weird error... - Nothing -> return $ showFileHunk OldFormat fh + -- FIXME This is a weird error... + Nothing -> return $ showFileHunk fmt fh Just ls -> let pre = take numpre $ drop (l - numpre - 1) ls cleanedls = case reverse ls of (x : xs) - | BS.null x -> reverse xs + | B.null x -> reverse xs _ -> ls post = take numpost $ drop (max 0 $ l+length o-1) cleanedls in return $ - blueText "hunk" <+> formatFileName OldFormat f + blueText "hunk" <+> formatFileName fmt f <+> text (show l) $$ prefix " " (vcat $ map userchunkPS pre) $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o)) @@ -111,33 +112,36 @@ _ -> 3 instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (FL p) where - showPatch = showPatchInternal patchListFormat + showPatch ForDisplay = vcat . mapFL (showPatch ForDisplay) + showPatch ForStorage = showPatchInternal patchListFormat where showPatchInternal :: ListFormat p -> FL p wX wY -> Doc - showPatchInternal ListFormatV1 (p :>: NilFL) = showPatch p + showPatchInternal ListFormatV1 (p :>: NilFL) = (showPatch ForStorage) p showPatchInternal ListFormatV1 NilFL = blueText "{" $$ blueText "}" showPatchInternal ListFormatV1 ps = blueText "{" - $$ vcat (mapFL showPatch ps) + $$ vcat (mapFL (showPatch ForStorage) ps) $$ blueText "}" - showPatchInternal ListFormatV2 ps = vcat (mapFL showPatch ps) - showPatchInternal ListFormatDefault ps = vcat (mapFL showPatch ps) + showPatchInternal ListFormatV2 ps = vcat (mapFL (showPatch ForStorage) ps) + showPatchInternal ListFormatDefault ps = vcat (mapFL (showPatch ForStorage) ps) -instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) - => ShowPatch (FL p) where - showContextPatch = showContextPatchInternal patchListFormat +instance (Apply p, IsHunk p, PatchListFormat p, ShowContextPatch p) + => ShowContextPatch (FL p) where + showContextPatch ForDisplay = showContextSeries ForDisplay UserFormat + showContextPatch ForStorage = showContextPatchInternal patchListFormat where showContextPatchInternal :: (ApplyMonad (ApplyState (FL p)) m) => ListFormat p -> FL p wX wY -> m Doc showContextPatchInternal ListFormatV1 (p :>: NilFL) = - showContextPatch p + showContextPatch ForStorage p showContextPatchInternal ListFormatV1 NilFL = return $ blueText "{" $$ blueText "}" showContextPatchInternal ListFormatV1 ps = do - x <- showContextSeries ps + x <- showContextSeries ForStorage OldFormat ps return $ blueText "{" $$ x $$ blueText "}" - showContextPatchInternal ListFormatV2 ps = showContextSeries ps - showContextPatchInternal ListFormatDefault ps = showContextSeries ps + showContextPatchInternal ListFormatV2 ps = showContextSeries ForStorage NewFormat ps + showContextPatchInternal ListFormatDefault ps = showContextSeries ForStorage NewFormat ps +instance (PatchListFormat p, ShowPatch p) => ShowPatch (FL p) where description = vcat . mapFL description summary = summaryFL @@ -152,12 +156,13 @@ things = thing instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RL p) where - showPatch = showPatch . reverseRL + showPatch f = showPatch f . reverseRL -instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) - => ShowPatch (RL p) where - showContextPatch = showContextPatch . reverseRL +instance (ShowContextPatch p, Apply p, IsHunk p, PatchListFormat p) + => ShowContextPatch (RL p) where + showContextPatch use = showContextPatch use . reverseRL +instance (PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where description = description . reverseRL summary = summary . reverseRL diff --git a/src/Darcs/Patch/Witnesses/Eq.hs b/src/Darcs/Patch/Witnesses/Eq.hs --- a/src/Darcs/Patch/Witnesses/Eq.hs +++ b/src/Darcs/Patch/Witnesses/Eq.hs @@ -1,6 +1,6 @@ module Darcs.Patch.Witnesses.Eq ( EqCheck(..) - , MyEq(..) + , Eq2(..) , isIsEq ) where @@ -26,7 +26,7 @@ -- |An witness aware equality class. -- A minimal definition defines any one of 'unsafeCompare', '=\/=' and '=/\='. -class MyEq p where +class Eq2 p where -- |It is unsafe to define a class instance via this method, because -- if it returns True then the default implementations of '=\/=' and '=/\=' -- will coerce the equality of two witnesses. diff --git a/src/Darcs/Patch/Witnesses/Ordered.hs b/src/Darcs/Patch/Witnesses/Ordered.hs --- a/src/Darcs/Patch/Witnesses/Ordered.hs +++ b/src/Darcs/Patch/Witnesses/Ordered.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Patch.Witnesses.Ordered ( -- * Directed Types @@ -30,50 +28,58 @@ , (:/\:)(..) , (:||:)(..) , Fork(..) - -- * Functions + -- * Functions for 'FL's and 'RL's + , nullFL + , nullRL , lengthFL + , lengthRL , mapFL + , mapRL , mapFL_FL - , spanFL + , mapRL_RL , foldlFL + , foldlRL , allFL + , allRL , anyFL + , anyRL , filterFL + , filterRL , splitAtFL , splitAtRL - , bunchFL - , foldlRL - , lengthRL - , isShorterThanRL - , mapRL - , mapRL_RL - , zipWithFL , filterOutFLFL , filterOutRLRL - , filterRL , reverseFL , reverseRL , (+>+) , (+<+) - , nullFL + , (+>>+) + , (+<<+) , concatFL , concatRL - , snocRLSealed - , nullRL - , toFL , dropWhileFL , dropWhileRL + -- * 'FL' only + , bunchFL + , foldFL_M + , spanFL , spanFL_M + , zipWithFL + , toFL , mapFL_FL_M + , sequenceFL_ , eqFL , eqFLRev , eqFLUnsafe + , initsFL + -- * 'RL' only + , isShorterThanRL + , snocRLSealed ) where import Prelude () import Darcs.Prelude -#include "impossible.h" import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..) @@ -84,7 +90,7 @@ , Sealed2(..) , seal ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) -- * Directed Types @@ -221,11 +227,11 @@ instance (Show2 a, Show2 b) => Show ( (a :> b) wX wY ) where showsPrec d (x :> y) = showOp2 1 ":>" d x y -instance (MyEq a, MyEq b) => MyEq (a :> b) where +instance (Eq2 a, Eq2 b) => Eq2 (a :> b) where (a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2 | otherwise = NotEq -instance (MyEq a, MyEq b) => Eq ((a :> b) wX wY) where +instance (Eq2 a, Eq2 b) => Eq ((a :> b) wX wY) where (==) = unsafeCompare instance (Show2 a, Show2 b) => Show2 (a :> b) where @@ -262,7 +268,7 @@ filterOutFLFL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> FL p wW wZ -> FL p wW wZ filterOutFLFL _ NilFL = NilFL filterOutFLFL f (x:>:xs) | IsEq <- f x = filterOutFLFL f xs - | otherwise = x :>: filterOutFLFL f xs + | otherwise = x :>: filterOutFLFL f xs filterOutRLRL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> RL p wW wZ -> RL p wW wZ filterOutRLRL _ NilRL = NilRL @@ -344,6 +350,14 @@ bFL bs = case splitAtFL n bs of a :> b -> a :>: bFL b +-- | Monadic fold over an 'FL' +-- associating to the left, i.e. from left to right. +-- The order of arguments follows the standard 'foldM' from base. +foldFL_M :: Monad m + => (forall wA wB. r wA -> p wA wB -> m (r wB)) + -> r wX -> FL p wX wY -> m (r wY) +foldFL_M _ r NilFL = return r +foldFL_M f r (x :>: xs) = f r x >>= \r' -> foldFL_M f r' xs allFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool allFL f xs = and $ mapFL f xs @@ -351,6 +365,12 @@ anyFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool anyFL f xs = or $ mapFL f xs +allRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool +allRL f xs = and $ mapRL f xs + +anyRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool +anyRL f xs = or $ mapRL f xs + foldlFL :: (forall wW wY . a -> b wW wY -> a) -> a -> FL b wX wZ -> a foldlFL _ x NilFL = x foldlFL f x (y:>:ys) = foldlFL f (f x y) ys @@ -369,6 +389,9 @@ bs <- mapFL_FL_M f as return (b:>:bs) +sequenceFL_ :: Monad m => (forall wW wZ . a wW wZ -> m b) -> FL a wX wY -> m () +sequenceFL_ f = sequence_ . mapFL f + zipWithFL :: (forall wX wY . a -> p wX wY -> q wX wY) -> [a] -> FL p wW wZ -> FL q wW wZ zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys @@ -430,19 +453,38 @@ | otherwise = seal xs -- |Check that two 'FL's are equal element by element. --- This differs from the 'MyEq' instance for 'FL' which +-- This differs from the 'Eq2' instance for 'FL' which -- uses commutation. -eqFL :: MyEq a => FL a wX wY -> FL a wX wZ -> EqCheck wY wZ +eqFL :: Eq2 a => FL a wX wY -> FL a wX wZ -> EqCheck wY wZ eqFL NilFL NilFL = IsEq eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq eqFL _ _ = NotEq -eqFLRev :: MyEq a => FL a wX wZ -> FL a wY wZ -> EqCheck wX wY +eqFLRev :: Eq2 a => FL a wX wZ -> FL a wY wZ -> EqCheck wX wY eqFLRev NilFL NilFL = IsEq eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq eqFLRev _ _ = NotEq -eqFLUnsafe :: MyEq a => FL a wX wY -> FL a wZ wW -> Bool +eqFLUnsafe :: Eq2 a => FL a wX wY -> FL a wZ wW -> Bool eqFLUnsafe NilFL NilFL = True eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys eqFLUnsafe _ _ = False + +infixr 5 +>>+ +infixl 5 +<<+ + +-- | Prepend an 'RL' to an 'FL'. This traverses only the left hand side. +(+>>+) :: RL p wX wY -> FL p wY wZ -> FL p wX wZ +NilRL +>>+ ys = ys +(xs:<:x) +>>+ ys = xs +>>+ (x :>: ys) + +-- | Append an 'FL' to an 'RL'. This traverses only the right hand side. +(+<<+) :: RL p wX wY -> FL p wY wZ -> RL p wX wZ +xs +<<+ NilFL = xs +xs +<<+ (y:>:ys) = (xs:<:y) +<<+ ys + +initsFL :: FL p wX wY -> [Sealed ((p :> FL p) wX)] +initsFL NilFL = [] +initsFL (x :>: xs) = + Sealed (x :> NilFL) : + map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs) diff --git a/src/Darcs/Patch/Witnesses/Sealed.hs b/src/Darcs/Patch/Witnesses/Sealed.hs --- a/src/Darcs/Patch/Witnesses/Sealed.hs +++ b/src/Darcs/Patch/Witnesses/Sealed.hs @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_HADDOCK ignore-exports #-} module Darcs.Patch.Witnesses.Sealed @@ -46,7 +46,7 @@ import Prelude () import Darcs.Prelude -import Darcs.Patch.Witnesses.Eq ( MyEq, EqCheck(..) ) +import Darcs.Patch.Witnesses.Eq ( Eq2, EqCheck(..) ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Eq ( (=\/=) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1, unsafeCoerceP ) @@ -60,7 +60,7 @@ seal :: a wX -> Sealed a seal = Sealed -instance MyEq a => Eq (Sealed (a wX)) where +instance Eq2 a => Eq (Sealed (a wX)) where Sealed x == Sealed y | IsEq <- x =\/= y = True | otherwise = False @@ -139,7 +139,7 @@ -- of the type witnesses. newtype FreeLeft p = FLInternal (Poly (Stepped Sealed p)) --- |'FreeLeft' p is @ \forall y . \exists x . p x y @ +-- |'FreeRight' p is @ \forall y . \exists x . p x y @ -- In other words the caller is free to specify the right witness, -- and then the left witness is an existential. -- Note that the order of the type constructors is important for ensuring diff --git a/src/Darcs/Patch/Witnesses/Show.hs b/src/Darcs/Patch/Witnesses/Show.hs --- a/src/Darcs/Patch/Witnesses/Show.hs +++ b/src/Darcs/Patch/Witnesses/Show.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Darcs.Patch.Witnesses.Show ( ShowDict(..) , showD diff --git a/src/Darcs/Patch/Witnesses/Unsafe.hs b/src/Darcs/Patch/Witnesses/Unsafe.hs --- a/src/Darcs/Patch/Witnesses/Unsafe.hs +++ b/src/Darcs/Patch/Witnesses/Unsafe.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MagicHash #-} module Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP , unsafeCoercePStart @@ -7,19 +6,19 @@ , unsafeCoerceP1 ) where -import GHC.Base (unsafeCoerce#) +import Unsafe.Coerce unsafeCoerceP :: a wX wY -> a wB wC -unsafeCoerceP = unsafeCoerce# +unsafeCoerceP = unsafeCoerce unsafeCoercePStart :: a wX1 wY -> a wX2 wY -unsafeCoercePStart = unsafeCoerce# +unsafeCoercePStart = unsafeCoerce unsafeCoercePEnd :: a wX wY1 -> a wX wY2 -unsafeCoercePEnd = unsafeCoerce# +unsafeCoercePEnd = unsafeCoerce unsafeCoerceP2 :: t wW wX wY wZ -> t wA wB wC wD -unsafeCoerceP2 = unsafeCoerce# +unsafeCoerceP2 = unsafeCoerce unsafeCoerceP1 :: a wX -> a wY -unsafeCoerceP1 = unsafeCoerce# +unsafeCoerceP1 = unsafeCoerce diff --git a/src/Darcs/Patch/Witnesses/WZipper.hs b/src/Darcs/Patch/Witnesses/WZipper.hs --- a/src/Darcs/Patch/Witnesses/WZipper.hs +++ b/src/Darcs/Patch/Witnesses/WZipper.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Patch.Witnesses.WZipper ( FZipper(..) , focus diff --git a/src/Darcs/Prelude.hs b/src/Darcs/Prelude.hs --- a/src/Darcs/Prelude.hs +++ b/src/Darcs/Prelude.hs @@ -2,27 +2,32 @@ -- BSD3 {- -This module abstracts over the differences in the Haskell Prelude over multiple GHC versions, -and also hides some symbols that are exported by the Prelude but clash with common names in -the Darcs code. +This module abstracts over the differences in the Haskell Prelude over +multiple GHC versions, and also hides some symbols that are exported by the +Prelude but clash with common names in the Darcs code. -Broadly it exports everything that the latest Prelude supports, minus the things we explicitly exclude +Broadly it exports everything that the latest Prelude supports, minus the +things we explicitly exclude By default it should be imported with import Prelude () import Darcs.Prelude -If necessary more things can be hidden in the 'Darcs.Prelude' import if they clash with something local, -but consider whether to either hide them globally instead or to choose a different name for the local thing. - -If something is needed from the Prelude that's hidden by default, then add it to the Prelude import. +If necessary more things can be hidden in the 'Darcs.Prelude' import if they +clash with something local, but consider whether to either hide them +globally instead or to choose a different name for the local thing. +If something is needed from the Prelude that's hidden by default, then add +it to the Prelude import. -} module Darcs.Prelude ( module Prelude , module Control.Applicative , module Data.Monoid + , module Data.Semigroup , module Data.Traversable + , module Data.Maybe + , impossible, bug ) where import Prelude hiding @@ -30,12 +35,16 @@ -- because it's a good name for a PatchInfo pi , - -- because they're in the new Prelude but only in Control.Applicative in older GHCs + -- because they're in the new Prelude but only in Control.Applicative + -- in older GHCs Applicative(..), (<$>), (<*>) , -- because it's in the new Prelude but only in Data.Monoid in older GHCs Monoid(..) , + -- because it's in the new Prelude but only in Data.Semigroup in older GHCs + Semigroup(..) + , -- because it's in the new Prelude but only in Data.Traversable in older GHCs traverse , @@ -51,4 +60,13 @@ import Control.Applicative ( Applicative(..), (<$>), (<*>) ) import Data.Monoid ( Monoid(..) ) +import Data.Semigroup ( Semigroup(..) ) import Data.Traversable ( traverse ) +import Data.Maybe ( fromJust ) + +impossible :: a +impossible = error "Impossible case" + +bug :: String -> a +bug str = error ("This is a bug! Please report it at http://darcs.net\n" ++ str) + diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -16,9 +16,13 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables #-} module Darcs.Repository ( Repository + , repoLocation + , repoFormat + , repoPristineType + , repoCache + , PristineType(..) , HashedDir(..) , Cache(..) , CacheLoc(..) @@ -30,7 +34,8 @@ , withRepoLock , withRepoLockCanFail , withRepository - , withRepositoryDirectory + , withRepositoryLocation + , withUMaskFlag , writePatchSet , findRepository , amInRepository @@ -40,7 +45,6 @@ , readRepo , prefsUrl , repoPatchType - , readRepoUsingSpecificInventory , addToPending , addPendingDiffToPending , tentativelyAddPatch @@ -54,8 +58,10 @@ , revertRepositoryChanges , finalizeRepositoryChanges , createRepository + , createRepositoryV1 + , createRepositoryV2 + , EmptyRepository(..) , cloneRepository - , patchSetToRepository , unrevertUrl , applyToWorking , createPristineDirectoryTree @@ -67,7 +73,6 @@ , PatchInfoAnd , setScriptsExecutable , setScriptsExecutablePatches - , checkUnrelatedRepos , testTentative , modifyCache , reportBadSources @@ -75,77 +80,66 @@ , readRecorded , readUnrecorded , unrecordedChanges - , unrecordedChangesWithPatches , filterOutConflicts , readPending , readRecordedAndPending -- * Index. , readIndex , invalidateIndex - -- * Used as command arguments - , listFiles - , listRegisteredFiles - , listUnregisteredFiles ) where -import Prelude () -import Darcs.Prelude - -import Control.Monad ( unless, when ) -import Data.List ( (\\) ) -import System.Exit ( exitSuccess ) - import Darcs.Repository.State ( readRecorded , readUnrecorded , unrecordedChanges - , unrecordedChangesWithPatches - , readPendingAndWorking , readPending , readIndex , invalidateIndex , readRecordedAndPending - , restrictDarcsdir - , restrictBoring - , applyTreeFilter , filterOutConflicts + , addPendingDiffToPending + , addToPending ) -import Darcs.Repository.Internal - ( Repository(..) - , maybeIdentifyRepository +import Darcs.Repository.Prefs ( prefsUrl ) + +import Darcs.Repository.Identify + ( maybeIdentifyRepository , identifyRepositoryFor , findRepository , amInRepository , amNotInRepository , amInHashedRepository - , readRepo + ) +import Darcs.Repository.Hashed + ( readRepo , readTentativeRepo - , readRepoUsingSpecificInventory - , prefsUrl , withRecorded , tentativelyAddPatch , tentativelyRemovePatches - , tentativelyAddToPending , revertRepositoryChanges , finalizeRepositoryChanges , unrevertUrl - , applyToWorking , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory , cleanRepository + ) +import Darcs.Repository.Pending + ( tentativelyAddToPending + ) +import Darcs.Repository.Working + ( applyToWorking , setScriptsExecutable , setScriptsExecutablePatches - , makeNewPending - , repoPatchType ) import Darcs.Repository.Job ( RepoJob(..) , withRepoLock , withRepoLockCanFail , withRepository - , withRepositoryDirectory + , withRepositoryLocation + , withUMaskFlag ) import Darcs.Repository.Rebase ( RebaseJobFlags(..), withManualRebaseUpdate ) import Darcs.Repository.Test ( testTentative ) @@ -158,111 +152,27 @@ , WritableOrNot(..) , reportBadSources ) -import Darcs.Repository.InternalTypes ( modifyCache ) -import Darcs.Repository.Flags - ( DiffAlgorithm (..) - , ScanKnown(..) - , UpdateWorking(..) - , UseCache(..) - , UseIndex(..) +import Darcs.Repository.InternalTypes + ( Repository + , PristineType(..) + , modifyCache + , repoPatchType + , repoLocation + , repoFormat + , repoPristineType + , repoCache ) import Darcs.Repository.Clone - ( createRepository - , cloneRepository + ( cloneRepository , replacePristine , writePatchSet - , patchSetToRepository ) +import Darcs.Repository.Create + ( createRepository + , createRepositoryV1 + , createRepositoryV2 + , EmptyRepository(..) + ) -import Darcs.Patch ( RepoPatch - , PrimOf - ) -import Darcs.Patch.Set ( PatchSet(..) - , SealedPatchSet - ) -import Darcs.Patch.Commute( commuteFL ) -import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) +import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) -import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FreeLeft, unFreeLeft ) -import Darcs.Patch.Witnesses.Ordered - ( (:>)(..) - , reverseRL - , reverseFL - , FL(..) - , (+>+) - ) -import Darcs.Patch.Depends ( areUnrelatedRepos ) - -import Darcs.Util.Prompt ( promptYorn ) -import Darcs.Util.Path( anchorPath ) - -import Darcs.Util.Tree( Tree, emptyTree, expand, list ) -import Darcs.Util.Tree.Plain( readPlainTree ) - -checkUnrelatedRepos :: RepoPatch p - => Bool - -> PatchSet rt p wStart wX - -> PatchSet rt p wStart wY - -> IO () -checkUnrelatedRepos allowUnrelatedRepos us them = - when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $ - do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?" - unless confirmed $ do putStrLn "Cancelled." - exitSuccess - --- | Add an FL of patches started from the pending state to the pending patch. --- TODO: add witnesses for pending so we can make the types precise: currently --- the passed patch can be applied in any context, not just after pending. -addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository rt p wR wU wT -> UpdateWorking - -> FreeLeft (FL (PrimOf p)) -> IO () -addPendingDiffToPending _ NoUpdateWorking _ = return () -addPendingDiffToPending repo@(Repo{}) uw@YesUpdateWorking newP = do - (toPend :> _) <- - readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing - invalidateIndex repo - case unFreeLeft newP of - (Sealed p) -> makeNewPending repo uw $ toPend +>+ p - --- | Add a FL of patches starting from the working state to the pending patch, --- including as much extra context as is necessary (context meaning --- dependencies), by commuting the patches to be added past as much of the --- changes between pending and working as is possible, and including anything --- that doesn't commute, and the patch itself in the new pending patch. -addToPending :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository rt p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO () -addToPending _ NoUpdateWorking _ = return () -addToPending repo@(Repo{}) uw@YesUpdateWorking p = do - (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing - invalidateIndex repo - case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of - (toP' :> p' :> _excessUnrec) -> - makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p' - --- | Get a list of all files and directories in the working copy, including --- boring files if necessary -listFiles :: Bool -> IO [String] -listFiles takeBoring = - do - nonboring <- considered emptyTree - working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "." - return $ map (anchorPath "" . fst) $ list working - where - considered = if takeBoring - then const (return restrictDarcsdir) - else restrictBoring - --- | 'listUnregisteredFiles' returns the list of all non-boring unregistered --- files in the repository. -listUnregisteredFiles :: Bool -> IO [String] -listUnregisteredFiles includeBoring = - do unregd <- listFiles includeBoring - regd <- listRegisteredFiles - return $ unregd \\ regd -- (inefficient) - --- | 'listRegisteredFiles' returns the list of all registered files in the repository. -listRegisteredFiles :: IO [String] -listRegisteredFiles = - do recorded <- expand =<< withRepository YesUseCache (RepoJob readRecordedAndPending) - return $ map (anchorPath "" . fst) $ list recorded 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 @@ -47,7 +47,7 @@ import Darcs.Util.Exception ( prettyException ) import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) -import Darcs.Util.Printer ( hPutDocLn, RenderMode(..) ) +import Darcs.Util.Printer ( hPutDocLn ) import Darcs.Util.Printer.Color ( showDoc ) import Darcs.Util.External ( backupByCopying, backupByRenaming ) import Darcs.Util.Path ( FileName, fn2fp ) @@ -66,9 +66,9 @@ mapM_ go items endTedious what where go item = - do finishedOneIO what (showDoc Encode $ paMessage item) + do finishedOneIO what (showDoc $ paMessage item) runDefaultIO (paAction item) `catch` \e -> - do hPutDocLn Encode stderr $ paOnError item + do hPutDocLn stderr $ paOnError item ioError e instance ApplyMonad Tree DefaultIO where 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 @@ -1,9 +1,6 @@ -{-# LANGUAGE CPP #-} - module Darcs.Repository.Cache ( cacheHash , okayHash - , takeHash , Cache(..) , CacheType(..) , CacheLoc(..) @@ -29,11 +26,10 @@ , reportBadSources ) where -import Control.Monad ( liftM, when, guard, unless, filterM, forM_, mplus ) -import qualified Data.ByteString as B (length, drop, ByteString ) -import qualified Data.ByteString.Char8 as BC (unpack) +import Control.Monad ( liftM, when, unless, filterM, forM_, mplus ) +import qualified Data.ByteString as B (length, ByteString ) import Data.List ( nub, intercalate ) -import Data.Maybe ( catMaybes, listToMaybe, fromMaybe ) +import Data.Maybe ( catMaybes, fromMaybe ) import System.FilePath.Posix ( (), joinPath, dropFileName ) import System.Directory ( createDirectoryIfMissing, removeFile, doesFileExist, doesDirectoryExist, getDirectoryContents, @@ -42,7 +38,7 @@ import System.IO ( hPutStrLn, stderr ) import System.Posix.Files ( createLink, linkCount, getSymbolicLinkStatus ) -import Darcs.Util.ByteString ( gzWriteFilePS, linesPS ) +import Darcs.Util.ByteString ( gzWriteFilePS ) import Darcs.Util.Global ( darcsdir, addBadSource, isBadSource, addReachableSource, isReachableSource, getBadSourcesList, defaultRemoteDarcsCmd ) import Darcs.Util.External ( gzFetchFilePS, fetchFilePS @@ -54,8 +50,7 @@ import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl ) import Darcs.Util.File ( withCurrentDirectory ) -import Darcs.Util.Crypt.SHA1 ( sha1PS ) -import Darcs.Util.Crypt.SHA256 ( sha256sum ) +import Darcs.Util.Hash ( sha256sum ) import Darcs.Util.English ( englishNum, Noun(..), Pronoun(..) ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Progress ( progressList, debugMessage, debugFail ) @@ -178,18 +173,10 @@ shaOfPs = sha256sum ps okayHash :: String -> Bool -okayHash s = length s `elem` [40, 64, 75] - -takeHash :: B.ByteString -> Maybe (String, B.ByteString) -takeHash ps = do - h <- listToMaybe $ linesPS ps - let v = BC.unpack h - guard $ okayHash v - return (v, B.drop (B.length h) ps) +okayHash s = length s `elem` [64, 75] checkHash :: String -> B.ByteString -> Bool checkHash h s - | length h == 40 = (show $ sha1PS s) == h | length h == 64 = sha256sum s == h | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h diff --git a/src/Darcs/Repository/Clone.hs b/src/Darcs/Repository/Clone.hs --- a/src/Darcs/Repository/Clone.hs +++ b/src/Darcs/Repository/Clone.hs @@ -1,53 +1,53 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} module Darcs.Repository.Clone - ( createRepository - , cloneRepository + ( cloneRepository , replacePristine , writePatchSet - , patchSetToRepository ) where import Prelude () import Darcs.Prelude import Control.Exception ( catch, SomeException ) -import Control.Monad ( when, void ) -import qualified Data.ByteString.Char8 as BS +import Control.Monad ( when ) +import qualified Data.ByteString.Char8 as BC import Data.List( intercalate ) -import Data.Maybe( catMaybes, isJust ) +import Data.Maybe( catMaybes ) import System.FilePath( () ) import System.Directory - ( createDirectory - , removeFile + ( removeFile , getDirectoryContents - , getCurrentDirectory - , setCurrentDirectory ) import System.IO ( stderr ) -import System.IO.Error ( isAlreadyExistsError ) -import Darcs.Repository.State ( invalidateIndex, readWorking ) - -import Darcs.Repository.Internal - ( Repository(..) - , IdentifyRepo(..) +import Darcs.Repository.Create + ( EmptyRepository(..) + , createRepository + , writePristine + ) +import Darcs.Repository.State ( invalidateIndex ) +import Darcs.Repository.Pending ( tentativelyAddToPending ) +import Darcs.Repository.Identify + ( IdentifyRepo(..) , identifyRepositoryFor - , identifyRepository - , maybeIdentifyRepository - , readRepo + , maybeIdentifyRepository ) +import Darcs.Repository.Hashed + ( readRepo , tentativelyRemovePatches - , tentativelyAddToPending , finalizeRepositoryChanges , createPristineDirectoryTree - , setScriptsExecutable - , setScriptsExecutablePatches - , seekRepo - , repoPatchType , revertRepositoryChanges ) +import Darcs.Repository.Working + ( setScriptsExecutable + , setScriptsExecutablePatches ) import Darcs.Repository.InternalTypes - ( modifyCache ) -import Darcs.Repository.Job ( RepoJob(..), withRepoLock, withRepository ) + ( Repository + , repoLocation + , repoFormat + , repoCache + , modifyCache + , repoPatchType ) +import Darcs.Repository.Job ( withUMaskFlag ) import Darcs.Repository.Cache ( unionRemoteCaches , unionCaches @@ -60,22 +60,19 @@ ) import qualified Darcs.Repository.Cache as DarcsCache -import qualified Darcs.Repository.HashedRepo as HashedRepo -import Darcs.Repository.ApplyPatches ( applyPatches, runDefault ) -import Darcs.Repository.HashedRepo - ( applyToTentativePristine - , pris2inv - , inv2pris +import qualified Darcs.Repository.Hashed as HashedRepo +import Darcs.Repository.ApplyPatches ( runDefault ) +import Darcs.Repository.Hashed + ( applyToTentativePristineCwd + , peekPristineHash ) import Darcs.Repository.Format ( RepoProperty ( HashedInventory, Darcs2 ) , RepoFormat - , createRepoFormat , formatHas - , writeRepoFormat , readProblem ) -import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources ) +import Darcs.Repository.Prefs ( addRepoSource, deleteSources ) import Darcs.Repository.Match ( getOnePatchset ) import Darcs.Util.External ( copyFileOrUrl @@ -83,8 +80,7 @@ , gzFetchFilePS ) import Darcs.Repository.PatchIndex - ( createOrUpdatePatchIndexDisk - , doesPatchIndexExist + ( doesPatchIndexExist , createPIWithInterrupt ) import Darcs.Repository.Packs @@ -92,11 +88,7 @@ , fetchAndUnpackPatches , packsDir ) -import Darcs.Util.Lock - ( writeBinFile - , writeDocBinFile - , appendBinFile - ) +import Darcs.Util.Lock ( appendTextFile, withNewDirectory ) import Darcs.Repository.Flags ( UpdateWorking(..) , UseCache(..) @@ -116,12 +108,12 @@ , PatchFormat (..) ) -import Darcs.Patch ( RepoPatch, IsRepoType, apply, invert, effect, PrimOf ) +import Darcs.Patch ( RepoPatch, IsRepoType, apply, invert, effect ) import Darcs.Patch.Depends ( findCommonWithThem, countUsThem ) import Darcs.Patch.Set ( Origin - , PatchSet(..) - , newset2RL - , newset2FL + , PatchSet + , patchSet2RL + , patchSet2FL , progressPatchSet ) import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch ) @@ -140,19 +132,15 @@ ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully ) -import Darcs.Util.Hash( encodeBase16 ) import Darcs.Util.Tree( Tree, emptyTree ) -import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes ) -import Darcs.Util.ByteString( gzReadFilePS ) import Darcs.Util.Download ( maxPipelineLength ) import Darcs.Util.Exception ( catchall ) -import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.SignalHandler ( catchInterrupt ) -import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) ) +import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc ) import Darcs.Util.Progress ( debugMessage , tediousSize @@ -160,31 +148,6 @@ , endTedious ) -#include "impossible.h" - -createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> IO () -createRepository patchfmt withWorkingDir createPatchIndex = do - createDirectory darcsdir `catch` - (\e-> if isAlreadyExistsError e - then fail "Tree has already been initialized!" - else fail $ "Error creating directory `"++darcsdir++"'.") - cwd <- getCurrentDirectory - x <- seekRepo - when (isJust x) $ do - setCurrentDirectory cwd - putStrLn "WARNING: creating a nested repository." - createDirectory $ darcsdir "pristine.hashed" - createDirectory $ darcsdir "patches" - createDirectory $ darcsdir "inventories" - createDirectory $ darcsdir "prefs" - writeDefaultPrefs - writeRepoFormat (createRepoFormat patchfmt withWorkingDir) (darcsdir "format") - writeBinFile (darcsdir "hashed_inventory") "" - writePristine "." emptyTree - withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of - NoPatchIndex -> return () -- default - YesPatchIndex -> createOrUpdatePatchIndexDisk repo - joinUrl :: [String] -> String joinUrl = intercalate "/" @@ -203,41 +166,45 @@ -> Bool -- use packs -> ForgetParent -> IO () -cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos - setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks forget = do - createDirectory mysimplename - setCurrentDirectory mysimplename - createRepository (if formatHas Darcs2 rfsource then PatchFormat2 else PatchFormat1) - withWorkingDir - (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) - debugMessage "Finished initializing new repository." - addRepoSource repodir NoDryRun remoteRepos setDefault +cloneRepository repodir mysimplename v useCache cloneKind um rdarcs sse remoteRepos + setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks + forget = + withUMaskFlag um $ withNewDirectory mysimplename $ do + let patchfmt = if formatHas Darcs2 rfsource then PatchFormat2 else PatchFormat1 + EmptyRepository toRepo' <- + createRepository patchfmt withWorkingDir + (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) useCache + debugMessage "Finished initializing new repository." + addRepoSource repodir NoDryRun remoteRepos setDefault - debugMessage "Grabbing lock in new repository." - withRepoLock NoDryRun uc YesUpdateWorking um - $ RepoJob $ \repository -> do debugMessage "Identifying and copying repository..." - fromRepo@(Repo fromDir rffrom _ fromCache) <- identifyRepositoryFor repository uc repodir + fromRepo <- identifyRepositoryFor toRepo' useCache repodir + let fromLoc = repoLocation fromRepo + let rffrom = repoFormat fromRepo case readProblem rffrom of - Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e + Just e -> fail $ "Incompatibility with repository " ++ fromLoc ++ ":\n" ++ e Nothing -> return () - debugMessage "Copying prefs" - copyFileOrUrl (remoteDarcs rdarcs) (joinUrl [fromDir, darcsdir, "prefs", "prefs"]) + debugMessage "Copying prefs..." + copyFileOrUrl (remoteDarcs rdarcs) + (joinUrl [fromLoc, darcsdir, "prefs", "prefs"]) (darcsdir "prefs/prefs") (MaxAge 600) `catchall` return () - -- prepare sources and cache - (Repo toDir toFormat toPristine toCache) <- identifyRepository uc "." - toCache2 <- unionRemoteCaches toCache fromCache fromDir - toRepo <- copySources (Repo toDir toFormat toPristine toCache2) fromDir + debugMessage "Copying sources..." + cache <- unionRemoteCaches (repoCache toRepo') (repoCache fromRepo) fromLoc + appendTextFile (darcsdir "prefs/sources") + (show $ repo2cache fromLoc `unionCaches` dropNonRepos cache) + debugMessage "Done copying and filtering sources." + -- put remote source last + let toRepo = modifyCache toRepo' (const $ cache `unionCaches` repo2cache fromLoc) if formatHas HashedInventory rffrom then do -- copying basic repository (hashed_inventory and pristine) - if usePacks && (not . isValidLocalPath) fromDir + if usePacks && (not . isValidLocalPath) fromLoc then copyBasicRepoPacked fromRepo toRepo v rdarcs withWorkingDir else copyBasicRepoNotPacked fromRepo toRepo v rdarcs withWorkingDir when (cloneKind /= LazyClone) $ do when (cloneKind /= CompleteClone) $ putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..." -- copying complete repository (inventories and patches) - if usePacks && (not . isValidLocalPath) fromDir + if usePacks && (not . isValidLocalPath) fromLoc then copyCompleteRepoPacked fromRepo toRepo v cloneKind else copyCompleteRepoNotPacked fromRepo toRepo v cloneKind else @@ -245,8 +212,8 @@ -- we need to copy all patches first and then build pristine copyRepoOldFashioned fromRepo toRepo v withWorkingDir when (sse == YesSetScriptsExecutable) setScriptsExecutable - when (havePatchsetMatch (repoPatchType repository) matchFlags) $ do - putStrLn "Going to specified version..." + when (havePatchsetMatch (repoPatchType toRepo) matchFlags) $ do + putInfo v $ text "Going to specified version..." -- the following is necessary to be able to read repo's patches revertRepositoryChanges toRepo YesUpdateWorking patches <- readRepo toRepo @@ -266,24 +233,33 @@ when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps) when (forget == YesForgetParent) deleteSources +-- | This keeps only NonWritable Repo entries. +dropNonRepos :: Cache -> Cache +dropNonRepos (Ca cache) = Ca $ filter notRepo cache where + notRepo xs = case xs of + Cache DarcsCache.Directory _ _ -> False + -- we don't want to write thisrepo: entries to the disk + Cache DarcsCache.Repo DarcsCache.Writable _ -> False + _ -> True + putInfo :: Verbosity -> Doc -> IO () putInfo Quiet _ = return () -putInfo _ d = hPutDocLn Encode stderr d +putInfo _ d = hPutDocLn stderr d putVerbose :: Verbosity -> Doc -> IO () putVerbose Verbose d = putDocLn d putVerbose _ _ = return () -copyBasicRepoNotPacked :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -- remote +copyBasicRepoNotPacked :: forall rt p wR wU wT. + Repository rt p wR wU wT -- remote -> Repository rt p wR wU wT -- existing empty local -> Verbosity -> RemoteDarcs -> WithWorkingDir -> IO () -copyBasicRepoNotPacked (Repo fromDir _ _ _) toRepo verb rdarcs withWorkingDir = do +copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir = do putVerbose verb $ text "Copying hashed inventory from remote repo..." - HashedRepo.copyHashedInventory toRepo rdarcs fromDir + HashedRepo.copyHashedInventory toRepo rdarcs (repoLocation fromRepo) putVerbose verb $ text "Writing pristine and working directory contents..." createPristineDirectoryTree toRepo "." withWorkingDir @@ -293,31 +269,33 @@ -> Verbosity -> CloneKind -> IO () -copyCompleteRepoNotPacked _ torepository@(Repo todir _ _ _) verb cloneKind = do +copyCompleteRepoNotPacked _ toRepo verb cloneKind = do let cleanup = putInfo verb $ text "Using lazy repository." allowCtrlC cloneKind cleanup $ do - fetchPatchesIfNecessary torepository - pi <- doesPatchIndexExist todir - when pi $ createPIWithInterrupt torepository + fetchPatchesIfNecessary toRepo + pi <- doesPatchIndexExist (repoLocation toRepo) + ps <- readRepo toRepo + when pi $ createPIWithInterrupt toRepo ps copyBasicRepoPacked :: - forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => Repository rt p wR wU wT -- remote + forall rt p wR wU wT. + Repository rt p wR wU wT -- remote -> Repository rt p wR wU wT -- existing empty local repository -> Verbosity -> RemoteDarcs -> WithWorkingDir -> IO () -copyBasicRepoPacked r@(Repo fromDir _ _ _) toRepo verb rdarcs withWorkingDir = - do let hashURL = joinUrl [fromDir, darcsdir, packsDir, "pristine"] +copyBasicRepoPacked fromRepo toRepo verb rdarcs withWorkingDir = + do let fromLoc = repoLocation fromRepo + let hashURL = joinUrl [fromLoc, darcsdir, packsDir, "pristine"] mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing) - let hiURL = joinUrl [fromDir, darcsdir, "hashed_inventory"] + let hiURL = joinUrl [fromLoc, darcsdir, "hashed_inventory"] i <- gzFetchFilePS hiURL Uncachable - let currentHash = BS.pack $ inv2pris i - let copyNormally = copyBasicRepoNotPacked r toRepo verb rdarcs withWorkingDir + let currentHash = BC.pack $ peekPristineHash i + let copyNormally = copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir case mPackHash of Just packHash | packHash == currentHash - -> ( copyBasicRepoPacked2 r toRepo verb withWorkingDir + -> ( copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir `catch` \(e :: SomeException) -> do putStrLn ("Exception while getting basic pack:\n" ++ show e) copyNormally) @@ -325,53 +303,53 @@ copyNormally copyBasicRepoPacked2 :: - forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => Repository rt p wR wU wT -- remote + forall rt p wR wU wT. + Repository rt p wR wU wT -- remote -> Repository rt p wR wU wT -- existing empty local repository -> Verbosity -> WithWorkingDir -> IO () -copyBasicRepoPacked2 (Repo fromDir _ _ _) toRepo@(Repo _ _ _ toCache) verb withWorkingDir = do +copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir = do putVerbose verb $ text "Cloning packed basic repository." -- unpack inventory & pristine cache cleanDir $ darcsdir "pristine.hashed" removeFile $ darcsdir "hashed_inventory" - fetchAndUnpackBasic toCache fromDir + fetchAndUnpackBasic (repoCache toRepo) (repoLocation fromRepo) putInfo verb $ text "Done fetching and unpacking basic pack." createPristineDirectoryTree toRepo "." withWorkingDir copyCompleteRepoPacked :: - forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -- remote -> Repository rt p wR wU wT -- existing basic local repository -> Verbosity -> CloneKind -> IO () -copyCompleteRepoPacked r to verb cloneKind = - ( copyCompleteRepoPacked2 r to verb cloneKind - `catch` \(e :: SomeException) -> - do putStrLn ("Exception while getting patches pack:\n" ++ show e) - putVerbose verb $ text "Problem while copying patches pack, copying normally." - copyCompleteRepoNotPacked r to verb cloneKind ) +copyCompleteRepoPacked from to verb cloneKind = + copyCompleteRepoPacked2 from to verb cloneKind + `catch` + \(e :: SomeException) -> do + putStrLn ("Exception while getting patches pack:\n" ++ show e) + putVerbose verb $ text "Problem while copying patches pack, copying normally." + copyCompleteRepoNotPacked from to verb cloneKind copyCompleteRepoPacked2 :: - forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO () -copyCompleteRepoPacked2 (Repo fromDir _ _ _) - toRepo@(Repo toDir _ _ toCache) - verb cloneKind = do +copyCompleteRepoPacked2 fromRepo toRepo verb cloneKind = do us <- readRepo toRepo -- get old patches let cleanup = putInfo verb $ text "Using lazy repository." allowCtrlC cloneKind cleanup $ do putVerbose verb $ text "Using patches pack." - fetchAndUnpackPatches (mapRL hashedPatchFileName $ newset2RL us) toCache fromDir - pi <- doesPatchIndexExist toDir - when pi $ createPIWithInterrupt toRepo + fetchAndUnpackPatches (mapRL hashedPatchFileName $ patchSet2RL us) + (repoCache toRepo) (repoLocation fromRepo) + pi <- doesPatchIndexExist (repoLocation toRepo) + when pi $ createPIWithInterrupt toRepo us -- TODO or do another readRepo? cleanDir :: FilePath -> IO () cleanDir d = mapM_ (\x -> removeFile $ d x) . @@ -383,35 +361,35 @@ -> Verbosity -> WithWorkingDir -> IO () -copyRepoOldFashioned fromrepository toRepo@(Repo _ _ _ toCache) verb withWorkingDir = do +copyRepoOldFashioned fromrepository toRepo verb withWorkingDir = do HashedRepo.revertTentativeChanges patches <- readRepo fromrepository let k = "Copying patch" beginTedious k - tediousSize k (lengthRL $ newset2RL patches) + tediousSize k (lengthRL $ patchSet2RL patches) let patches' = progressPatchSet k patches - HashedRepo.writeTentativeInventory toCache GzipCompression patches' + HashedRepo.writeTentativeInventory (repoCache toRepo) GzipCompression patches' endTedious k HashedRepo.finalizeTentativeChanges toRepo GzipCompression -- apply all patches into current hashed repository HashedRepo.revertTentativeChanges local_patches <- readRepo toRepo replacePristine toRepo emptyTree - let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches - sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply + let patchesToApply = progressFL "Applying patch" $ patchSet2FL local_patches + sequence_ $ mapFL applyToTentativePristineCwd $ bunchFL 100 patchesToApply finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression putVerbose verb $ text "Writing pristine and working directory contents..." createPristineDirectoryTree toRepo "." withWorkingDir -- | This function fetches all patches that the given repository has -- with fetchFileUsingCache, unless --lazy is passed. -fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT -> IO () -fetchPatchesIfNecessary torepository@(Repo _ _ _ c) = - do r <- readRepo torepository +fetchPatchesIfNecessary toRepo = + do ps <- readRepo toRepo pipelineLength <- maxPipelineLength - let patches = newset2RL r + let patches = patchSet2RL ps ppatches = progressRLShowTags "Copying patches" patches (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches speculate | pipelineLength > 1 = [] : first : map (:[]) other @@ -423,56 +401,54 @@ fetchAndSpeculate (f, ss) = do _ <- fetchFileUsingCache c HashedPatchesDir f mapM_ (speculateFileUsingCache c HashedPatchesDir) ss + c = repoCache toRepo +{- -- | patchSetToRepository takes a patch set, and writes a new repository -- in the current directory that contains all the patches in the patch -- set. This function is used when 'darcs get'ing a repository with -- the --to-match flag. +-- bf: no it is not used anywhere patchSetToRepository :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR1 wU1 wR1 -> PatchSet rt p Origin wX -> UseCache -> RemoteDarcs -> IO () -patchSetToRepository (Repo fromrepo rf _ _) patchset useCache rDarcs = do - when (formatHas HashedInventory rf) $ -- set up sources and all that +patchSetToRepository fromRepo patchset useCache rDarcs = do + when (formatHas HashedInventory (repoFormat fromRepo)) $ + -- set up sources and all that do writeFile (darcsdir "tentative_pristine") "" -- this is hokey repox <- writePatchSet patchset useCache - HashedRepo.copyHashedInventory repox rDarcs fromrepo - void $ copySources repox fromrepo - repo@(Repo dir _ _ _) <- writePatchSet patchset useCache - readRepo repo >>= (runDefault . applyPatches . newset2FL) + let fromLoc = repoLocation fromRepo + HashedRepo.copyHashedInventory repox rDarcs fromLoc + void $ copySources repox fromLoc + repo <- writePatchSet patchset useCache + readRepo repo >>= (runDefault . applyPatches . patchSet2FL) debugMessage "Writing the pristine" - withCurrentDirectory dir $ readWorking >>= replacePristine repo + withRepoLocation repo $ readWorking >>= replacePristine repo +-} -- | writePatchSet is like patchSetToRepository, except that it doesn't -- touch the working directory or pristine cache. -writePatchSet :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +writePatchSet :: (IsRepoType rt, RepoPatch p) => PatchSet rt p Origin wX -> UseCache -> IO (Repository rt p wR wU wT) writePatchSet patchset useCache = do maybeRepo <- maybeIdentifyRepository useCache "." - let repo@(Repo _ _ _ c) = + let repo = case maybeRepo of GoodRepository r -> r BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e) NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e) debugMessage "Writing inventory" - HashedRepo.writeTentativeInventory c GzipCompression patchset + HashedRepo.writeTentativeInventory (repoCache repo) GzipCompression patchset HashedRepo.finalizeTentativeChanges repo GzipCompression return repo -- | Replace the existing pristine with a new one (loaded up in a Tree object). replacePristine :: Repository rt p wR wU wT -> Tree IO -> IO () -replacePristine (Repo r _ _ _) = writePristine r - -writePristine :: FilePath -> Tree IO -> IO () -writePristine r tree = withCurrentDirectory r $ - do let t = darcsdir "hashed_inventory" - i <- gzReadFilePS t - tree' <- darcsAddMissingHashes tree - root <- writeDarcsHashed tree' $ darcsdir "pristine.hashed" - writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i +replacePristine = writePristine . repoLocation allowCtrlC :: CloneKind -> IO () -> IO () -> IO () allowCtrlC CompleteClone _ action = action @@ -482,30 +458,3 @@ hashedPatchFileName x = case extractHash x of Left _ -> fail "unexpected unhashed patch" Right h -> h - --- |'copySources' does two things: --- * it copies the prefs/sources file to the local repo, from the --- remote, having first filtered the local filesystem sources. --- * it returns the original list of sources of the local repo --- updated with the remote repo as an additional source -copySources :: RepoPatch p - => Repository rt p wR wU wT - -> String - -> IO (Repository rt p wR wU wT) -copySources repo@(Repo outr _ _ cache0) inr = do - let (Repo s f p newCache1) = modifyCache repo dropNonRepos - let sourcesToWrite = repo2cache inr `unionCaches` newCache1 - appendBinFile (outr ++ "/" ++ darcsdir ++ "/prefs/sources") - (show sourcesToWrite) - debugMessage "Done copying and filtering pref/sources." - - -- put remote source last: - let newSources = cache0 `unionCaches` repo2cache inr - return (Repo s f p newSources) - where - dropNonRepos (Ca cache) = Ca $ filter notRepo cache - notRepo xs = case xs of - Cache DarcsCache.Directory _ _ -> False - -- we don't want to write thisrepo: entries to the disk - Cache DarcsCache.Repo DarcsCache.Writable _ -> False - _ -> True diff --git a/src/Darcs/Repository/Create.hs b/src/Darcs/Repository/Create.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Create.hs @@ -0,0 +1,165 @@ +module Darcs.Repository.Create + ( createRepository + , createRepositoryV1 + , createRepositoryV2 + , EmptyRepository(..) + , writePristine + ) where + +import Prelude () +import Darcs.Prelude + +import Control.Monad ( when ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Maybe( isJust ) +import System.Directory + ( createDirectory + , getCurrentDirectory + , setCurrentDirectory + ) +import System.FilePath ( () ) +import System.IO.Error + ( catchIOError + , isAlreadyExistsError + ) + +import Darcs.Patch ( RepoPatch ) +import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) +import Darcs.Patch.Set ( Origin, emptyPatchSet ) +import Darcs.Patch.V1 ( RepoPatchV1 ) +import Darcs.Patch.V2 ( RepoPatchV2 ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) + +import Darcs.Repository.Cache ( Cache ) +import Darcs.Repository.Format + ( RepoFormat + , createRepoFormat + , writeRepoFormat + ) +import Darcs.Repository.Flags + ( UseCache(..) + , WithWorkingDir (..) + , WithPatchIndex (..) + , PatchFormat (..) + ) +import Darcs.Repository.Hashed + ( pokePristineHash + , pristineDirPath + , patchesDirPath + , inventoriesDirPath + , hashedInventoryPath + ) +import Darcs.Repository.Identify ( seekRepo ) +import Darcs.Repository.InternalTypes + ( Repository + , PristineType(..) + , mkRepo + ) +import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk ) +import Darcs.Repository.Prefs + ( writeDefaultPrefs + , getCaches + , prefsDirPath + ) + +import Darcs.Util.ByteString( gzReadFilePS ) +import Darcs.Util.File ( withCurrentDirectory ) +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Hash( encodeBase16 ) +import Darcs.Util.Lock + ( writeBinFile + , writeDocBinFile + ) +import Darcs.Util.Tree( Tree, emptyTree ) +import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes ) + +createRepositoryFiles :: PatchFormat -> WithWorkingDir -> IO RepoFormat +createRepositoryFiles patchfmt withWorkingDir = do + cwd <- getCurrentDirectory + x <- seekRepo + when (isJust x) $ do + setCurrentDirectory cwd + putStrLn "WARNING: creating a nested repository." + createDirectory darcsdir `catchIOError` + (\e-> if isAlreadyExistsError e + then fail "Tree has already been initialized!" + else fail $ "Error creating directory `"++darcsdir++"'.") + createDirectory pristineDirPath + createDirectory patchesDirPath + createDirectory inventoriesDirPath + createDirectory prefsDirPath + writeDefaultPrefs + let repo_format = createRepoFormat patchfmt withWorkingDir + writeRepoFormat repo_format (darcsdir "format") + -- note: all repos we create nowadays are hashed + writeBinFile hashedInventoryPath B.empty + writePristine here emptyTree + return repo_format + +data EmptyRepository where + EmptyRepository :: (RepoPatch p, ApplyState p ~ Tree) + => Repository ('RepoType 'NoRebase) p Origin Origin Origin + -> EmptyRepository + +createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> UseCache + -> IO EmptyRepository +createRepository patchfmt withWorkingDir withPatchIndex useCache = do + rfmt <- createRepositoryFiles patchfmt withWorkingDir + cache <- getCaches useCache here + repo@(EmptyRepository r) <- case patchfmt of + PatchFormat1 -> return $ EmptyRepository $ mkRepoV1 rfmt cache + PatchFormat2 -> return $ EmptyRepository $ mkRepoV2 rfmt cache + maybeCreatePatchIndex withPatchIndex r + return repo + +mkRepoV1 + :: RepoFormat + -> Cache + -> Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin +mkRepoV1 repofmt cache = mkRepo "." repofmt HashedPristine cache + +mkRepoV2 + :: RepoFormat + -> Cache + -> Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin +mkRepoV2 repofmt cache = mkRepo "." repofmt HashedPristine cache + +createRepositoryV1 + :: WithWorkingDir -> WithPatchIndex -> UseCache + -> IO (Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin) +createRepositoryV1 withWorkingDir withPatchIndex useCache = do + rfmt <- createRepositoryFiles PatchFormat1 withWorkingDir + cache <- getCaches useCache here + let repo = mkRepoV1 rfmt cache + maybeCreatePatchIndex withPatchIndex repo + return repo + +createRepositoryV2 + :: WithWorkingDir -> WithPatchIndex -> UseCache + -> IO (Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin) +createRepositoryV2 withWorkingDir withPatchIndex useCache = do + rfmt <- createRepositoryFiles PatchFormat2 withWorkingDir + cache <- getCaches useCache here + let repo = mkRepoV2 rfmt cache + maybeCreatePatchIndex withPatchIndex repo + return repo + +maybeCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) + => WithPatchIndex -> Repository rt p Origin wU Origin -> IO () +maybeCreatePatchIndex NoPatchIndex _ = return () +maybeCreatePatchIndex YesPatchIndex repo = + createOrUpdatePatchIndexDisk repo emptyPatchSet + +writePristine :: FilePath -> Tree IO -> IO () +writePristine dir tree = + withCurrentDirectory dir $ do + inv <- gzReadFilePS hashedInventoryPath + tree' <- darcsAddMissingHashes tree + root <- writeDarcsHashed tree' pristineDirPath + writeDocBinFile hashedInventoryPath $ pokePristineHash (BC.unpack $ encodeBase16 root) inv + +here :: String +here = "." diff --git a/src/Darcs/Repository/Diff.hs b/src/Darcs/Repository/Diff.hs --- a/src/Darcs/Repository/Diff.hs +++ b/src/Darcs/Repository/Diff.hs @@ -28,7 +28,6 @@ -- Stability : experimental -- Portability : portable -{-# LANGUAGE CPP #-} module Darcs.Repository.Diff ( treeDiff @@ -38,7 +37,7 @@ import Darcs.Prelude import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.ByteString as BS +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.List ( sortBy ) @@ -69,9 +68,6 @@ import Darcs.Patch.Witnesses.Sealed ( Gap(..) ) import Darcs.Repository.Flags ( DiffAlgorithm(..) ) -#include "impossible.h" - - data Diff m = Added (TreeItem m) | Removed (TreeItem m) | Changed (TreeItem m) (TreeItem m) @@ -87,7 +83,7 @@ getDiff _ Nothing Nothing = impossible -- zipTrees should never return this -treeDiff :: forall m w prim . (Functor m, Monad m, Gap w, PrimPatch prim) +treeDiff :: forall m w prim . (Monad m, Gap w, PrimPatch prim) => DiffAlgorithm -> (FilePath -> FileType) -> Tree m @@ -148,12 +144,40 @@ | BL.null a && BL.null b = emptyGap NilFL | BL.null a = freeGap (diff_from_empty p b) | BL.null b = freeGap (diff_to_empty p a) + + -- What is 'a line'? One view is that a line is something that is + -- /terminated/ by either a newline or end of file. Another view is + -- that lines are /separated/ by newline symbols. + -- + -- The first view is the more "intuitive" one. The second is more + -- "technical", it has the simpler definition and the highly desirable + -- property that splitting a text into lines and joining them with + -- newline symbols are inverse operations. The last point is the reason + -- we never use the standard versions of 'unlines' for ByteString + -- anywhere in darcs. + -- + -- The two views differ mostly when enumerating the lines of a file + -- that ends with a newline symbol: here, the technical view counts one + -- more (empty) line. This leads to un-intuitive (though technically + -- not incorrect) results when calculating the diff for a change that + -- appends an empty line to a file that already has a newline at the + -- end. For instance, for a file with a single, newline-terminated line + -- of text, the LCS algorithm would tell us that a *third* (empty) line + -- is being added. + -- + -- To avoid this, we add a special case here: we strip off common + -- newline symbols at the end. When we later split the result into + -- lines for the diff algorithm, it never gets to see the empty + -- last lines in both files and thus gives us the more intuitive result. + + | BLC.last a == '\n' && BLC.last b == '\n' + = freeGap (line_diff p (linesB $ BLC.init a) (linesB $ BLC.init b)) | otherwise = freeGap (line_diff p (linesB a) (linesB b)) line_diff p a b = canonize da (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] + | otherwise = line_diff p (linesB x) [B.empty] diff_from_empty p x = invert (diff_to_empty p x) @@ -161,4 +185,4 @@ linesB = map strict . BLC.split '\n' - strict = BS.concat . BL.toChunks + strict = B.concat . BL.toChunks diff --git a/src/Darcs/Repository/Flags.hs b/src/Darcs/Repository/Flags.hs --- a/src/Darcs/Repository/Flags.hs +++ b/src/Darcs/Repository/Flags.hs @@ -30,6 +30,8 @@ , ForgetParent (..) , PatchFormat (..) , IncludeBoring (..) + , HooksConfig (..) + , HookConfig (..) ) where import Darcs.Util.Diff ( DiffAlgorithm(..) ) @@ -129,3 +131,13 @@ data PatchFormat = PatchFormat1 | PatchFormat2 deriving ( Eq, Show ) + +data HooksConfig = HooksConfig + { pre :: HookConfig + , post :: HookConfig + } + +data HookConfig = HookConfig + { cmd :: Maybe String + , prompt :: Bool + } 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 @@ -2,8 +2,6 @@ -- -- This file is licensed under the GPL, version two or later. -{-# LANGUAGE CPP #-} - module Darcs.Repository.Format ( RepoFormat(..) , RepoProperty(..) @@ -22,10 +20,8 @@ import Prelude () import Darcs.Prelude -#include "impossible.h" - import Control.Monad ( mplus, (<=<) ) -import qualified Data.ByteString.Char8 as BC ( split, unpack, elemIndex ) +import qualified Data.ByteString.Char8 as BC ( split, pack, unpack, elemIndex ) import qualified Data.ByteString as B ( null, empty ) import Data.List ( partition, intercalate, (\\) ) import Data.Maybe ( isJust, mapMaybe ) @@ -149,7 +145,8 @@ -- | Write the repo format to the given file. writeRepoFormat :: RepoFormat -> FilePath -> IO () -writeRepoFormat rf loc = writeBinFile loc $ show rf +writeRepoFormat rf loc = writeBinFile loc $ BC.pack $ show rf +-- note: this assumes show returns ascii -- | Create a repo format. The first argument is whether to use the old (darcs-1) -- format; the second says whether the repo has a working tree. diff --git a/src/Darcs/Repository/Hashed.hs b/src/Darcs/Repository/Hashed.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Hashed.hs @@ -0,0 +1,1101 @@ +-- Copyright (C) 2006-2007 David Roundy +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software Foundation, +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +module Darcs.Repository.Hashed + ( inventoriesDir + , inventoriesDirPath + , pristineDir + , pristineDirPath + , patchesDir + , patchesDirPath + , hashedInventory + , hashedInventoryPath + + , revertTentativeChanges + , revertRepositoryChanges + , finalizeTentativeChanges + , cleanPristine + , filterDirContents + , cleanInventories + , cleanPatches + , copyPristine + , copyPartialsPristine + , applyToTentativePristine + , applyToTentativePristineCwd + , addToTentativeInventory + , readRepo + , readRepoHashed + , readTentativeRepo + , writeAndReadPatch + , writeTentativeInventory + , copyHashedInventory + , readHashedPristineRoot + , pokePristineHash + , peekPristineHash + , listInventories + , listInventoriesLocal + , listInventoriesRepoDir + , listPatchesLocalBucketed + , writePatchIfNecessary + , diffHashLists + , withRecorded + , withTentative + , tentativelyAddPatch + , tentativelyRemovePatches + , tentativelyRemovePatches_ + , tentativelyAddPatch_ + , tentativelyAddPatches_ + , tentativelyReplacePatches + , finalizeRepositoryChanges + , unrevertUrl + , createPristineDirectoryTree + , createPartialsPristineDirectoryTree + , reorderInventory + , cleanRepository + , UpdatePristine(..) + , repoXor + ) where + +import Prelude () +import Darcs.Prelude + +import Control.Arrow ( (&&&) ) +import Control.Exception ( catch, IOException ) +import Darcs.Util.Exception ( catchall ) +import Control.Monad ( when, unless, void ) +import Data.Maybe +import Data.List( foldl' ) + +import qualified Data.ByteString as B ( empty, readFile, append ) +import qualified Data.ByteString.Char8 as BC ( unpack, pack ) +import qualified Data.Set as Set + +import Darcs.Util.Hash( encodeBase16, Hash(..), SHA1, sha1Xor, sha1zero ) +import Darcs.Util.Prompt ( promptYorn ) +import Darcs.Util.Tree( treeHash, Tree ) +import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize, + readDarcsHashed, writeDarcsHashed, + decodeDarcsHash, decodeDarcsSize ) +import Darcs.Util.SignalHandler ( withSignalsBlocked ) + +import System.Directory ( createDirectoryIfMissing, getDirectoryContents + , doesFileExist, doesDirectoryExist ) +import System.FilePath.Posix( () ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( stderr, hPutStrLn ) + +import Darcs.Util.External + ( copyFileOrUrl + , cloneFile + , fetchFilePS + , gzFetchFilePS + , Cachable( Uncachable ) + ) +import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs + , Verbosity(..), UpdateWorking (..), WithWorkingDir (WithWorkingDir) ) + +import Darcs.Repository.Format ( RepoProperty( HashedInventory ), formatHas ) +import Darcs.Repository.Pending + ( readPending + , pendingName + , tentativelyRemoveFromPending + , finalizePending + , setTentativePending + , prepend + ) +import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist ) +import Darcs.Repository.State ( readRecorded, updateIndex ) + +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Lock + ( writeBinFile + , writeDocBinFile + , writeAtomicFilePS + , appendDocBinFile + , removeFileMayNotExist + ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..) + , SealedPatchSet, Origin + , patchSet2RL + ) + +import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) ) +import Darcs.Patch.PatchInfoAnd + ( PatchInfoAnd, Hopefully, patchInfoAndPatch, info + , extractHash, createHashed, hopefully ) +import Darcs.Patch ( IsRepoType, RepoPatch, showPatch, apply + , description + , commuteRL + , readPatch + , effect + , invert + ) + +import Darcs.Patch.Apply ( Apply, ApplyState ) + +import Darcs.Patch.Bundle ( scanBundle + , makeBundleN + ) +import Darcs.Patch.Named.Wrapped ( namedIsInternal ) +import Darcs.Patch.Read ( ReadPatch ) +import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset + , mergeThem, splitOnTag ) +import Darcs.Patch.Info + ( PatchInfo, displayPatchInfo, isTag, makePatchname ) +import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath + , AbsolutePath, toFilePath ) +import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, + speculateFilesUsingCache, writeFileUsingCache, + HashedDir(..), hashedDir, peekInCache, bucketFolder ) +import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed, + cleanHashdir ) +import Darcs.Repository.Inventory +import Darcs.Repository.InternalTypes + ( Repository + , repoCache + , repoFormat + , repoLocation + , withRepoLocation + , coerceT ) +import qualified Darcs.Repository.Old as Old ( readOldRepo, oldRepoFailMsg ) +import Darcs.Util.File ( withCurrentDirectory ) +import Darcs.Patch.Witnesses.Ordered + ( (+<+), FL(..), RL(..), mapRL, foldFL_M + , (:>)(..), lengthFL, filterOutFLFL + , reverseFL, reverseRL ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) + +import Darcs.Util.ByteString ( gzReadFilePS ) +import Darcs.Util.Printer.Color ( showDoc ) +import Darcs.Util.Printer + ( Doc, hcat, ($$), renderString, renderPS, text, putDocLn, (<+>) ) +import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO ) +import Darcs.Patch.Progress (progressFL) +import Darcs.Util.Workaround ( renameFile ) +import Darcs.Repository.Prefs ( globalCacheDir ) + + +makeDarcsdirPath :: String -> String +makeDarcsdirPath name = darcsdir name + +-- TODO rename xyzPath to xyzLocal to make it clear that it is +-- relative to the local darcsdir + +-- Location of the (one and only) head inventory. +hashedInventory, hashedInventoryPath :: String +hashedInventory = "hashed_inventory" +hashedInventoryPath = makeDarcsdirPath hashedInventory + +-- Location of the (one and only) tentative head inventory. +tentativeHashedInventory, tentativeHashedInventoryPath :: String +tentativeHashedInventory = "tentative_hashed_inventory" +tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory + +-- Location of parent inventories. +inventoriesDir, inventoriesDirPath :: String +inventoriesDir = "inventories" +inventoriesDirPath = makeDarcsdirPath inventoriesDir + +-- Location of pristine trees. +pristineDir, tentativePristinePath, pristineDirPath :: String +tentativePristinePath = makeDarcsdirPath "tentative_pristine" +pristineDir = "pristine.hashed" +pristineDirPath = makeDarcsdirPath pristineDir + +-- Location of patches. +patchesDir, patchesDirPath :: String +patchesDir = "patches" +patchesDirPath = makeDarcsdirPath patchesDir + +-- | The way patchfiles, inventories, and pristine trees are stored. +-- 'PlainLayout' means all files are in the same directory. 'BucketedLayout' +-- means we create a second level of subdirectories, such that all files whose +-- hash starts with the same two letters are in the same directory. +data DirLayout = PlainLayout | BucketedLayout + +-- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to +-- apply the patch to the 'Tree' identified by @h@. If we encounter an old, +-- size-prefixed pristine, we first convert it to the non-size-prefixed format, +-- then apply the patch. +applyToHashedPristine :: (Apply p, ApplyState p ~ Tree) => String -> p wX wY + -> IO String +applyToHashedPristine h p = applyOrConvertOldPristineAndApply + where + applyOrConvertOldPristineAndApply = + tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply + + hash = decodeDarcsHash $ BC.pack h + + failOnMalformedRoot (SHA256 _) = return () + failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root + + hash2root = BC.unpack . encodeBase16 + + tryApply :: Hash -> IO String + tryApply root = do + failOnMalformedRoot root + -- Read a non-size-prefixed pristine, failing if we encounter one. + tree <- readDarcsHashedNosize pristineDirPath root + (_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath + return . hash2root $ treeHash updatedTree + + warn = "WARNING: Doing a one-time conversion of pristine format.\n" + ++ "This may take a while. The new format is backwards-compatible." + + handleOldPristineAndApply = do + hPutStrLn stderr warn + inv <- gzReadFilePS hashedInventoryPath + let oldroot = BC.pack $ peekPristineHash inv + oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot + -- Read the old size-prefixed pristine tree + old <- readDarcsHashed pristineDirPath oldrootSizeandHash + -- Write out the pristine tree as a non-size-prefixed pristine. + root <- writeDarcsHashed old pristineDirPath + let newroot = hash2root root + -- Write out the new inventory. + writeDocBinFile hashedInventoryPath $ pokePristineHash newroot inv + cleanHashdir (Ca []) HashedPristineDir [newroot] + hPutStrLn stderr "Pristine conversion done..." + -- Retry applying the patch, which should now succeed. + tryApply root + +-- |revertTentativeChanges swaps the tentative and "real" hashed inventory +-- files, and then updates the tentative pristine with the "real" inventory +-- hash. +revertTentativeChanges :: IO () +revertTentativeChanges = do + cloneFile hashedInventoryPath tentativeHashedInventoryPath + i <- gzReadFilePS hashedInventoryPath + writeBinFile tentativePristinePath $ B.append pristineName (BC.pack (peekPristineHash i)) + +-- |finalizeTentativeChanges trys to atomically swap the tentative +-- inventory/pristine pointers with the "real" pointers; it first re-reads the +-- inventory to optimize it, presumably to take account of any new tags, and +-- then writes out the new tentative inventory, and finally does the atomic +-- swap. In general, we can't clean the pristine cache at the same time, since +-- a simultaneous get might be in progress. +finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p) + => Repository rt p wR wU wT -> Compression -> IO () +finalizeTentativeChanges r compr = do + debugMessage "Optimizing the inventory..." + -- Read the tentative patches + ps <- readTentativeRepo r "." + writeTentativeInventory (repoCache r) compr ps + i <- gzReadFilePS tentativeHashedInventoryPath + p <- gzReadFilePS tentativePristinePath + -- Write out the "optimised" tentative inventory. + writeDocBinFile tentativeHashedInventoryPath $ pokePristineHash (peekPristineHash p) i + -- Atomically swap. + renameFile tentativeHashedInventoryPath hashedInventoryPath + +-- |readHashedPristineRoot attempts to read the pristine hash from the current +-- inventory, returning Nothing if it cannot do so. +readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe String) +readHashedPristineRoot r = withRepoLocation r $ do + i <- (Just <$> gzReadFilePS hashedInventoryPath) + `catch` (\(_ :: IOException) -> return Nothing) + return $ peekPristineHash <$> i + +-- |cleanPristine removes any obsolete (unreferenced) entries in the pristine +-- cache. +cleanPristine :: Repository rt p wR wU wT -> IO () +cleanPristine r = withRepoLocation r $ do + debugMessage "Cleaning out the pristine cache..." + i <- gzReadFilePS hashedInventoryPath + cleanHashdir (repoCache r) HashedPristineDir [peekPristineHash i] + +-- |filterDirContents returns the contents of the directory @d@ +-- except files whose names begin with '.' (directories . and .., +-- hidden files) and files whose names are filtered by the function @f@, if +-- @dir@ is empty, no paths are returned. +filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath] +filterDirContents d f = do + let realPath = makeDarcsdirPath d + exists <- doesDirectoryExist realPath + if exists + then filter (\x -> head x /= '.' && f x) <$> + getDirectoryContents realPath + else return [] + +-- | Set difference between two lists of hashes. +diffHashLists :: [String] -> [String] -> [String] +diffHashLists xs ys = from_set $ (to_set xs) `Set.difference` (to_set ys) + where + to_set = Set.fromList . map BC.pack + from_set = map BC.unpack . Set.toList + +-- |cleanInventories removes any obsolete (unreferenced) files in the +-- inventories directory. +cleanInventories :: Repository rt p wR wU wT -> IO () +cleanInventories _ = do + debugMessage "Cleaning out inventories..." + hs <- listInventoriesLocal + fs <- filterDirContents inventoriesDir (const True) + mapM_ (removeFileMayNotExist . (inventoriesDirPath )) + (diffHashLists fs hs) + +-- FIXME this is ugly, these files should be directly under _darcs +-- since they are not hashed. And 'unrevert' isn't even a real patch but +-- a patch bundle. +-- |specialPatches list of special patch files that may exist in the directory +-- _darcs/patches/. +specialPatches :: [FilePath] +specialPatches = ["unrevert", "pending", "pending.tentative"] + +-- |cleanPatches removes any obsolete (unreferenced) files in the +-- patches directory. +cleanPatches :: Repository rt p wR wU wT -> IO () +cleanPatches _ = do + debugMessage "Cleaning out patches..." + hs <- listPatchesLocal PlainLayout darcsdir darcsdir + fs <- filterDirContents patchesDir (`notElem` specialPatches) + mapM_ (removeFileMayNotExist . (patchesDirPath )) + (diffHashLists fs hs) + + +-- |addToSpecificInventory adds a patch to a specific inventory file, and +-- returns the FilePath whichs corresponds to the written-out patch. +addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression + -> PatchInfoAnd rt p wX wY -> IO FilePath +addToSpecificInventory invPath c compr p = do + let invFile = makeDarcsdirPath invPath + hash <- snd <$> writePatchIfNecessary c compr p + appendDocBinFile invFile $ + showInventoryEntry (info p, hash) + return $ patchesDirPath getValidHash hash + +-- | Warning: this allows to add any arbitrary patch! Used by convert import. +addToTentativeInventory :: RepoPatch p => Cache -> Compression + -> PatchInfoAnd rt p wX wY -> IO FilePath +addToTentativeInventory = addToSpecificInventory tentativeHashedInventory + +-- | Attempt to remove an FL of patches from the tentative inventory. +-- This is used for commands that wish to modify already-recorded patches. +-- +-- Precondition: it must be possible to remove the patches, i.e. +-- +-- * the patches are in the repository +-- +-- * any necessary commutations will succeed +removeFromTentativeInventory :: (IsRepoType rt, RepoPatch p) + => Repository rt p wR wU wT -> Compression + -> FL (PatchInfoAnd rt p) wX wT -> IO () +removeFromTentativeInventory repo compr to_remove = do + debugMessage $ "Start removeFromTentativeInventory" + allpatches <- readTentativeRepo repo "." + remaining <- case removeFromPatchSet to_remove allpatches of + Nothing -> bug "Hashed.removeFromTentativeInventory: precondition violated" + Just r -> return r + writeTentativeInventory (repoCache repo) compr remaining + debugMessage $ "Done removeFromTentativeInventory" + +-- |writeHashFile takes a Doc and writes it as a hash-named file, returning the +-- filename that the contents were written to. +writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String +writeHashFile c compr subdir d = do + debugMessage $ "Writing hash file to " ++ hashedDir subdir + writeFileUsingCache c compr subdir $ renderPS d + +-- |readRepo returns the "current" repo patchset. +readRepoHashed :: (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT + -> String -> IO (PatchSet rt p Origin wR) +readRepoHashed = readRepoUsingSpecificInventory hashedInventory + +-- |readRepo returns the tentative repo patchset. +readTentativeRepo :: (IsRepoType rt, RepoPatch p) + => Repository rt p wR wU wT -> String + -> IO (PatchSet rt p Origin wT) +readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory + +-- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the +-- repository @repo@. +readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p) + => String -> Repository rt p wR wU wT + -> String -> IO (PatchSet rt p Origin wS) +readRepoUsingSpecificInventory invPath repo dir = do + realdir <- toPath <$> ioAbsoluteOrRemote dir + Sealed ps <- readRepoPrivate (repoCache repo) realdir invPath + `catch` \e -> do + hPutStrLn stderr ("Invalid repository: " ++ realdir) + ioError e + return $ unsafeCoerceP ps + where + readRepoPrivate :: (IsRepoType rt, RepoPatch p) => Cache -> FilePath + -> FilePath -> IO (SealedPatchSet rt p Origin) + readRepoPrivate cache d iname = do + inventory <- readInventoryPrivate (d darcsdir iname) + readRepoFromInventoryList cache inventory + +-- | Read a 'PatchSet' from the repository (assumed to be located at the +-- current working directory) by following the chain of 'Inventory's, starting +-- with the given one. The 'Cache' parameter is used to locate patches and parent +-- inventories, since not all of them need be present inside the current repo. +readRepoFromInventoryList + :: (IsRepoType rt, RepoPatch p) + => Cache + -> Inventory + -> IO (SealedPatchSet rt p Origin) +readRepoFromInventoryList cache = parseInv + where + parseInv :: (IsRepoType rt, RepoPatch p) + => Inventory + -> IO (SealedPatchSet rt p Origin) + parseInv (Inventory Nothing ris) = + mapSeal (PatchSet NilRL) <$> read_patches (reverse ris) + parseInv (Inventory (Just h) []) = + -- TODO could be more tolerant and create a larger PatchSet + bug $ "bad inventory " ++ getValidHash h ++ " (no tag) in parseInv!" + parseInv (Inventory (Just h) (t : ris)) = do + Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h) + Sealed ps <- unseal seal <$> + unsafeInterleaveIO (read_patches $ reverse ris) + return $ seal $ PatchSet ts ps + + read_patches :: (IsRepoType rt, RepoPatch p) => [InventoryEntry] + -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) + read_patches [] = return $ seal NilRL + read_patches allis@((i1, h1) : is1) = + lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1) + (createValidHashed h1 (const $ speculateAndParse h1 allis i1)) + where + rp :: (IsRepoType rt, RepoPatch p) => [InventoryEntry] + -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) + rp [] = return $ seal NilRL + rp [(i, h), (il, hl)] = + lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) + (rp [(il, hl)]) + (createValidHashed h + (const $ speculateAndParse h (reverse allis) i)) + rp ((i, h) : is) = + lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) + (rp is) + (createValidHashed h (parse i)) + + lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ) + -> IO (Sealed (p wX)) + -> (forall wB . IO (Sealed (q wB))) + -> IO (Sealed (r wX)) + lift2Sealed f iox ioy = do + Sealed x <- unseal seal <$> unsafeInterleaveIO iox + Sealed y <- unseal seal <$> unsafeInterleaveIO ioy + return $ seal $ f y x + + speculateAndParse h is i = speculate h is >> parse i h + + speculate :: PatchHash -> [InventoryEntry] -> IO () + speculate h is = do + already_got_one <- peekInCache cache HashedPatchesDir (getValidHash h) + unless already_got_one $ + speculateFilesUsingCache cache HashedPatchesDir (map (getValidHash . snd) is) + + parse :: ReadPatch p => PatchInfo -> PatchHash -> IO (Sealed (p wX)) + parse i h = do + debugMessage ("Reading patch file: "++ showDoc (displayPatchInfo i)) + (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir (getValidHash h) + case readPatch ps of + Just p -> return p + Nothing -> fail $ unlines [ "Couldn't parse file " ++ fn + , "which is patch" + , renderString $ displayPatchInfo i ] + + read_ts :: (IsRepoType rt, RepoPatch p) => InventoryEntry + -> InventoryHash -> IO (Sealed (RL (Tagged rt p) Origin)) + read_ts tag0 h0 = do + contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash (getValidHash h0) + let is = reverse $ case contents of + (Inventory (Just _) (_ : ris0)) -> ris0 + (Inventory Nothing ris0) -> ris0 + (Inventory (Just _) []) -> bug "inventory without tag!" + Sealed ts <- unseal seal <$> + unsafeInterleaveIO + (case contents of + (Inventory (Just h') (t' : _)) -> read_ts t' h' + (Inventory (Just _) []) -> bug "inventory without tag!" + (Inventory Nothing _) -> return $ seal NilRL) + Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is) + Sealed tag00 <- read_tag tag0 + return $ seal $ ts :<: Tagged tag00 (Just (getValidHash h0)) ps + + read_tag :: (IsRepoType rt, RepoPatch p) => InventoryEntry + -> IO (Sealed (PatchInfoAnd rt p wX)) + read_tag (i, h) = + mapSeal (patchInfoAndPatch i) <$> createValidHashed h (parse i) + + readTaggedInventoryFromHash :: String + -> IO Inventory + readTaggedInventoryFromHash invHash = do + (fileName, pristineAndInventory) <- + fetchFileUsingCache cache HashedInventoriesDir invHash + case parseInventory pristineAndInventory of + Just r -> return r + Nothing -> fail $ unwords ["parse error in file", fileName] + +-- | Read an inventory from a file. Fails with an error message if +-- file is not there or cannot be parsed. +readInventoryPrivate :: FilePath + -> IO Inventory +readInventoryPrivate path = do + inv <- skipPristineHash <$> gzFetchFilePS path Uncachable + case parseInventory inv of + Just r -> return r + Nothing -> fail $ unwords ["parse error in file", path] + +-- |copyRepo copies the hashed inventory of @repo@ to the repository located at +-- @remote@. +copyHashedInventory :: Repository rt p wR wU wT -> RemoteDarcs -> String -> IO () +copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do + let outloc = repoLocation outrepo + createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath) + copyFileOrUrl remote (inloc hashedInventoryPath) + (outloc hashedInventoryPath) + Uncachable -- no need to copy anything but hashed_inventory! + debugMessage "Done copying hashed inventory." + +-- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus +-- forcing it), and then re-reads the patch lazily. +writeAndReadPatch :: (IsRepoType rt, RepoPatch p) => Cache -> Compression + -> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY) +writeAndReadPatch c compr p = do + (i, h) <- writePatchIfNecessary c compr p + unsafeInterleaveIO $ readp h i + where + parse i h = do + debugMessage ("Rereading patch file: "++ showDoc (displayPatchInfo i)) + (fn, ps) <- fetchFileUsingCache c HashedPatchesDir (getValidHash h) + case readPatch ps of + Just x -> return x + Nothing -> fail $ unlines [ "Couldn't parse patch file " ++ fn + , "which is" + , renderString $ displayPatchInfo i] + + readp h i = do Sealed x <- createValidHashed h (parse i) + return . patchInfoAndPatch i $ unsafeCoerceP x + +createValidHashed :: PatchHash + -> (PatchHash -> IO (Sealed (a wX))) + -> IO (Sealed (Darcs.Patch.PatchInfoAnd.Hopefully a wX)) +createValidHashed h f = createHashed (getValidHash h) (f . mkValidHash) + +-- | writeTentativeInventory writes @patchSet@ as the tentative inventory. +writeTentativeInventory :: RepoPatch p => Cache -> Compression + -> PatchSet rt p Origin wX -> IO () +writeTentativeInventory cache compr patchSet = do + debugMessage "in writeTentativeInventory..." + createDirectoryIfMissing False inventoriesDirPath + beginTedious tediousName + hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet + endTedious tediousName + debugMessage "still in writeTentativeInventory..." + case hsh of + Nothing -> writeBinFile (makeDarcsdirPath tentativeHashedInventory) B.empty + Just h -> do + content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h + writeAtomicFilePS (makeDarcsdirPath tentativeHashedInventory) content + where + tediousName = "Writing inventory" + writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX + -> IO (Maybe String) + writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing + writeInventoryPrivate (PatchSet NilRL ps) = do + inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps + let inventorylist = showInventoryPatches (reverse inventory) + hash <- writeHashFile cache compr HashedInventoriesDir inventorylist + return $ Just hash + writeInventoryPrivate + (PatchSet xs@(_ :<: Tagged t _ _) x) = do + resthash <- write_ts xs + finishedOneIO tediousName $ fromMaybe "" resthash + inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) + (NilRL :<: t +<+ x) + let inventorylist = hcat (map showInventoryEntry $ reverse inventory) + inventorycontents = + case resthash of + Just h -> text ("Starting with inventory:\n" ++ h) $$ + inventorylist + Nothing -> inventorylist + hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents + return $ Just hash + where + -- | write_ts writes out a tagged patchset. If it has already been + -- written, we'll have the hash, so we can immediately return it. + write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX + -> IO (Maybe String) + write_ts (_ :<: Tagged _ (Just h) _) = return (Just h) + write_ts (tts :<: Tagged _ Nothing pps) = + writeInventoryPrivate $ PatchSet tts pps + write_ts NilRL = return Nothing + +-- |writeHashIfNecessary writes the patch and returns the resulting info/hash, +-- if it has not already been written. If it has been written, we have the hash +-- in the PatchInfoAnd, so we extract and return the info/hash. +writePatchIfNecessary :: RepoPatch p => Cache -> Compression + -> PatchInfoAnd rt p wX wY -> IO InventoryEntry +writePatchIfNecessary c compr hp = infohp `seq` + case extractHash hp of + Right h -> return (infohp, mkValidHash h) + Left p -> do + h <- writeHashFile c compr HashedPatchesDir (showPatch ForStorage p) + return (infohp, mkValidHash h) + where + infohp = info hp + +-- |listInventoriesWith returns a list of the inventories hashes. +-- The first argument is to choose directory format. +-- The first argument can be readInventoryPrivate or readInventoryLocalPrivate. +-- The second argument specifies whether the files are expected +-- to be stored in plain or in bucketed format. +-- The third argument is the directory of the parent inventory files. +-- The fourth argument is the directory of the head inventory file. +listInventoriesWith + :: (FilePath -> IO Inventory) + -> DirLayout + -> String -> String -> IO [String] +listInventoriesWith readInv dirformat baseDir startDir = do + mbStartingWithInv <- getStartingWithHash startDir hashedInventory + followStartingWiths mbStartingWithInv + where + getStartingWithHash dir file = inventoryParent <$> readInv (dir file) + + invDir = baseDir inventoriesDir + nextDir dir = case dirformat of + BucketedLayout -> invDir bucketFolder dir + PlainLayout -> invDir + + followStartingWiths Nothing = return [] + followStartingWiths (Just hash) = do + let startingWith = getValidHash hash + mbNextInv <- getStartingWithHash (nextDir startingWith) startingWith + (startingWith :) <$> followStartingWiths mbNextInv + +-- |listInventories returns a list of the inventories hashes. +-- This function attempts to retrieve missing inventory files. +listInventories :: IO [String] +listInventories = + listInventoriesWith readInventoryPrivate PlainLayout darcsdir darcsdir + +-- | Read the given inventory file if it exist, otherwise return an empty +-- inventory. Used when we expect that some inventory files may be missing. +readInventoryLocalPrivate :: FilePath -> IO Inventory +readInventoryLocalPrivate path = do + b <- doesFileExist path + if b then readInventoryPrivate path + else return emptyInventory + +-- | Return inventories hashes by following the head inventory. +-- This function does not attempt to retrieve missing inventory files. +listInventoriesLocal :: IO [String] +listInventoriesLocal = + listInventoriesWith readInventoryLocalPrivate PlainLayout darcsdir darcsdir + +-- |listInventoriesRepoDir returns a list of the inventories hashes. +-- The argument @repoDir@ is the directory of the repository from which +-- we are going to read the head inventory file. +-- The rest of hashed files are read from the global cache. +listInventoriesRepoDir :: String -> IO [String] +listInventoriesRepoDir repoDir = do + gCacheDir' <- globalCacheDir + let gCacheInvDir = fromJust gCacheDir' + listInventoriesWith + readInventoryLocalPrivate BucketedLayout gCacheInvDir (repoDir darcsdir) + +-- | Return a list of the patch filenames, extracted from inventory +-- files, by starting with the head inventory and then following the +-- chain of parent inventories. +-- +-- This function does not attempt to download missing inventory files. +-- +-- * The first argument specifies whether the files are expected +-- to be stored in plain or in bucketed format. +-- * The second argument is the directory of the parent inventory. +-- * The third argument is the directory of the head inventory. +listPatchesLocal :: DirLayout -> String -> String -> IO [String] +listPatchesLocal dirformat baseDir startDir = do + inventory <- readInventoryPrivate (startDir hashedInventory) + followStartingWiths (inventoryParent inventory) (inventoryPatchNames inventory) + where + invDir = baseDir inventoriesDir + nextDir dir = case dirformat of + BucketedLayout -> invDir bucketFolder dir + PlainLayout -> invDir + + followStartingWiths Nothing patches = return patches + followStartingWiths (Just hash) patches = do + let startingWith = getValidHash hash + inv <- readInventoryLocalPrivate + (nextDir startingWith startingWith) + (patches++) <$> followStartingWiths (inventoryParent inv) (inventoryPatchNames inv) + +-- |listPatchesLocalBucketed is similar to listPatchesLocal, but +-- it read the inventory directory under @darcsDir@ in bucketed format. +listPatchesLocalBucketed :: String -> String -> IO [String] +listPatchesLocalBucketed = listPatchesLocal BucketedLayout + +-- | copyPristine copies a pristine tree into the current pristine dir, +-- and possibly copies a clean working copy. +-- The target is read from the passed-in dir/inventory name combination. +copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO () +copyPristine cache dir iname wwd = do + i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable + debugMessage $ "Copying hashed pristine tree: " ++ peekPristineHash i + let tediousName = "Copying pristine" + beginTedious tediousName + copyHashed tediousName cache wwd $ peekPristineHash i + endTedious tediousName + +-- |copyPartialsPristine copies the pristine entries for a given list of +-- filepaths. +copyPartialsPristine :: FilePathLike fp => Cache -> String + -> String -> [fp] -> IO () +copyPartialsPristine c d iname fps = do + i <- fetchFilePS (d ++ "/" ++ iname) Uncachable + copyPartialsHashed c (peekPristineHash i) fps + +unrevertUrl :: Repository rt p wR wU wT -> String +unrevertUrl r = repoLocation r ++ "/"++darcsdir++"/patches/unrevert" + +tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> Compression + -> Verbosity + -> UpdateWorking + -> PatchInfoAnd rt p wT wY + -> IO (Repository rt p wR wU wY) +tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine + +data UpdatePristine = UpdatePristine + | DontUpdatePristine + | DontUpdatePristineNorRevert deriving Eq + +tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree) + => UpdatePristine + -> Repository rt p wR wU wT + -> Compression + -> Verbosity + -> UpdateWorking + -> FL (PatchInfoAnd rt p) wT wY + -> IO (Repository rt p wR wU wY) +tentativelyAddPatches_ up r c v uw ps = + foldFL_M (\r' p -> tentativelyAddPatch_ up r' c v uw p) r ps + +-- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun +-- :: Bool, with dryRun = unsafePerformIO $ readIORef ... +tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree) + => UpdatePristine + -> Repository rt p wR wU wT + -> Compression + -> Verbosity + -> UpdateWorking + -> PatchInfoAnd rt p wT wY + -> IO (Repository rt p wR wU wY) + +tentativelyAddPatch_ up r compr verb uw p = + withRepoLocation r $ do + void $ addToTentativeInventory (repoCache r) compr p + when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." + applyToTentativePristine r verb p + debugMessage "Updating pending..." + tentativelyRemoveFromPending r uw p + return (coerceT r) + + +-- |applyToTentativePristine applies a patch @p@ to the tentative pristine +-- tree, and updates the tentative pristine hash +applyToTentativePristine :: (ApplyState q ~ Tree, Apply q, ShowPatch q) + => Repository rt p wR wU wT + -> Verbosity + -> q wT wY + -> IO () +applyToTentativePristine r verb p = + withRepoLocation r $ + do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p + applyToTentativePristineCwd p + +applyToTentativePristineCwd :: (ApplyState p ~ Tree, Apply p) => p wX wY + -> IO () +applyToTentativePristineCwd p = do + tentativePristine <- gzReadFilePS tentativePristinePath + -- Extract the pristine hash from the tentativePristine file, using + -- peekPristineHash (this is valid since we normally just extract the hash from the + -- first line of an inventory file; we can pass in a one-line file that + -- just contains said hash). + let tentativePristineHash = peekPristineHash tentativePristine + newPristineHash <- applyToHashedPristine tentativePristineHash p + writeDocBinFile tentativePristinePath $ + pokePristineHash newPristineHash tentativePristine + +tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> Compression + -> UpdateWorking + -> FL (PatchInfoAnd rt p) wX wT + -> IO (Repository rt p wR wU wX) +tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine + +tentativelyRemovePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => UpdatePristine + -> Repository rt p wR wU wT + -> Compression + -> UpdateWorking + -> FL (PatchInfoAnd rt p) wX wT + -> IO (Repository rt p wR wU wX) +tentativelyRemovePatches_ up r compr uw ps = + withRepoLocation r $ do + when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." + prepend r uw $ effect ps + unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps + debugMessage "Removing changes from tentative inventory..." + if formatHas HashedInventory (repoFormat r) + then do removeFromTentativeInventory r compr ps + when (up == UpdatePristine) $ + applyToTentativePristineCwd $ + progressFL "Applying inverse to pristine" $ invert ps + else fail Old.oldRepoFailMsg + return (coerceT r) + +-- FIXME this is a rather weird API. If called with a patch that isn't already +-- in the repo, it fails with an obscure error from 'commuteToEnd'. It also +-- ends up redoing the work that the caller has already done - if it has +-- already commuted these patches to the end, it must also know the commuted +-- versions of the other patches in the repo. +-- |Given a sequence of patches anchored at the end of the current repository, +-- actually pull them to the end of the repository by removing any patches +-- with the same name and then adding the passed in sequence. +-- Typically callers will have obtained the passed in sequence using +-- 'findCommon' and friends. +tentativelyReplacePatches :: forall rt p wR wU wT wX + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> Compression + -> UpdateWorking + -> Verbosity + -> FL (PatchInfoAnd rt p) wX wT + -> IO () +tentativelyReplacePatches repository compr uw verb ps = + do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps + repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps' + mapAdd repository' ps' + where mapAdd :: Repository rt p wM wL wI + -> FL (PatchInfoAnd rt p) wI wJ + -> IO () + mapAdd _ NilFL = return () + mapAdd r (a:>:as) = + do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a + mapAdd r' as + +-- The type here should rather be +-- ... -> Repo rt p wR wU wT -> IO (Repo rt p wT wU wT) +-- In other words: we set the recorded state to the tentative state. +finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> UpdateWorking + -> Compression + -> IO () +finalizeRepositoryChanges r updateWorking compr + | formatHas HashedInventory (repoFormat r) = + withRepoLocation r $ do + debugMessage "Finalizing changes..." + withSignalsBlocked $ do + finalizeTentativeChanges r compr + recordedState <- readRecorded r + finalizePending r updateWorking recordedState + debugMessage "Done finalizing changes..." + ps <- readRepo r + doesPatchIndexExist (repoLocation r) >>= (`when` createOrUpdatePatchIndexDisk r ps) + updateIndex r + | otherwise = fail Old.oldRepoFailMsg + +-- TODO: rename this and document the transaction protocol (revert/finalize) +-- clearly. +-- |Slightly confusingly named: as well as throwing away any tentative +-- changes, revertRepositoryChanges also re-initialises the tentative state. +-- It's therefore used before makign any changes to the repo. +-- So the type should rather be +-- +-- > ... -> Repo rt p wR wU wT -> IO (Repo rt p wR wU wR) +revertRepositoryChanges :: RepoPatch p + => Repository rt p wR wU wT + -> UpdateWorking + -> IO () +revertRepositoryChanges r uw + | formatHas HashedInventory (repoFormat r) = + withRepoLocation r $ + do removeFileMayNotExist (pendingName ++ ".tentative") + Sealed x <- readPending r + setTentativePending r uw x + when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName + revertTentativeChanges + | otherwise = fail Old.oldRepoFailMsg + +removeFromUnrevertContext :: forall rt p wR wU wT wX + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> FL (PatchInfoAnd rt p) wX wT + -> IO () +removeFromUnrevertContext r ps = do + Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL)) + remove_from_unrevert_context_ bundle + where unrevert_impossible = + do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?" + if confirmed then removeFileMayNotExist (unrevertUrl r) + else fail "Cancelled." + unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin) + unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl r) + case scanBundle pf of + Right foo -> return foo + Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err + remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO () + remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return () + remove_from_unrevert_context_ bundle = + do debugMessage "Adjusting the context of the unrevert changes..." + debugMessage $ "Removing "++ show (lengthFL ps) ++ + " patches in removeFromUnrevertContext!" + ref <- readTentativeRepo r (repoLocation r) + let withSinglet :: Sealed (FL ppp wXxx) + -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO () + withSinglet (Sealed (x :>: NilFL)) j = j x + withSinglet _ _ = return () + withSinglet (mergeThem ref bundle) $ \h_us -> + case commuteRL (reverseFL ps :> h_us) of + Nothing -> unrevert_impossible + Just (us' :> _) -> + case removeFromPatchSet ps ref of + Nothing -> unrevert_impossible + Just common -> + do debugMessage "Have now found the new context..." + bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL) + writeDocBinFile (unrevertUrl r) bundle' + debugMessage "Done adjusting the context of the unrevert changes!" + +cleanRepository :: Repository rt p wR wU wT -> IO () +cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r + +-- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree, +-- possibly writing a clean working copy in the process. +createPristineDirectoryTree :: Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO () +createPristineDirectoryTree r reldir wwd + | formatHas HashedInventory (repoFormat r) = + do createDirectoryIfMissing True reldir + withCurrentDirectory reldir $ + copyPristine (repoCache r) (repoLocation r) hashedInventoryPath wwd + | otherwise = fail Old.oldRepoFailMsg + +-- fp below really should be FileName +-- | Used by the commands dist and diff +createPartialsPristineDirectoryTree :: (FilePathLike fp) + => Repository rt p wR wU wT + -> [fp] + -> FilePath + -> IO () +createPartialsPristineDirectoryTree r prefs dir + | formatHas HashedInventory (repoFormat r) = + do createDirectoryIfMissing True dir + withCurrentDirectory dir $ + copyPartialsPristine (repoCache r) (repoLocation r) + hashedInventoryPath prefs + | otherwise = fail Old.oldRepoFailMsg + +withRecorded :: Repository rt p wR wU wT + -> ((AbsolutePath -> IO a) -> IO a) + -> (AbsolutePath -> IO a) + -> IO a +withRecorded repository mk_dir f + = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir + f d + +withTentative :: forall rt p a wR wU wT. + Repository rt p wR wU wT + -> ((AbsolutePath -> IO a) -> IO a) + -> (AbsolutePath -> IO a) + -> IO a +withTentative r mk_dir f + | formatHas HashedInventory (repoFormat r) = + mk_dir $ \d -> do copyPristine + (repoCache r) + (repoLocation r) + (darcsdir++"/tentative_pristine") + WithWorkingDir + f d + | otherwise = fail Old.oldRepoFailMsg + +-- | Writes out a fresh copy of the inventory that minimizes the +-- amount of inventory that need be downloaded when people pull from +-- the repository. +-- +-- Specifically, it breaks up the inventory on the most recent tag. +-- This speeds up most commands when run remotely, both because a +-- smaller file needs to be transfered (only the most recent +-- inventory). It also gives a guarantee that all the patches prior +-- to a given tag are included in that tag, so less commutation and +-- history traversal is needed. This latter issue can become very +-- important in large repositories. +reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wR + -> Compression + -> UpdateWorking + -> Verbosity + -> IO () +reorderInventory repository compr uw verb = do + debugMessage "Reordering the inventory." + PatchSet _ ps <- misplacedPatches `fmap` readRepo repository + tentativelyReplacePatches repository compr uw verb $ reverseRL ps + finalizeTentativeChanges repository compr + debugMessage "Done reordering the inventory." + +-- | Returns the patches that make the most recent tag dirty. +misplacedPatches :: forall rt p wS wX . RepoPatch p + => PatchSet rt p wS wX + -> PatchSet rt p wS wX +misplacedPatches ps = + -- Filter the repository keeping only with the tags, ordered from the + -- most recent. + case filter isTag $ mapRL info $ patchSet2RL ps of + [] -> ps + (lt:_) -> + -- Take the most recent tag, and split the repository in, + -- the clean PatchSet "up to" the tag (ts), and a RL of + -- patches after the tag (r). + case splitOnTag lt ps of + Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r) + _ -> impossible -- Because the tag is in ps. + +-- @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. +readRepo :: (IsRepoType rt, RepoPatch p) + => Repository rt p wR wU wT + -> IO (PatchSet rt p Origin wR) +readRepo r + | formatHas HashedInventory (repoFormat r) = readRepoHashed r (repoLocation r) + | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r) + return $ unsafeCoerceP ps + +-- | XOR of all hashes of the patches' metadata. +-- It enables to quickly see whether two repositories +-- have the same patches, independently of their order. +-- It relies on the assumption that the same patch cannot +-- be present twice in a repository. +-- This checksum is not cryptographically secure, +-- see http://robotics.stanford.edu/~xb/crypto06b/ . +repoXor :: (IsRepoType rt, RepoPatch p) + => Repository rt p wR wU wR -> IO SHA1 +repoXor repo = do + hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo repo + return $ foldl' sha1Xor sha1zero hashes + + + 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 @@ -15,14 +15,12 @@ -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. {-# OPTIONS_GHC -fno-warn-missing-methods #-} -{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses #-} -module Darcs.Repository.HashedIO ( HashedIO, - copyHashed, copyPartialsHashed, +module Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed, cleanHashdir, getHashedFiles, - RW(RW) -- only exported to make warning go away - , pathsAndContents + pathsAndContents ) where import Prelude () @@ -49,8 +47,8 @@ , normPath , fp2fn , fn2fp - , fn2niceps - , niceps2fn + , fn2ps + , ps2fn , breakOnDir , ownName , superName @@ -72,23 +70,15 @@ readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString) readHashFile c subdir hash = do debugMessage $ "Reading hash file "++hash++" from "++hashedDir subdir++"/" - fetchFileUsingCache c subdir hash - -data HashDir r p = HashDir { permissions :: !r, cache :: !Cache, - rootHash :: !String } -type HashedIO p = StateT (HashDir RW p) IO + r <- fetchFileUsingCache c subdir hash + debugMessage $ "Result of reading hash file: " ++ show r + return r -data RW = RW -{- -class Readable r where - isRO :: r -> Bool - isRO = const False -instance Readable RW -instance Readable RO where - isRO RO = True --} +data HashDir = HashDir { cache :: !Cache, + rootHash :: !String } +type HashedIO = StateT HashDir IO -mWithCurrentDirectory :: FileName -> HashedIO p a -> HashedIO p a +mWithCurrentDirectory :: FileName -> HashedIO a -> HashedIO a mWithCurrentDirectory fn j | fn' == fp2fn "" = j | otherwise = @@ -107,7 +97,7 @@ return x where fn' = normPath fn -mInCurrentDirectory :: FileName -> HashedIO p a -> HashedIO p a +mInCurrentDirectory :: FileName -> HashedIO a -> HashedIO a mInCurrentDirectory fn j | fn' == fp2fn "" = j | otherwise = case breakOnDir fn' of @@ -121,10 +111,10 @@ Just h -> inh h $ mInCurrentDirectory fn'' j where fn' = normPath fn -instance ApplyMonad Tree (HashedIO p) where - type ApplyMonadBase (HashedIO p) = IO +instance ApplyMonad Tree HashedIO where + type ApplyMonadBase HashedIO = IO -instance ApplyMonadTree (HashedIO p) where +instance ApplyMonadTree HashedIO where mDoesDirectoryExist fn = do thing <- identifyThing fn case thing of Just (D,_) -> return True _ -> return False @@ -150,7 +140,7 @@ fail $ "Cannot remove non-empty file "++fn2fp f rmThing f -identifyThing :: FileName -> HashedIO p (Maybe (ObjType,String)) +identifyThing :: FileName -> HashedIO (Maybe (ObjType,String)) identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash return $ Just (D, h) | otherwise = case breakOnDir fn' of @@ -161,11 +151,11 @@ Just h -> inh h $ identifyThing fn'' where fn' = normPath fn -makeThing :: FileName -> (ObjType,String) -> HashedIO p () +makeThing :: FileName -> (ObjType,String) -> HashedIO () makeThing fn (o,h) = mWithCurrentDirectory (superName $ normPath fn) $ seta o (ownName $ normPath fn) h `fmap` readroot >>= writeroot -rmThing :: FileName -> HashedIO p () +rmThing :: FileName -> HashedIO () rmThing fn = mWithCurrentDirectory (superName $ normPath fn) $ do c <- readroot let c' = filter (\(_,x,_)->x/= ownName (normPath fn)) c @@ -173,13 +163,13 @@ then writeroot c' else fail "obj doesn't exist in rmThing" -readhash :: String -> HashedIO p B.ByteString +readhash :: String -> HashedIO B.ByteString readhash h = do c <- gets cache z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h let (_,out) = z return out -withh :: String -> HashedIO p a -> HashedIO p (String,a) +withh :: String -> HashedIO a -> HashedIO (String,a) withh h j = do hd <- get put $ hd { rootHash = h } x <- j @@ -187,24 +177,25 @@ put hd return (h',x) -inh :: String -> HashedIO p a -> HashedIO p a +inh :: String -> HashedIO a -> HashedIO a inh h j = snd `fmap` withh h j -readroot :: HashedIO p [(ObjType, FileName, String)] +readroot :: HashedIO [(ObjType, FileName, String)] readroot = do haveitalready <- peekroot cc <- gets rootHash >>= readdir unless haveitalready $ speculate cc return cc - where speculate :: [(a,b,String)] -> HashedIO q () + where speculate :: [(a,b,String)] -> HashedIO () speculate c = do cac <- gets cache mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c - peekroot :: HashedIO p Bool - peekroot = do HashDir _ c h <- get + peekroot :: HashedIO Bool + peekroot = do HashDir c h <- get lift $ peekInCache c HashedPristineDir h -writeroot :: [(ObjType, FileName, String)] -> HashedIO p () -writeroot c = do h <- writedir c - modify $ \hd -> hd { rootHash = h } +writeroot :: [(ObjType, FileName, String)] -> HashedIO () +writeroot c = do + h <- writedir c + modify $ \hd -> hd { rootHash = h } data ObjType = F | D deriving Eq @@ -224,24 +215,35 @@ seta o f h ((_,f',_):r) | f == f' = (o,f,h):r seta o f h (x:xs) = x : seta o f h xs -readdir :: String -> HashedIO p [(ObjType, FileName, String)] -readdir hash = (parsed . linesPS) `fmap` readhash hash - where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, BC.unpack h) : parsed rest - | t == file = (F, niceps2fn n, BC.unpack h) : parsed rest - parsed _ = [] +readdir :: String -> HashedIO [(ObjType, FileName, String)] +readdir hash = do + x <- readhash hash + lift $ debugMessage $ show x + let r = (parsed . linesPS) x + lift $ debugMessage $ unlines $ map (\(_,fn,_) -> "DEBUG readdir " ++ hash ++ " entry: " ++ show fn) r + return r + where + parsed (t:n:h:rest) | t == dir = (D, ps2fn n, BC.unpack h) : parsed rest + | t == file = (F, ps2fn n, BC.unpack h) : parsed rest + parsed _ = [] + dir :: B.ByteString dir = BC.pack "directory:" file :: B.ByteString file = BC.pack "file:" -writedir :: [(ObjType, FileName, String)] -> HashedIO p String -writedir c = writeHashFile cps - where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,BC.pack h]) c++[B.empty] - showO D = dir - showO F = file +writedir :: [(ObjType, FileName, String)] -> HashedIO String +writedir c = do + lift $ debugMessage $ unlines $ map (\(_,fn,_) -> "DEBUG writedir entry: " ++ show fn) c + writeHashFile cps + where + cps = unlinesPS $ concatMap wr c ++ [B.empty] + wr (o,d,h) = [showO o,fn2ps d,BC.pack h] + showO D = dir + showO F = file -writeHashFile :: B.ByteString -> HashedIO p String +writeHashFile :: B.ByteString -> HashedIO String writeHashFile ps = do c <- gets cache -- pristine files are always compressed lift $ writeFileUsingCache c GzipCompression HashedPristineDir ps @@ -250,13 +252,14 @@ -- | Grab a whole pristine tree from a hash, and, if asked, -- write files in the working copy. copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO () -copyHashed k c wwd z = void . runStateT cph $ HashDir { permissions = RW, cache = c, rootHash = z } +copyHashed k c wwd z = void . runStateT cph $ HashDir { cache = c, rootHash = z } where cph = do cc <- readroot lift $ tediousSize k (length cc) mapM_ cp cc cp (F,n,h) = do ps <- readhash h lift $ finishedOneIO k (fn2fp n) + lift $ debugMessage $ "DEBUG copyHashed " ++ show n case wwd of WithWorkingDir -> lift $ writeAtomicFilePS (fn2fp n) ps NoWorkingDir -> ps `seq` return () @@ -279,7 +282,7 @@ -- Separator "/" is used since this function is used to generate -- zip archives from pristine trees. pathsAndContents :: FilePath -> Cache -> String -> IO [(FilePath,B.ByteString)] -pathsAndContents path c root = evalStateT cph $ HashDir { permissions = RW, cache = c, rootHash = root } +pathsAndContents path c root = evalStateT cph HashDir { cache = c, rootHash = root } where cph = do cc <- readroot pacs <- concat <$> mapM cp cc let current = if path == "." then [] else [(path ++ "/" , B.empty)] @@ -300,7 +303,7 @@ copyPartialHashed c root ff = do createDirectoryIfMissing True (basename $ toFilePath ff) void $ runStateT (cp $ fp2fn $ toFilePath ff) - HashDir { permissions = RW, cache = c, + HashDir { cache = c, rootHash = root } where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse cp f = do mt <- identifyThing f @@ -335,5 +338,4 @@ let subs = [ fst $ darcsLocation "" (s, h') | (TreeType, _, s, h') <- x ] hashes = h : [ fst $ darcsLocation "" (s, h') | (_, _, s, h') <- x ] (hashes++) . concat <$> mapM listone subs - hs <- concat <$> mapM listone hashroots - return hs + concat <$> mapM listone hashroots diff --git a/src/Darcs/Repository/HashedRepo.hs b/src/Darcs/Repository/HashedRepo.hs deleted file mode 100644 --- a/src/Darcs/Repository/HashedRepo.hs +++ /dev/null @@ -1,776 +0,0 @@ --- Copyright (C) 2006-2007 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software Foundation, --- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -module Darcs.Repository.HashedRepo - ( inventoriesDir - , pristineDir - , patchesDir - , hashedInventory - , revertTentativeChanges - , finalizeTentativeChanges - , cleanPristine - , filterDirContents - , cleanInventories - , cleanPatches - , copyPristine - , copyPartialsPristine - , applyToTentativePristine - , addToSpecificInventory - , addToTentativeInventory - , removeFromTentativeInventory - , readRepo - , readTentativeRepo - , readRepoUsingSpecificInventory - , writeAndReadPatch - , writeTentativeInventory - , copyHashedInventory - , readHashedPristineRoot - , pris2inv - , inv2pris - , listInventories - , listInventoriesLocal - , listInventoriesRepoDir - , listPatchesLocalBucketed - , writePatchIfNecessary - , readRepoFromInventoryList - , readPatchIds - , set - , unset - ) where - -#include "impossible.h" - -import Prelude () -import Darcs.Prelude - -import Control.Arrow ( (&&&) ) -import Control.Exception ( catch, IOException ) -import Control.Monad ( unless ) -import Data.Maybe -import qualified Data.ByteString as B ( null, length, empty ,tail, drop, - ByteString, splitAt ) -import qualified Data.ByteString.Char8 as BC ( unpack, dropWhile, break, pack, - ByteString ) -import qualified Data.Set as Set -import Darcs.Util.Hash( encodeBase16, Hash(..) ) -import Darcs.Util.Tree( treeHash, Tree ) -import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize, - readDarcsHashed, writeDarcsHashed, - decodeDarcsHash, decodeDarcsSize ) -import System.Directory ( createDirectoryIfMissing, getDirectoryContents - , doesFileExist, doesDirectoryExist ) -import System.FilePath.Posix( () ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO ( stderr, hPutStrLn ) - -import Darcs.Util.Printer.Color ( showDoc ) -import Darcs.Util.External - ( copyFileOrUrl - , cloneFile - , fetchFilePS - , gzFetchFilePS - , Cachable( Uncachable ) - ) -import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs, WithWorkingDir ) -import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.Lock - ( writeBinFile - , writeDocBinFile - , writeAtomicFilePS - , appendBinFile - , appendDocBinFile - , removeFileMayNotExist - ) -import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) - -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info, - extractHash, createHashed ) -import Darcs.Patch ( IsRepoType, RepoPatch, Patchy, showPatch, readPatch, apply ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Read ( ReadPatch ) -import Darcs.Patch.ReadMonads ( parseStrictly ) -import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfo, showPatchInfoUI, - readPatchInfo ) -import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath ) -import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, - speculateFilesUsingCache, writeFileUsingCache, - okayHash, takeHash, - HashedDir(..), hashedDir, peekInCache, bucketFolder ) -import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed, - cleanHashdir ) -import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) -import Darcs.Util.File ( withCurrentDirectory ) -import Darcs.Patch.Witnesses.Ordered - ( (+<+), FL(..), RL(..), mapRL ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) - -import Darcs.Util.ByteString ( gzReadFilePS, dropSpace ) -import Darcs.Util.Crypt.SHA256 ( sha256sum ) -import Darcs.Util.Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, - invisiblePS, RenderMode(..) ) -import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO ) -import Darcs.Util.Workaround ( renameFile ) -import Darcs.Repository.Prefs ( globalCacheDir ) - -makeDarcsdirPath :: String -> String -makeDarcsdirPath name = darcsdir name - -hashedInventory, hashedInventoryPath :: String -hashedInventory = "hashed_inventory" -hashedInventoryPath = makeDarcsdirPath hashedInventory - -tentativeHashedInventory, tentativeHashedInventoryPath :: String -tentativeHashedInventory = "tentative_hashed_inventory" -tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory - -inventoriesDir, inventoriesDirPath :: String -inventoriesDir = "inventories" -inventoriesDirPath = makeDarcsdirPath inventoriesDir - -pristineDir, tentativePristinePath, pristineDirPath :: String -tentativePristinePath = makeDarcsdirPath "tentative_pristine" -pristineDir = "pristine.hashed" -pristineDirPath = makeDarcsdirPath pristineDir - -patchesDir, patchesDirPath :: String -patchesDir = "patches" -patchesDirPath = makeDarcsdirPath patchesDir - -pristineNamePrefix :: String -pristineNamePrefix = "pristine:" - -pristineName :: B.ByteString -pristineName = BC.pack pristineNamePrefix - --- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to --- apply the patch to the 'Tree' identified by @h@. If we encounter an old, --- size-prefixed pristine, we first convert it to the non-size-prefixed format, --- then apply the patch. -applyToHashedPristine :: (ApplyState p ~ Tree, Patchy p) => String -> p wX wY - -> IO String -applyToHashedPristine h p = applyOrConvertOldPristineAndApply - where - applyOrConvertOldPristineAndApply = - tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply - - hash = decodeDarcsHash $ BC.pack h - - failOnMalformedRoot (SHA256 _) = return () - failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root - - hash2root = BC.unpack . encodeBase16 - - tryApply :: Hash -> IO String - tryApply root = do - failOnMalformedRoot root - -- Read a non-size-prefixed pristine, failing if we encounter one. - tree <- readDarcsHashedNosize pristineDirPath root - (_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath - return . hash2root $ treeHash updatedTree - - warn = "WARNING: Doing a one-time conversion of pristine format.\n" - ++ "This may take a while. The new format is backwards-compatible." - - handleOldPristineAndApply = do - hPutStrLn stderr warn - inv <- gzReadFilePS hashedInventoryPath - let oldroot = BC.pack $ inv2pris inv - oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot - -- Read the old size-prefixed pristine tree - old <- readDarcsHashed pristineDirPath oldrootSizeandHash - -- Write out the pristine tree as a non-size-prefixed pristine. - root <- writeDarcsHashed old pristineDirPath - let newroot = hash2root root - -- Write out the new inventory. - writeDocBinFile hashedInventoryPath $ pris2inv newroot inv - cleanHashdir (Ca []) HashedPristineDir [newroot] - hPutStrLn stderr "Pristine conversion done..." - -- Retry applying the patch, which should now succeed. - tryApply root - --- |revertTentativeChanges swaps the tentative and "real" hashed inventory --- files, and then updates the tentative pristine with the "real" inventory --- hash. -revertTentativeChanges :: IO () -revertTentativeChanges = do - cloneFile hashedInventoryPath tentativeHashedInventoryPath - i <- gzReadFilePS hashedInventoryPath - writeBinFile tentativePristinePath $ pristineNamePrefix ++ inv2pris i - --- |finalizeTentativeChanges trys to atomically swap the tentative --- inventory/pristine pointers with the "real" pointers; it first re-reads the --- inventory to optimize it, presumably to take account of any new tags, and --- then writes out the new tentative inventory, and finally does the atomic --- swap. In general, we can't clean the pristine cache at the same time, since --- a simultaneous get might be in progress. -finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> Compression -> IO () -finalizeTentativeChanges r compr = do - debugMessage "Optimizing the inventory..." - -- Read the tentative patches - ps <- readTentativeRepo r "." - writeTentativeInventory (extractCache r) compr ps - i <- gzReadFilePS tentativeHashedInventoryPath - p <- gzReadFilePS tentativePristinePath - -- Write out the "optimised" tentative inventory. - writeDocBinFile tentativeHashedInventoryPath $ pris2inv (inv2pris p) i - -- Atomically swap. - renameFile tentativeHashedInventoryPath hashedInventoryPath - --- |readHashedPristineRoot attempts to read the pristine hash from the current --- inventory, returning Nothing if it cannot do so. -readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe String) -readHashedPristineRoot (Repo d _ _ _) = withCurrentDirectory d $ do - i <- (Just <$> gzReadFilePS hashedInventoryPath) - `catch` (\(_ :: IOException) -> return Nothing) - return $ inv2pris <$> i - --- |cleanPristine removes any obsolete (unreferenced) entries in the pristine --- cache. -cleanPristine :: Repository rt p wR wU wT -> IO () -cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $ do - debugMessage "Cleaning out the pristine cache..." - i <- gzReadFilePS hashedInventoryPath - cleanHashdir (extractCache r) HashedPristineDir [inv2pris i] - --- |filterDirContents returns the contents of the directory @d@ --- except files whose names begin with '.' (directories . and .., --- hidden files) and files whose names are filtered by the function @f@, if --- @dir@ is empty, no paths are returned. -filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath] -filterDirContents d f = do - let realPath = makeDarcsdirPath d - exists <- doesDirectoryExist realPath - if exists - then filter (\x -> head x /= '.' && f x) <$> - getDirectoryContents realPath - else return [] - --- |set converts a list of strings into a set of Char8 ByteStrings for faster --- Set operations. -set :: [String] -> Set.Set BC.ByteString -set = Set.fromList . map BC.pack - --- |unset is the inverse of set. -unset :: Set.Set BC.ByteString -> [String] -unset = map BC.unpack . Set.toList - --- |cleanInventories removes any obsolete (unreferenced) files in the --- inventories directory. -cleanInventories :: Repository rt p wR wU wT -> IO () -cleanInventories _ = do - debugMessage "Cleaning out inventories..." - hs <- listInventoriesLocal - fs <- filterDirContents inventoriesDir (const True) - mapM_ (removeFileMayNotExist . (inventoriesDirPath )) - (unset $ (set fs) `Set.difference` (set hs)) - --- |specialPatches list of special patch files that may exist in the directory --- _darcs/patches/. -specialPatches :: [FilePath] -specialPatches = ["unrevert", "pending", "pending.tentative"] - --- |cleanPatches removes any obsolete (unreferenced) files in the --- patches directory. -cleanPatches :: Repository rt p wR wU wT -> IO () -cleanPatches _ = do - debugMessage "Cleaning out patches..." - hs <- listPatchesLocal darcsdir - fs <- filterDirContents patchesDir (`notElem` specialPatches) - mapM_ (removeFileMayNotExist . (patchesDirPath )) - (unset $ (set fs) `Set.difference` (set hs)) - - --- |addToSpecificInventory adds a patch to a specific inventory file, and --- returns the FilePath whichs corresponds to the written-out patch. -addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression - -> PatchInfoAnd rt p wX wY -> IO FilePath -addToSpecificInventory invPath c compr p = do - let invFile = darcsdir invPath - hash <- snd <$> writePatchIfNecessary c compr p - appendDocBinFile invFile $ showPatchInfo $ info p - appendBinFile invFile $ "\nhash: " ++ hash ++ "\n" - return $ darcsdir "patches" hash - -addToTentativeInventory :: RepoPatch p => Cache -> Compression - -> PatchInfoAnd rt p wX wY -> IO FilePath -addToTentativeInventory = addToSpecificInventory tentativeHashedInventory - --- | Attempt to remove an FL of patches from the tentative inventory. --- This is used for commands that wish to modify already-recorded patches. --- --- Precondition: it must be possible to remove the patches, i.e. --- --- * the patches are in the repository --- --- * any necessary commutations will succeed -removeFromTentativeInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> Compression - -> FL (PatchInfoAnd rt p) wX wT -> IO () -removeFromTentativeInventory repo compr to_remove = do - debugMessage $ "Start removeFromTentativeInventory" - allpatches <- readTentativeRepo repo "." - remaining <- case removeFromPatchSet to_remove allpatches of - Nothing -> bug "HashedRepo.removeFromTentativeInventory: precondition violated" - Just r -> return r - writeTentativeInventory (extractCache repo) compr remaining - debugMessage $ "Done removeFromTentativeInventory" - --- |writeHashFile takes a Doc and writes it as a hash-named file, returning the --- filename that the contents were written to. -writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String -writeHashFile c compr subdir d = do - debugMessage $ "Writing hash file to " ++ hashedDir subdir - writeFileUsingCache c compr subdir $ renderPS Standard d - --- |readRepo returns the "current" repo patchset. -readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT - -> String -> IO (PatchSet rt p Origin wR) -readRepo = readRepoUsingSpecificInventory hashedInventory - --- |readRepo returns the tentative repo patchset. -readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> String - -> IO (PatchSet rt p Origin wT) -readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory - --- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the --- repository @repo@. -readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => String -> Repository rt p wR wU wT - -> String -> IO (PatchSet rt p Origin wS) -readRepoUsingSpecificInventory invPath repo dir = do - realdir <- toPath <$> ioAbsoluteOrRemote dir - Sealed ps <- readRepoPrivate (extractCache repo) realdir invPath - `catch` \e -> do - hPutStrLn stderr ("Invalid repository: " ++ realdir) - ioError e - return $ unsafeCoerceP ps - where - readRepoPrivate :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath - -> FilePath -> IO (SealedPatchSet rt p Origin) - readRepoPrivate cache d iname = do - inventory <- readInventoryPrivate (d darcsdir) iname - readRepoFromInventoryList cache inventory - --- |readRepoFromInventoryList allows the caller to provide an optional "from --- inventory" hash, and a list of info/hash pairs that identify a list of --- patches, returning a patchset of the resulting repo. -readRepoFromInventoryList :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache - -> (Maybe String, [(PatchInfo, String)]) - -> IO (SealedPatchSet rt p Origin) -readRepoFromInventoryList cache = parseinvs - where - speculateAndParse h is i = speculate h is >> parse i h - - read_patches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] - -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) - read_patches [] = return $ seal NilRL - read_patches allis@((i1, h1) : is1) = - lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1) - (createHashed h1 (const $ speculateAndParse h1 allis i1)) - where - rp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] - -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) - rp [] = return $ seal NilRL - rp [(i, h), (il, hl)] = - lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) - (rp [(il, hl)]) - (createHashed h - (const $ speculateAndParse h (reverse allis) i)) - rp ((i, h) : is) = - lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) - (rp is) - (createHashed h (parse i)) - - read_tag :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) - -> IO (Sealed (PatchInfoAnd rt p wX)) - read_tag (i, h) = - mapSeal (patchInfoAndPatch i) <$> createHashed h (parse i) - - speculate :: String -> [(PatchInfo, String)] -> IO () - speculate h is = do - already_got_one <- peekInCache cache HashedPatchesDir h - unless already_got_one $ - speculateFilesUsingCache cache HashedPatchesDir (map snd is) - - parse :: ReadPatch p => PatchInfo -> String -> IO (Sealed (p wX)) - parse i h = do - debugMessage ("Reading patch file: "++ showDoc Encode (showPatchInfoUI i)) - (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir h - case readPatch ps of - Just p -> return p - Nothing -> fail $ unlines [ "Couldn't parse file " ++ fn - , "which is patch" - , renderString Encode $ showPatchInfoUI i ] - - parseinvs :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => (Maybe String, [(PatchInfo, String)]) - -> IO (SealedPatchSet rt p Origin) - parseinvs (Nothing, ris) = - mapSeal (PatchSet NilRL) <$> read_patches (reverse ris) - parseinvs (Just h, []) = - bug $ "bad inventory " ++ h ++ " (no tag) in parseinvs!" - parseinvs (Just h, t : ris) = do - Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h) - Sealed ps <- unseal seal <$> - unsafeInterleaveIO (read_patches $ reverse ris) - return $ seal $ PatchSet ts ps - - read_ts :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) - -> String -> IO (Sealed (RL (Tagged rt p) Origin)) - read_ts tag0 h0 = do - contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash h0 - let is = reverse $ case contents of - (Just _, _ : ris0) -> ris0 - (Nothing, ris0) -> ris0 - (Just _, []) -> bug "inventory without tag!" - Sealed ts <- unseal seal <$> - unsafeInterleaveIO - (case contents of - (Just h', t' : _) -> read_ts t' h' - (Just _, []) -> bug "inventory without tag!" - (Nothing, _) -> return $ seal NilRL) - Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is) - Sealed tag00 <- read_tag tag0 - return $ seal $ ts :<: Tagged tag00 (Just h0) ps - - readTaggedInventoryFromHash :: String - -> IO (Maybe String, [(PatchInfo, String)]) - readTaggedInventoryFromHash invHash = do - (fileName, pristineAndInventory) <- - fetchFileUsingCache cache HashedInventoriesDir invHash - readInventoryFromContent fileName pristineAndInventory - - lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ) - -> IO (Sealed (p wX)) - -> (forall wB . IO (Sealed (q wB))) - -> IO (Sealed (r wX)) - lift2Sealed f iox ioy = do - Sealed x <- unseal seal <$> unsafeInterleaveIO iox - Sealed y <- unseal seal <$> unsafeInterleaveIO ioy - return $ seal $ f y x - --- |readInventoryPrivate reads the inventory with name @invName@ in @dir@. -readInventoryPrivate :: String -> String - -> IO (Maybe String, [(PatchInfo, String)]) -readInventoryPrivate dir invName = do - inv <- skipPristine <$> gzFetchFilePS (dir invName) Uncachable - readInventoryFromContent (toPath dir ++ "/" ++ darcsdir ++ invName) inv - --- |readInventoryFromContent extracts an inventory from the content of an --- inventory file, who's path is @fileName@. -readInventoryFromContent :: FilePath -> B.ByteString - -> IO (Maybe String, [(PatchInfo, String)]) -readInventoryFromContent fileName pristineAndInventory = do - (hash, patchIds) <- - if mbStartingWith == BC.pack "Starting with inventory:" - then let (hash, pids) = BC.break ('\n' ==) $ B.tail pistr - hashStr = BC.unpack hash in - if okayHash hashStr - then return (Just hashStr, pids) - else fail $ "Bad hash in file " ++ fileName - else return (Nothing, inventory) - return (hash, readPatchIds patchIds) - where - inventory = skipPristine pristineAndInventory - (mbStartingWith, pistr) = BC.break ('\n' ==) inventory - --- |copyRepo copies the hashed inventory of @repo@ to the repository located at --- @remote@. -copyHashedInventory :: RepoPatch p => Repository rt p wR wU wT -> RemoteDarcs -> String -> IO () -copyHashedInventory (Repo outr _ _ _) rdarcs inr | remote <- remoteDarcs rdarcs = do - createDirectoryIfMissing False (outr ++ "/" ++ inventoriesDirPath) - copyFileOrUrl remote (inr darcsdir hashedInventory) - (outr darcsdir hashedInventory) - Uncachable -- no need to copy anything but hashed_inventory! - debugMessage "Done copying hashed inventory." - --- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus --- forcing it), and then re-reads the patch lazily. -writeAndReadPatch :: (IsRepoType rt, RepoPatch p) => Cache -> Compression - -> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY) -writeAndReadPatch c compr p = do - (i, h) <- writePatchIfNecessary c compr p - unsafeInterleaveIO $ readp h i - where - parse i h = do - debugMessage ("Rereading patch file: "++ showDoc Encode (showPatchInfoUI i)) - (fn, ps) <- fetchFileUsingCache c HashedPatchesDir h - case readPatch ps of - Just x -> return x - Nothing -> fail $ unlines [ "Couldn't parse patch file " ++ fn - , "which is" - , renderString Encode $ showPatchInfoUI i] - - readp h i = do Sealed x <- createHashed h (parse i) - return . patchInfoAndPatch i $ unsafeCoerceP x - --- | writeTentativeInventory writes @patchSet@ as the tentative inventory. -writeTentativeInventory :: RepoPatch p => Cache -> Compression - -> PatchSet rt p Origin wX -> IO () -writeTentativeInventory cache compr patchSet = do - debugMessage "in writeTentativeInventory..." - createDirectoryIfMissing False inventoriesDirPath - beginTedious tediousName - hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet - endTedious tediousName - debugMessage "still in writeTentativeInventory..." - case hsh of - Nothing -> writeBinFile (darcsdir tentativeHashedInventory) "" - Just h -> do - content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h - writeAtomicFilePS (darcsdir tentativeHashedInventory) content - where - tediousName = "Writing inventory" - writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX - -> IO (Maybe String) - writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing - writeInventoryPrivate (PatchSet NilRL ps) = do - inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps - let inventorylist = hcat (map pihash $ reverse inventory) - hash <- writeHashFile cache compr HashedInventoriesDir inventorylist - return $ Just hash - writeInventoryPrivate - (PatchSet xs@(_ :<: Tagged t _ _) x) = do - resthash <- write_ts xs - finishedOneIO tediousName $ fromMaybe "" resthash - inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) - (NilRL :<: t +<+ x) - let inventorylist = hcat (map pihash $ reverse inventory) - inventorycontents = - case resthash of - Just h -> text ("Starting with inventory:\n" ++ h) $$ - inventorylist - Nothing -> inventorylist - hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents - return $ Just hash - where - -- | write_ts writes out a tagged patchset. If it has already been - -- written, we'll have the hash, so we can immediately return it. - write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX - -> IO (Maybe String) - write_ts (_ :<: Tagged _ (Just h) _) = return (Just h) - write_ts (tts :<: Tagged _ Nothing pps) = - writeInventoryPrivate $ PatchSet tts pps - write_ts NilRL = return Nothing - --- |writeHashIfNecessary writes the patch and returns the resulting info/hash, --- if it has not already been written. If it has been written, we have the hash --- in the PatchInfoAnd, so we extract and return the info/hash. -writePatchIfNecessary :: RepoPatch p => Cache -> Compression - -> PatchInfoAnd rt p wX wY -> IO (PatchInfo, String) -writePatchIfNecessary c compr hp = infohp `seq` - case extractHash hp of - Right h -> return (infohp, h) - Left p -> (\h -> (infohp, h)) <$> - writeHashFile c compr HashedPatchesDir (showPatch p) - where - infohp = info hp - --- |pihash takes an info/hash pair, and renders the info, along with the hash --- as a Doc. -pihash :: (PatchInfo, String) -> Doc -pihash (pinf, hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n") - --- |listInventoriesWith returns a list of the inventories hashes. --- The function @f@ can be readInventoryPrivate or readInventoryLocalPrivate. --- The argument @hashedRepoDir@ is the path to the repository, --- where it's the 'hashed_inventory' file. --- The argument @darcsDir@ is the path to the directory of inventories files. -listInventoriesWith :: (String -> String - -> IO (Maybe String, [(PatchInfo, String)])) - -> String -> String -> IO [String] -listInventoriesWith f darcsDir hashedRepoDir = do - mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory - followStartingWiths mbStartingWithInv - where - getStartingWithHash invDir inv = - fst <$> f invDir inv - - followStartingWiths Nothing = return [] - followStartingWiths (Just startingWith) = do - mbNextInv <- getStartingWithHash (darcsDir inventoriesDir) startingWith - (startingWith :) <$> followStartingWiths mbNextInv - --- |listInventoriesBucketedWith is similar to listInventoriesWith, but --- it read the inventory directory under @darcsDir@ in bucketed format. -listInventoriesBucketedWith :: (String -> String - -> IO (Maybe String, [(PatchInfo, String)])) - -> String -> String -> IO [String] -listInventoriesBucketedWith f darcsDir hashedRepoDir = do - mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory - followStartingWiths mbStartingWithInv - where - getStartingWithHash invDir inv = - fst <$> f invDir inv - - followStartingWiths Nothing = return [] - followStartingWiths (Just startingWith) = do - mbNextInv <- getStartingWithHash - (darcsDir inventoriesDir bucketFolder startingWith) startingWith - (startingWith :) <$> followStartingWiths mbNextInv - --- |listInventories returns a list of the inventories hashes. --- This function attempts to retrieve missing inventory files. -listInventories :: IO [String] -listInventories = listInventoriesWith readInventoryPrivate darcsdir darcsdir - --- |readInventoryLocalPrivate reads the inventory with name @invName@ in @dir@ --- if it exist, otherwise returns an empty inventory. -readInventoryLocalPrivate :: String -> String - -> IO (Maybe String, [(PatchInfo, String)]) -readInventoryLocalPrivate dir invName = do - b <- doesFileExist (dir invName) - if b then readInventoryPrivate dir invName - else return (Nothing, []) - --- |listInventoriesLocal returns a list of the inventories hashes. --- This function does not attempt to retrieve missing inventory files. -listInventoriesLocal :: IO [String] -listInventoriesLocal = listInventoriesWith readInventoryLocalPrivate darcsdir darcsdir - --- |listInventoriesRepoDir returns a list of the inventories hashes. --- The argument @repoDir@ is the directory of the repository from which --- we are going to read the "hashed_inventory" file. --- The rest of hashed files are read from the global cache. -listInventoriesRepoDir :: String -> IO [String] -listInventoriesRepoDir repoDir = do - gCacheDir' <- globalCacheDir - let gCacheInvDir = fromJust gCacheDir' - listInventoriesBucketedWith readInventoryLocalPrivate gCacheInvDir (repoDir darcsdir) - --- |listPatchesLocal returns a list of the patches hashes, extracted --- from inventory files, by following the inventory "chain" of "Starting --- with inventory" hashes. This function does not attempt to download missing --- inventory files. --- The argument @darcsDir@ is the path to the darcs directory (e.g. "_darcs") --- of the repository from which we're going to read the inventories. -listPatchesLocal :: String -> IO [String] -listPatchesLocal darcsDir = do - inventory <- readInventoryPrivate darcsDir hashedInventory - followStartingWiths (fst inventory) (getPatches inventory) - where - followStartingWiths Nothing patches = return patches - followStartingWiths (Just startingWith) patches = do - inv <- readInventoryLocalPrivate (darcsDir inventoriesDir) startingWith - (patches++) <$> followStartingWiths (fst inv) (getPatches inv) - - getPatches inv = map snd (snd inv) - --- |listPatchesLocalBucketed is similar to listPatchesLocal, but --- it read the inventory directory under @darcsDir@ in bucketed format. -listPatchesLocalBucketed :: String -> String -> IO [String] -listPatchesLocalBucketed darcsDir hashedRepoDir = do - inventory <- readInventoryPrivate hashedRepoDir hashedInventory - followStartingWiths (fst inventory) (getPatches inventory) - where - followStartingWiths Nothing patches = return patches - followStartingWiths (Just startingWith) patches = do - inv <- readInventoryLocalPrivate - (darcsDir inventoriesDir bucketFolder startingWith) startingWith - (patches++) <$> followStartingWiths (fst inv) (getPatches inv) - - getPatches inv = map snd (snd inv) - --- | 'readPatchIds inventory' parses the content of a hashed_inventory file --- after the "pristine:" and "Starting with inventory:" header lines have --- been removed. The second value in the resulting tuples is the file hash --- of the associated patch (the "hash:" line). -readPatchIds :: B.ByteString -> [(PatchInfo, String)] -readPatchIds inv | B.null inv = [] -readPatchIds inv = case parseStrictly readPatchInfo inv of - Nothing -> [] - Just (pinfo, r) -> - case readHash r of - Nothing -> [] - Just (h, r') -> (pinfo, h) : readPatchIds r' - where - readHash :: B.ByteString -> Maybe (String, B.ByteString) - readHash s = let s' = dropSpace s - (l, r) = BC.break ('\n' ==) s' - (kw, h) = BC.break (' ' ==) l in - if kw /= BC.pack "hash:" || B.length h <= 1 - then Nothing - else Just (BC.unpack $ B.tail h, r) - --- |applyToTentativePristine applies a patch @p@ to the tentative pristine --- tree, and updates the tentative pristine hash -applyToTentativePristine :: (ApplyState p ~ Tree, Patchy p) => p wX wY - -> IO () -applyToTentativePristine p = do - tentativePristine <- gzReadFilePS tentativePristinePath - -- Extract the pristine hash from the tentativePristine file, using - -- inv2pris (this is valid since we normally just extract the hash from the - -- first line of an inventory file; we can pass in a one-line file that - -- just contains said hash). - let tentativePristineHash = inv2pris tentativePristine - newPristineHash <- applyToHashedPristine tentativePristineHash p - writeDocBinFile tentativePristinePath $ - pris2inv newPristineHash tentativePristine - --- | copyPristine copies a pristine tree into the current pristine dir, --- and possibly copies a clean working copy. --- The target is read from the passed-in dir/inventory name combination. -copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO () -copyPristine cache dir iname wwd = do - i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable - debugMessage $ "Copying hashed pristine tree: " ++ inv2pris i - let tediousName = "Copying pristine" - beginTedious tediousName - copyHashed tediousName cache wwd $ inv2pris i - endTedious tediousName - --- |copyPartialsPristine copies the pristine entries for a given list of --- filepaths. -copyPartialsPristine :: FilePathLike fp => Cache -> String - -> String -> [fp] -> IO () -copyPartialsPristine c d iname fps = do - i <- fetchFilePS (d ++ "/" ++ iname) Uncachable - copyPartialsHashed c (inv2pris i) fps - --- |pris2inv takes an updated pristine hash and an inventory, and outputs the --- new pristine hash followed by the original inventory (having skipped the old --- inventory hash). -pris2inv :: String -> B.ByteString -> Doc -pris2inv h inv = invisiblePS pristineName <> text h $$ - invisiblePS (skipPristine inv) - --- |inv2pris takes the content of an inventory, and extracts the corresponding --- pristine hash from the inventory (the hash is prefixed by "pristine:"). -inv2pris :: B.ByteString -> String -inv2pris inv = case tryDropPristineName inv of - Just rest -> case takeHash rest of - Just (h, _) -> h - Nothing -> error "Bad hash in inventory!" - Nothing -> sha256sum B.empty - --- |skipPristine drops the 'pristine: HASH' prefix line, if present. -skipPristine :: B.ByteString -> B.ByteString -skipPristine ps = case tryDropPristineName ps of - Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest - Nothing -> ps - --- |tryDropPristineName returns the result of dropping the pristineName from --- the input, if it was present, otherwise it returns Nothing. -tryDropPristineName :: B.ByteString -> Maybe B.ByteString -tryDropPristineName input = - if prefix == pristineName then Just rest else Nothing - where - (prefix, rest) = B.splitAt (B.length pristineName) input diff --git a/src/Darcs/Repository/Identify.hs b/src/Darcs/Repository/Identify.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Identify.hs @@ -0,0 +1,229 @@ +{-| +License : GPL-2 + +A set of functions to identify and find Darcs repositories +from a given @URL@ or a given filesystem path. +-} + +module Darcs.Repository.Identify + ( maybeIdentifyRepository + , identifyRepository + , identifyRepositoryFor + , IdentifyRepo(..) + , findRepository + , amInRepository + , amNotInRepository + , amInHashedRepository + , seekRepo + , findAllReposInDir + ) where + +import Prelude () +import Darcs.Prelude + +import Control.Monad ( forM ) +import Darcs.Repository.Format ( tryIdentifyRepoFormat + , readProblem + , transferProblem + ) +import System.Directory ( doesDirectoryExist + , setCurrentDirectory + , createDirectoryIfMissing + , doesFileExist + , getDirectoryContents + ) +import System.FilePath.Posix ( () ) +import System.IO.Error ( catchIOError ) +import Data.Maybe ( fromMaybe ) + +import Darcs.Repository.Old ( oldRepoFailMsg ) +import Darcs.Repository.Flags ( UseCache(..), WorkRepo (..) ) +import Darcs.Util.Path + ( toFilePath + , ioAbsoluteOrRemote + , toPath + ) +import Darcs.Util.Exception ( catchall ) +import Darcs.Util.URL ( isValidLocalPath ) +import Darcs.Util.Workaround + ( getCurrentDirectory + ) +import Darcs.Repository.Prefs ( getCaches ) +import Darcs.Repository.InternalTypes( Repository + , PristineType(..) + , mkRepo + , repoFormat + , repoPristineType + ) +import Darcs.Util.Global ( darcsdir ) + +import System.Mem( performGC ) + +-- | The status of a given directory: is it a darcs repository? +data IdentifyRepo rt p wR wU wT + = BadRepository String -- ^ looks like a repository with some error + | NonRepository String -- ^ safest guess + | GoodRepository (Repository rt p wR wU wT) + +-- | Tries to identify the repository in a given directory +maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo rt p wR wU wT) +maybeIdentifyRepository useCache "." = + do darcs <- doesDirectoryExist darcsdir + if not darcs + then return (NonRepository $ "Missing " ++ darcsdir ++ " directory") + else do + repoFormatOrError <- tryIdentifyRepoFormat "." + here <- toPath `fmap` ioAbsoluteOrRemote "." + case repoFormatOrError of + Left err -> return $ NonRepository err + Right rf -> + case readProblem rf of + Just err -> return $ BadRepository err + Nothing -> do pris <- identifyPristine + cs <- getCaches useCache here + return $ GoodRepository $ mkRepo here rf pris cs +maybeIdentifyRepository useCache url' = + do url <- toPath `fmap` ioAbsoluteOrRemote url' + repoFormatOrError <- tryIdentifyRepoFormat url + case repoFormatOrError of + Left e -> return $ NonRepository e + Right rf -> case readProblem rf of + Just err -> return $ BadRepository err + Nothing -> do cs <- getCaches useCache url + return $ GoodRepository $ mkRepo url rf NoPristine cs + +identifyPristine :: IO PristineType +identifyPristine = + do pristine <- doesDirectoryExist $ darcsdir++"/pristine" + current <- doesDirectoryExist $ darcsdir++"/current" + hashinv <- doesFileExist $ darcsdir++"/hashed_inventory" + case (pristine || current, hashinv) of + (False, False) -> return NoPristine + (True, False) -> return PlainPristine + (False, True ) -> return HashedPristine + _ -> fail "Multiple pristine trees." + +-- | identifyRepository identifies the repo at 'url'. Warning: +-- you have to know what kind of patches are found in that repo. +identifyRepository :: forall rt p wR wU wT. UseCache -> String + -> IO (Repository rt p wR wU wT) +identifyRepository useCache url = + do er <- maybeIdentifyRepository useCache url + case er of + BadRepository s -> fail s + NonRepository s -> fail s + GoodRepository r -> return r + +-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url', +-- but fails if it is not compatible for reading from and writing to. +identifyRepositoryFor :: forall rt p wR wU wT vR vU vT. + Repository rt p wR wU wT + -> UseCache + -> String + -> IO (Repository rt p vR vU vT) +identifyRepositoryFor source useCache url = + do target <- identifyRepository useCache url + case transferProblem (repoFormat target) (repoFormat source) of + Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e + Nothing -> return target + +amInRepository :: WorkRepo -> IO (Either String ()) +amInRepository (WorkRepoDir d) = + do + setCurrentDirectory d + status <- maybeIdentifyRepository YesUseCache "." + case status of + GoodRepository _ -> return (Right ()) + BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e) + NonRepository _ -> return (Left "You need to be in a repository directory to run this command.") + `catchIOError` + \e -> return (Left (show e)) + +amInRepository _ = + fromMaybe (Left "You need to be in a repository directory to run this command.") <$> seekRepo + +amInHashedRepository :: WorkRepo -> IO (Either String ()) +amInHashedRepository wd + = do inrepo <- amInRepository wd + case inrepo of + Right _ -> do pristine <- identifyPristine + case pristine of + HashedPristine -> return (Right ()) + _ -> return (Left oldRepoFailMsg) + left -> return left + +-- | hunt upwards for the darcs repository +-- This keeps changing up one parent directory, testing at each +-- step if the current directory is a repository or not. $ +-- The result is: +-- Nothing, if no repository found +-- Just (Left errorMessage), if bad repository found +-- Just (Right ()), if good repository found. +-- WARNING this changes the current directory for good if matchFn succeeds +seekRepo :: IO (Maybe (Either String ())) +seekRepo = getCurrentDirectory >>= helper where + helper startpwd = do + status <- maybeIdentifyRepository YesUseCache "." + case status of + GoodRepository _ -> return . Just $ Right () + BadRepository e -> return . Just $ Left e + NonRepository _ -> + do cd <- toFilePath `fmap` getCurrentDirectory + setCurrentDirectory ".." + cd' <- toFilePath `fmap` getCurrentDirectory + if cd' /= cd + then helper startpwd + else do setCurrentDirectory startpwd + return Nothing + +-- 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 :: WorkRepo -> 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 WorkRepoCurrentDir +amNotInRepository _ = do + status <- maybeIdentifyRepository YesUseCache "." + case status of + GoodRepository _ -> return (Left "You may not run this command in a repository.") + BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e) + NonRepository _ -> return (Right ()) + +findRepository :: WorkRepo -> IO (Either String ()) +findRepository workrepo = + case workrepo of + WorkRepoPossibleURL d | isValidLocalPath d -> do + setCurrentDirectory d + findRepository WorkRepoCurrentDir + WorkRepoDir d -> do + setCurrentDirectory d + findRepository WorkRepoCurrentDir + _ -> fromMaybe (Right ()) <$> seekRepo + `catchIOError` \e -> + return (Left (show e)) + +-- | @findAllReposInDir topDir@ returns all paths to repositories under @topDir@. +findAllReposInDir :: FilePath -> IO [FilePath] +findAllReposInDir topDir = do + isDir <- doesDirectoryExist topDir + if isDir + then do + status <- maybeIdentifyRepository NoUseCache topDir + case status of + GoodRepository repo + | HashedPristine <- repoPristineType repo -> return [topDir] + | otherwise -> return [] -- old fashioned or broken repo + _ -> getRecursiveDarcsRepos' topDir + else return [] + where + getRecursiveDarcsRepos' d = do + names <- getDirectoryContents d + let properNames = filter (\x -> head x /= '.') names + paths <- forM properNames $ \name -> do + let path = d name + findAllReposInDir path + return (concat paths) diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs deleted file mode 100644 --- a/src/Darcs/Repository/Internal.hs +++ /dev/null @@ -1,1092 +0,0 @@ --- 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. - -{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-} - -module Darcs.Repository.Internal - ( Repository(..) - , maybeIdentifyRepository - , identifyRepository - , identifyRepositoryFor - , IdentifyRepo(..) - , findRepository - , amInRepository - , amNotInRepository - , amInHashedRepository - , revertRepositoryChanges - , announceMergeConflicts - , setTentativePending - , checkUnrecordedConflicts - , readRepo - , readTentativeRepo - , readRepoUsingSpecificInventory - , prefsUrl - , withRecorded - , withTentative - , tentativelyAddPatch - , tentativelyRemovePatches - , tentativelyRemovePatches_ - , tentativelyRemoveFromPending - , tentativelyAddToPending - , tentativelyAddPatch_ - , tentativelyAddPatches_ - , tentativelyReplacePatches - , finalizeRepositoryChanges - , unrevertUrl - , applyToWorking - , createPristineDirectoryTree - , createPartialsPristineDirectoryTree - , reorderInventory - , cleanRepository - , setScriptsExecutable - , setScriptsExecutablePatches - , UpdatePristine(..) - , MakeChanges(..) - , applyToTentativePristine - , makeNewPending - , seekRepo - , repoPatchType - , repoXor - ) where - -import Prelude () -import Darcs.Prelude - -import Darcs.Util.Printer ( putDocLn - , (<+>) - , text - , ($$) - , redText - , putDocLnWith - , ($$) - ) -import Darcs.Util.Printer.Color (fancyPrinters) -import Darcs.Util.Crypt.SHA1 ( SHA1, sha1Xor, zero ) -import Darcs.Repository.State ( readRecorded - , readWorking - , updateIndex - ) -import Darcs.Repository.Pending - ( readPending - , readTentativePending - , writeTentativePending - , readNewPending - , writeNewPending - , pendingName - ) -import System.Exit ( exitSuccess ) -import Darcs.Repository.ApplyPatches - ( runTolerantly - , runSilently - , runDefault - ) - -import Darcs.Util.SignalHandler ( withSignalsBlocked ) -import Darcs.Repository.Format ( RepoFormat - , RepoProperty( HashedInventory - , NoWorkingDir - ) - , tryIdentifyRepoFormat - , formatHas - , readProblem - , transferProblem - ) -import System.Directory ( doesDirectoryExist - , setCurrentDirectory - , createDirectoryIfMissing - , doesFileExist - ) -import Control.Monad ( when - , unless - , filterM - , void - ) - -import Control.Exception ( catch, IOException ) - -import qualified Data.ByteString as B ( readFile - , isPrefixOf - ) -import qualified Data.ByteString.Char8 as BC (pack) -import Data.List( foldl' ) -import Data.List.Ordered ( nubSort ) -import Data.Maybe ( fromMaybe ) -import Darcs.Patch ( Effect - , primIsHunk - , primIsBinary - , description - , tryToShrink - , commuteFLorComplain - , commute - , fromPrim - , RepoPatch - , IsRepoType - , Patchy - , merge - , listConflictedFiles - , listTouchedFiles - , WrappedNamed - , commuteRL - , fromPrims - , readPatch - , effect - , invert - , primIsAddfile - , primIsAdddir - , primIsSetpref - , apply - , applyToTree - ) - -import Darcs.Patch.Dummy ( DummyPatch ) - -import Darcs.Patch.Apply ( ApplyState ) - -import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.Prim ( PrimPatchBase - , PrimOf - , tryShrinkingInverse - , PrimPatch - ) -import Darcs.Patch.Bundle ( scanBundle - , makeBundleN - ) -import Darcs.Patch.Info ( isTag, makePatchname ) -import Darcs.Patch.Named.Wrapped ( namedIsInternal ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd - , hopefully - , info - ) -import Darcs.Patch.Type ( PatchType(..) ) - -import qualified Darcs.Repository.HashedRepo as HashedRepo - ( revertTentativeChanges - , finalizeTentativeChanges - , removeFromTentativeInventory - , copyPristine - , copyPartialsPristine - , applyToTentativePristine - , addToTentativeInventory - , readRepo - , readTentativeRepo - , readRepoUsingSpecificInventory - , cleanPristine - , cleanInventories - , cleanPatches - ) -import qualified Darcs.Repository.Old as Old - ( revertTentativeChanges - , readOldRepo - , oldRepoFailMsg - ) -import Darcs.Repository.Flags - ( Compression, Verbosity(..), UseCache(..), UpdateWorking (..), AllowConflicts (..), ExternalMerge (..) - , WorkRepo (..), WithWorkingDir (WithWorkingDir) ) -import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) -import Darcs.Patch.Witnesses.Unsafe - ( unsafeCoerceP, unsafeCoercePStart ) -import Darcs.Patch.Witnesses.Ordered - ( FL(..) - , RL(..) - , (:\/:)(..) - , (:/\:)(..) - , (:>)(..) - , (+>+) - , (+<+) - , lengthFL - , allFL - , filterOutFLFL - , reverseFL - , mapFL_FL - , concatFL - , reverseRL - , mapRL - ) -import Darcs.Patch.Witnesses.Sealed - ( Sealed(Sealed) - , seal - , FlippedSeal(FlippedSeal) - , flipSeal - , mapSeal - ) -import Darcs.Patch.Permutations ( commuteWhatWeCanFL - , removeFL - ) -import Darcs.Patch.Set ( PatchSet(..) - , SealedPatchSet - , newset2RL - , Origin - ) -import Darcs.Patch.Depends ( removeFromPatchSet - , mergeThem - , splitOnTag - ) -import Darcs.Patch.Show ( ShowPatch ) -import Darcs.Util.Path - ( FilePathLike - , AbsolutePath - , toFilePath - , ioAbsoluteOrRemote - , toPath - , anchorPath - ) -import Darcs.Util.Exception ( catchall ) -import Darcs.Util.File ( withCurrentDirectory ) -import Darcs.Util.Prompt ( promptYorn ) -import Darcs.Util.Progress ( debugMessage ) -import Darcs.Patch.Progress (progressFL) -import Darcs.Util.URL ( isValidLocalPath ) -import Darcs.Util.Workaround - ( getCurrentDirectory - , renameFile - , setExecutable - ) -import Darcs.Repository.Prefs ( getCaches ) -import Darcs.Util.Lock - ( writeDocBinFile - , removeFileMayNotExist - ) -import Darcs.Repository.InternalTypes( Repository(..) - , Pristine(..) - ) -import Darcs.Util.Global ( darcsdir ) - -import System.Mem( performGC ) - -import Darcs.Util.Tree ( Tree ) -import qualified Darcs.Util.Tree as Tree -import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist ) -#include "impossible.h" - --- | The status of a given directory: is it a darcs repository? -data IdentifyRepo rt p wR wU wT - = BadRepository String -- ^ looks like a repository with some error - | NonRepository String -- ^ safest guess - | GoodRepository (Repository rt p wR wU wT) - --- | Tries to identify the repository in a given directory -maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo rt p wR wU wT) -maybeIdentifyRepository useCache "." = - do darcs <- doesDirectoryExist darcsdir - if not darcs - then return (NonRepository $ "Missing " ++ darcsdir ++ " directory") - else do - repoFormatOrError <- tryIdentifyRepoFormat "." - here <- toPath `fmap` ioAbsoluteOrRemote "." - case repoFormatOrError of - Left err -> return $ NonRepository err - Right rf -> - case readProblem rf of - Just err -> return $ BadRepository err - Nothing -> do pris <- identifyPristine - cs <- getCaches useCache here - return $ GoodRepository $ Repo here rf pris cs -maybeIdentifyRepository useCache url' = - do url <- toPath `fmap` ioAbsoluteOrRemote url' - repoFormatOrError <- tryIdentifyRepoFormat url - case repoFormatOrError of - Left e -> return $ NonRepository e - Right rf -> case readProblem rf of - Just err -> return $ BadRepository err - Nothing -> do cs <- getCaches useCache url - return $ GoodRepository $ Repo url rf NoPristine cs - -identifyPristine :: IO Pristine -identifyPristine = - do pristine <- doesDirectoryExist $ darcsdir++"/pristine" - current <- doesDirectoryExist $ darcsdir++"/current" - hashinv <- doesFileExist $ darcsdir++"/hashed_inventory" - case (pristine || current, hashinv) of - (False, False) -> return NoPristine - (True, False) -> return PlainPristine - (False, True ) -> return HashedPristine - _ -> fail "Multiple pristine trees." - --- | identifyRepository identifies the repo at 'url'. Warning: --- you have to know what kind of patches are found in that repo. -identifyRepository :: forall rt p wR wU wT. UseCache -> String - -> IO (Repository rt p wR wU wT) -identifyRepository useCache url = - do er <- maybeIdentifyRepository useCache url - case er of - BadRepository s -> fail s - NonRepository s -> fail s - GoodRepository r -> return r - --- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url', --- but fails if it is not compatible for reading from and writing to. -identifyRepositoryFor :: forall rt p wR wU wT vR vU vT. RepoPatch p - => Repository rt p wR wU wT - -> UseCache - -> String - -> IO (Repository rt p vR vU vT) -identifyRepositoryFor (Repo _ source _ _) useCache url = - do Repo absurl target x c <- identifyRepository useCache url - case transferProblem target source of - Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e - Nothing -> return $ Repo absurl target x c - -amInRepository :: WorkRepo -> IO (Either String ()) -amInRepository (WorkRepoDir d) = do - setCurrentDirectory d `catchall` fail ("can't set directory to "++d) - status <- maybeIdentifyRepository YesUseCache "." - case status of - GoodRepository _ -> return (Right ()) - BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e) - NonRepository _ -> return (Left "You need to be in a repository directory to run this command.") -amInRepository _ = - fromMaybe (Left "You need to be in a repository directory to run this command.") <$> seekRepo - -amInHashedRepository :: WorkRepo -> IO (Either String ()) -amInHashedRepository wd - = do inrepo <- amInRepository wd - case inrepo of - Right _ -> do pristine <- identifyPristine - case pristine of - HashedPristine -> return (Right ()) - _ -> return (Left Old.oldRepoFailMsg) - left -> return left - -repoPatchType :: Repository rt p wR wU wT -> PatchType rt p -repoPatchType _ = PatchType - --- | hunt upwards for the darcs repository --- This keeps changing up one parent directory, testing at each --- step if the current directory is a repository or not. $ --- The result is: --- Nothing, if no repository found --- Just (Left errorMessage), if bad repository found --- Just (Right ()), if good repository found. --- WARNING this changes the current directory for good if matchFn succeeds -seekRepo :: IO (Maybe (Either String ())) -seekRepo = getCurrentDirectory >>= helper where - helper startpwd = do - status <- maybeIdentifyRepository YesUseCache "." - case status of - GoodRepository _ -> return . Just $ Right () - BadRepository e -> return . Just $ Left e - NonRepository _ -> - do cd <- toFilePath `fmap` getCurrentDirectory - setCurrentDirectory ".." - cd' <- toFilePath `fmap` getCurrentDirectory - if cd' /= cd - then helper startpwd - else do setCurrentDirectory startpwd - return Nothing - --- 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 :: WorkRepo -> 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 WorkRepoCurrentDir -amNotInRepository _ = do - status <- maybeIdentifyRepository YesUseCache "." - case status of - GoodRepository _ -> return (Left "You may not run this command in a repository.") - BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e) - NonRepository _ -> return (Right ()) - -findRepository :: WorkRepo -> IO (Either String ()) -findRepository (WorkRepoPossibleURL d) | isValidLocalPath d = - do setCurrentDirectory d `catchall` fail ("can't set directory to "++d) - findRepository WorkRepoCurrentDir -findRepository (WorkRepoDir d) = - do setCurrentDirectory d `catchall` fail ("can't set directory to "++d) - findRepository WorkRepoCurrentDir -findRepository _ = fromMaybe (Right ()) <$> seekRepo - --- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2 -readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO (Sealed ((FL p) wT)) -readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo - - --- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the --- @pendPs@ could be applied to pristine if we wanted to, and if so --- writes it to disk. If it can't be applied, @pendPs@ must --- be somehow buggy, so we save it for forensics and crash. -makeNewPending :: forall rt p wR wU wT wY. (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> UpdateWorking - -> FL (PrimOf p) wT wY - -> IO () -makeNewPending _ NoUpdateWorking _ = return () -makeNewPending repo@(Repo r _ _ _) YesUpdateWorking origp = - withCurrentDirectory r $ - do let newname = pendingName ++ ".new" - debugMessage $ "Writing new pending: " ++ newname - Sealed sfp <- return $ siftForPending origp - writeNewPending repo sfp - cur <- readRecorded repo - Sealed p <- readNewPendingLL repo -- :: IO (Sealed (FL (PrimOf p) wT)) - -- We don't ever use the resulting tree. - _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do - let buggyname = pendingName ++ "_buggy" - renameFile newname buggyname - bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err) - $$ text "If possible, please send the contents of" - <+> text buggyname - $$ text "along with a bug report." - renameFile newname pendingName - debugMessage $ "Finished writing new pending: " ++ newname - --- | @siftForPending ps@ simplifies the candidate pending patch @ps@ --- through a combination of looking for self-cancellations --- (sequences of patches followed by their inverses), coalescing, --- and getting rid of any hunk/binary patches we can commute out --- the back --- --- The visual image of sifting can be quite helpful here. We are --- repeatedly tapping (shrinking) the patch sequence and --- shaking it (sift). Whatever falls out is the pending we want --- to keep. We do this until the sequence looks about as clean as --- we can get it -siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX) -siftForPending simple_ps = - if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps - then seal oldps - else fromJust $ do - Sealed x <- return $ sift NilFL $ reverseFL oldps - return $ case tryToShrink x of - ps | lengthFL ps < lengthFL oldps -> siftForPending ps - | otherwise -> seal ps - where - oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps - -- get rid of any hunk/binary patches that we can commute out the - -- back (ie. we work our way backwards, pushing the patches down - -- to the very end and popping them off; so in (addfile f :> hunk) - -- we can nuke the hunk, but not so in (hunk :> replace) - sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC) - sift sofar NilRL = seal sofar - sift sofar (ps:<:p) | primIsHunk p || primIsBinary p = - case commuteFLorComplain (p :> sofar) of - Right (sofar' :> _) -> sift sofar' ps - Left _ -> sift (p:>:sofar) ps - sift sofar (ps:<:p) = sift (p:>:sofar) ps - -readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> IO (PatchSet rt p Origin wT) -readTentativeRepo repo@(Repo r rf _ _) - | formatHas HashedInventory rf = HashedRepo.readTentativeRepo repo r - | otherwise = fail Old.oldRepoFailMsg - -readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => String - -> Repository rt p wR wU wT - -> IO (PatchSet rt p Origin wT) -readRepoUsingSpecificInventory invPath repo@(Repo r rf _ _) - | formatHas HashedInventory rf = - HashedRepo.readRepoUsingSpecificInventory invPath repo r - | otherwise = fail Old.oldRepoFailMsg - -prefsUrl :: Repository rt p wR wU wT -> String -prefsUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/prefs" - -unrevertUrl :: Repository rt p wR wU wT -> String -unrevertUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/patches/unrevert" - -applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) - => Repository rt p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY - -> IO (Repository rt p wR wY wT) -applyToWorking (Repo r rf t c) verb patch = - do - unless (formatHas NoWorkingDir rf) $ - withCurrentDirectory r $ if verb == Quiet - then runSilently $ apply patch - else runTolerantly $ apply patch - return (Repo r rf t c) - --- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it --- adds a patch to the repository (eg. with apply or record). --- Think of it as one part of transferring patches from pending to --- somewhere else. --- --- Question (Eric Kow): how do we detect patch equivalence? -tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p) - => Repository rt p wR wU wT - -> UpdateWorking - -> PatchInfoAnd rt p wX wY - -> IO () -tentativelyRemoveFromPending _ NoUpdateWorking _ = return () -tentativelyRemoveFromPending repo YesUpdateWorking p = do - Sealed pend <- readTentativePending repo - -- Question (Eric Kow): why does pending being all simple matter for - -- changepref patches in p? isSimple includes changepref, so what do - -- adddir/etc have to do with it? Why don't we we systematically - -- crudeSift/not? - let effectp = if isSimple pend - then crudeSift $ effect p - else effect p - Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) - (unsafeCoercePStart pend) - writeTentativePending repo (unsafeCoercePStart newpend) - where - -- @rmpend effect pending@ removes as much of @effect@ from @pending@ - -- as possible - -- - -- Note that @effect@ and @pending@ must start from the same context - -- This is not a bad thing to assume because @effect@ is a patch we want to - -- add to the repository anyway so it'd kind of have to start from wR anyway - -- - -- Question (Eric Kow), ok then why not - -- @PatchInfoAnd p wR wY@ in the type signature above? - rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB) - rmpend NilFL x = Sealed x - rmpend _ NilFL = Sealed NilFL - rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys - rmpend (x:>:xs) ys = - case commuteWhatWeCanFL (x:>xs) of - a:>x':>b -> case rmpend a ys of - Sealed ys' -> case commute (invert (x':>:b) :> ys') of - Just (ys'' :> _) -> seal ys'' - Nothing -> seal $ invert (x':>:b)+>+ys' - -- DJR: I don't think this last case should be - -- reached, but it also shouldn't lead to corruption. - --- | A sequence of primitive patches (candidates for the pending patch) --- is considered simple if we can reason about their continued status as --- pending patches solely on the basis of them being hunk/binary patches. --- --- Simple here seems to mean that all patches are either hunk/binary --- patches, or patches that cannot (indirectly) depend on hunk/binary --- patches. For now, the only other kinds of patches in this category --- are changepref patches. --- --- It might be tempting to add, say, adddir patches but it's probably not a --- good idea because Darcs also inverts patches a lot in its reasoning so an --- innocent addir may be inverted to a rmdir which in turn may depend on --- a rmfile, which in turn depends on a hunk/binary. Likewise, we would --- not want to add move patches to this category for similar reasons of --- a potential dependency chain forming. -isSimple :: PrimPatch prim => FL prim wX wY -> Bool -isSimple = - allFL isSimp - where - isSimp x = primIsHunk x || primIsBinary x || primIsSetpref x - --- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending' --- that works without having to do any commutation. It either returns a --- sifted pending (if the input is simple enough for this crude approach) --- or has no effect. -crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY -crudeSift xs = - if isSimple xs then filterOutFLFL ishunkbinary xs else xs - where - ishunkbinary :: prim wA wB -> EqCheck wA wB - 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 }) - | formatHas HashedInventory rf = h - | otherwise = o - -data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) - -announceMergeConflicts :: (PrimPatch p, PatchInspect p) - => String - -> AllowConflicts - -> ExternalMerge - -> FL p wX wY - -> IO Bool -announceMergeConflicts cmd allowConflicts externalMerge resolved_pw = - case nubSort $ listTouchedFiles resolved_pw of - [] -> return False - cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark] - || externalMerge /= NoExternalMerge - then do putDocLnWith fancyPrinters $ - redText "We have conflicts in the following files:" $$ text (unlines cfs) - return True - else do putDocLnWith fancyPrinters $ - redText "There are conflicts in the following files:" $$ text (unlines cfs) - fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++ - "If you would rather apply the patch and mark the conflicts,\n"++ - "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++ - "These can set as defaults by adding\n"++ - " "++cmd++" mark-conflicts\n"++ - "to "++darcsdir++"/prefs/defaults in the target repo. " - -checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p - => UpdateWorking - -> FL (WrappedNamed rt p) wT wY - -> IO Bool -checkUnrecordedConflicts NoUpdateWorking _ - = return False -- because we are called by `darcs convert` hence we don't care -checkUnrecordedConflicts _ pc = - do repository <- identifyRepository NoUseCache "." - cuc repository - where cuc :: Repository rt p wR wU wT -> IO Bool - cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT)) - case mpend of - NilFL -> return False - pend -> - case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of - _ :/\: pend' -> - case listConflictedFiles pend' of - [] -> return False - fs -> do putStrLn ("You have conflicting local changes to:\n" - ++ unwords fs) - confirmed <- promptYorn "Proceed?" - unless confirmed $ - do putStrLn "Cancelled." - exitSuccess - return True - fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB - fromPrims_ = fromPrims - -tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> Compression - -> Verbosity - -> UpdateWorking - -> PatchInfoAnd rt p wT wY - -> IO (Repository rt p wR wU wY) -tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine - -data UpdatePristine = UpdatePristine - | DontUpdatePristine - | DontUpdatePristineNorRevert deriving Eq - -tentativelyAddPatches_ - :: forall rt p wR wU wT wY - . (RepoPatch p, ApplyState p ~ Tree) - => UpdatePristine - -> Repository rt p wR wU wT - -> Compression - -> Verbosity - -> UpdateWorking - -> FL (PatchInfoAnd rt p) wT wY - -> IO (Repository rt p wR wU wY) -tentativelyAddPatches_ _up r _compr _verb _uw NilFL = return r -tentativelyAddPatches_ up r compr verb uw (p:>:ps) = do - r' <- tentativelyAddPatch_ up r compr verb uw p - tentativelyAddPatches_ up r' compr verb uw ps - --- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun --- :: Bool, with dryRun = unsafePerformIO $ readIORef ... -tentativelyAddPatch_ :: forall rt p wR wU wT wY - . (RepoPatch p, ApplyState p ~ Tree) - => UpdatePristine - -> Repository rt p wR wU wT - -> Compression - -> Verbosity - -> UpdateWorking - -> PatchInfoAnd rt p wT wY - -> IO (Repository rt p wR wU wY) - -tentativelyAddPatch_ up r@(Repo dir rf t c) compr verb uw p = - withCurrentDirectory dir $ do - decideHashedOrNormal rf HvsO { - hashed = void $ HashedRepo.addToTentativeInventory c compr p, - old = fail Old.oldRepoFailMsg} - when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." - applyToTentativePristine r verb p - debugMessage "Updating pending..." - tentativelyRemoveFromPending r uw p - return (Repo dir rf t c) - -applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q) - => Repository rt p wR wU wT - -> Verbosity - -> q wT wY - -> IO () -applyToTentativePristine (Repo dir rf _ _) verb p = - withCurrentDirectory dir $ - do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p - decideHashedOrNormal rf HvsO {hashed = HashedRepo.applyToTentativePristine p, - old = fail Old.oldRepoFailMsg} - --- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@ --- appends @ps@ to the pending patch. --- --- It has no effect with @NoUpdateWorking@. --- --- This fuction is unsafe because it accepts a patch that works on the --- tentative pending and we don't currently track the state of the --- tentative pending. -tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p - => Repository rt p wR wU wT - -> UpdateWorking - -> FL (PrimOf p) wX wY - -> IO () -tentativelyAddToPending _ NoUpdateWorking _ = return () -tentativelyAddToPending repo@(Repo dir _ _ _) YesUpdateWorking patch = - withCurrentDirectory dir $ do - Sealed pend <- readTentativePending repo - FlippedSeal newpend_ <- return $ - newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch - writeTentativePending repo (unsafeCoercePStart newpend_) - where - newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC - newpend NilFL patch_ = flipSeal patch_ - newpend p patch_ = flipSeal $ p +>+ patch_ - --- | setTentativePending is basically unsafe. It overwrites the pending --- state with a new one, not related to the repository state. -setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p - => Repository rt p wR wU wT - -> UpdateWorking - -> FL (PrimOf p) wX wY - -> IO () -setTentativePending _ NoUpdateWorking _ = return () -setTentativePending repo@(Repo dir _ _ _) YesUpdateWorking patch = do - Sealed prims <- return $ siftForPending patch - withCurrentDirectory dir $ writeTentativePending repo (unsafeCoercePStart prims) - --- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch --- It's used right before removing @ps@ from the repo. This ensures that --- the pending patch can still be applied on top of the recorded state. --- --- This function is basically unsafe. It overwrites the pending state --- with a new one, not related to the repository state. -prepend :: forall rt p wR wU wT wX wY. RepoPatch p - => Repository rt p wR wU wT - -> UpdateWorking - -> FL (PrimOf p) wX wY - -> IO () -prepend _ NoUpdateWorking _ = return () -prepend repo YesUpdateWorking patch = do - Sealed pend <- readTentativePending repo - Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch - writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_) - where - newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA) - newpend NilFL patch_ = seal patch_ - newpend p patch_ = seal $ patch_ +>+ p - -tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> Compression - -> UpdateWorking - -> FL (PatchInfoAnd rt p) wX wT - -> IO (Repository rt p wR wU wX) -tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine - -tentativelyRemovePatches_ :: forall rt p wR wU wT wX - . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => UpdatePristine - -> Repository rt p wR wU wT - -> Compression - -> UpdateWorking - -> FL (PatchInfoAnd rt p) wX wT - -> IO (Repository rt p wR wU wX) -tentativelyRemovePatches_ up repository@(Repo dir rf t c) compr uw ps = - withCurrentDirectory dir $ do - when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." - prepend repository uw $ effect ps - unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext repository ps - debugMessage "Removing changes from tentative inventory..." - if formatHas HashedInventory rf - then do HashedRepo.removeFromTentativeInventory repository compr ps - when (up == UpdatePristine) $ - HashedRepo.applyToTentativePristine $ - progressFL "Applying inverse to pristine" $ invert ps - else fail Old.oldRepoFailMsg - return (Repo dir rf t c) - --- FIXME this is a rather weird API. If called with a patch that isn't already --- in the repo, it fails with an obscure error from 'commuteToEnd'. It also --- ends up redoing the work that the caller has already done - if it has --- already commuted these patches to the end, it must also know the commuted --- versions of the other patches in the repo. --- |Given a sequence of patches anchored at the end of the current repository, --- actually pull them to the end of the repository by removing any patches --- with the same name and then adding the passed in sequence. --- Typically callers will have obtained the passed in sequence using --- 'findCommon' and friends. -tentativelyReplacePatches :: forall rt p wR wU wT wX - . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> Compression - -> UpdateWorking - -> Verbosity - -> FL (PatchInfoAnd rt p) wX wT - -> IO () -tentativelyReplacePatches repository compr uw verb ps = - do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps - repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps' - mapAdd repository' ps' - where mapAdd :: Repository rt p wM wL wI - -> FL (PatchInfoAnd rt p) wI wJ - -> IO () - mapAdd _ NilFL = return () - mapAdd r (a:>:as) = - do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a - mapAdd r' as - --- | Replace the pending patch with the tentative pending. --- If @NoUpdateWorking@, this merely deletes the tentative pending --- without replacing the current one. --- --- Question (Eric Kow): shouldn't this also delete the tentative --- pending if @YesUpdateWorking@? I'm just puzzled by the seeming --- inconsistency of the @NoUpdateWorking@ doing deletion, but --- @YesUpdateWorking@ not bothering. -finalizePending :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> UpdateWorking - -> IO () -finalizePending (Repo dir _ _ _) NoUpdateWorking = - withCurrentDirectory dir $ removeFileMayNotExist pendingName -finalizePending repository@(Repo dir _ _ _) updateWorking@YesUpdateWorking = - withCurrentDirectory dir $ do - Sealed tpend <- readTentativePending repository - Sealed new_pending <- return $ siftForPending tpend - makeNewPending repository updateWorking new_pending - -finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> UpdateWorking - -> Compression - -> IO () -finalizeRepositoryChanges repository@(Repo dir rf _ _) updateWorking compr - | formatHas HashedInventory rf = - withCurrentDirectory dir $ do - debugMessage "Finalizing changes..." - withSignalsBlocked $ do - HashedRepo.finalizeTentativeChanges repository compr - finalizePending repository updateWorking - debugMessage "Done finalizing changes..." - doesPatchIndexExist dir >>= (`when` createOrUpdatePatchIndexDisk repository) - updateIndex repository - | otherwise = fail Old.oldRepoFailMsg - --- TODO: rename this and document the transaction protocol (revert/finalize) --- clearly. --- |Slightly confusingly named: as well as throwing away any tentative --- changes, revertRepositoryChanges also re-initialises the tentative state. --- It's therefore used before makign any changes to the repo. -revertRepositoryChanges :: RepoPatch p - => Repository rt p wR wU wT - -> UpdateWorking - -> IO () -revertRepositoryChanges r@(Repo dir rf _ _) uw = - withCurrentDirectory dir $ - do removeFileMayNotExist (pendingName ++ ".tentative") - Sealed x <- readPending r - setTentativePending r uw x - when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName - decideHashedOrNormal rf HvsO { hashed = HashedRepo.revertTentativeChanges, - old = Old.revertTentativeChanges } - -removeFromUnrevertContext :: forall rt p wR wU wT wX - . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> FL (PatchInfoAnd rt p) wX wT - -> IO () -removeFromUnrevertContext repository ps = do - Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL)) - remove_from_unrevert_context_ bundle - where unrevert_impossible = - do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?" - if confirmed then removeFileMayNotExist (unrevertUrl repository) - else fail "Cancelled." - unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin) - unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository) - case scanBundle pf of - Right foo -> return foo - Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err - remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO () - remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return () - remove_from_unrevert_context_ bundle = - do debugMessage "Adjusting the context of the unrevert changes..." - debugMessage $ "Removing "++ show (lengthFL ps) ++ - " patches in removeFromUnrevertContext!" - ref <- readTentativeRepo repository - let withSinglet :: Sealed (FL ppp wXxx) - -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO () - withSinglet (Sealed (x :>: NilFL)) j = j x - withSinglet _ _ = return () - withSinglet (mergeThem ref bundle) $ \h_us -> - case commuteRL (reverseFL ps :> h_us) of - Nothing -> unrevert_impossible - Just (us' :> _) -> - case removeFromPatchSet ps ref of - Nothing -> unrevert_impossible - Just common -> - do debugMessage "Have now found the new context..." - bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL) - writeDocBinFile (unrevertUrl repository) bundle' - debugMessage "Done adjusting the context of the unrevert changes!" - -cleanRepository :: RepoPatch p => Repository rt p wR wU wT -> IO () -cleanRepository repository@(Repo _ rf _ _) = - decideHashedOrNormal rf - HvsO { hashed = cleanHashedRepo repository, - old = fail Old.oldRepoFailMsg} - where - cleanHashedRepo r = do - HashedRepo.cleanPristine r - HashedRepo.cleanInventories r - HashedRepo.cleanPatches r - - --- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree, --- possibly writing a clean working copy in the process. -createPristineDirectoryTree :: RepoPatch p => Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO () -createPristineDirectoryTree (Repo r rf _ c) reldir wwd - | formatHas HashedInventory rf = - do createDirectoryIfMissing True reldir - withCurrentDirectory reldir $ HashedRepo.copyPristine c r (darcsdir++"/hashed_inventory") wwd - | otherwise = fail Old.oldRepoFailMsg - --- fp below really should be FileName --- | Used by the commands dist and diff -createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) - => Repository rt p wR wU wT - -> [fp] - -> FilePath - -> IO () -createPartialsPristineDirectoryTree (Repo r rf _ c) prefs dir - | formatHas HashedInventory rf = - do createDirectoryIfMissing True dir - withCurrentDirectory dir $ - HashedRepo.copyPartialsPristine c r (darcsdir++"/hashed_inventory") prefs - | otherwise = fail Old.oldRepoFailMsg - -withRecorded :: RepoPatch p - => Repository rt p wR wU wT - -> ((AbsolutePath -> IO a) -> IO a) - -> (AbsolutePath -> IO a) - -> IO a -withRecorded repository mk_dir f - = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir - f d - -withTentative :: forall rt p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> ((AbsolutePath -> IO a) -> IO a) - -> (AbsolutePath -> IO a) - -> IO a -withTentative (Repo dir rf _ c) mk_dir f - | formatHas HashedInventory rf = - mk_dir $ \d -> do HashedRepo.copyPristine - c - dir - (darcsdir++"/tentative_pristine") - WithWorkingDir - f d -withTentative repository@(Repo dir _ _ _) mk_dir f = - withRecorded repository mk_dir $ \d -> - do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") - runDefault $ apply ps - f d - where read_patches :: FilePath -> IO (Sealed (FL p wX)) - read_patches fil = do ps <- B.readFile fil - return $ fromMaybe (seal NilFL) $ readPatch ps - --- | Sets scripts in or below the current directory executable. --- A script is any file that starts with the bytes '#!'. --- This is used for --set-scripts-executable. -setScriptsExecutable_ :: PatchInspect p => Maybe (p wX wY) -> IO () -setScriptsExecutable_ pw = do - debugMessage "Making scripts executable" - tree <- readWorking - paths <- case pw of - Just ps -> filterM doesFileExist $ listTouchedFiles ps - Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ] - let setExecutableIfScript f = - do contents <- B.readFile f - when (BC.pack "#!" `B.isPrefixOf` contents) $ do - debugMessage ("Making executable: " ++ f) - setExecutable f True - mapM_ setExecutableIfScript paths - -setScriptsExecutable :: IO () -setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch wX wY)) - -setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO () -setScriptsExecutablePatches = setScriptsExecutable_ . Just - - --- | Writes out a fresh copy of the inventory that minimizes the --- amount of inventory that need be downloaded when people pull from --- the repository. --- --- Specifically, it breaks up the inventory on the most recent tag. --- This speeds up most commands when run remotely, both because a --- smaller file needs to be transfered (only the most recent --- inventory). It also gives a guarantee that all the patches prior --- to a given tag are included in that tag, so less commutation and --- history traversal is needed. This latter issue can become very --- important in large repositories. -reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wR - -> Compression - -> UpdateWorking - -> Verbosity - -> IO () -reorderInventory repository@(Repo _ rf _ _) compr uw verb = - decideHashedOrNormal rf HvsO { - hashed = do - debugMessage "Reordering the inventory." - PatchSet _ ps <- misplacedPatches `fmap` readRepo repository - tentativelyReplacePatches repository compr uw verb $ reverseRL ps - HashedRepo.finalizeTentativeChanges repository compr - debugMessage "Done reordering the inventory.", - old = fail Old.oldRepoFailMsg } - --- | Returns the patches that make the most recent tag dirty. -misplacedPatches :: forall rt p wS wX . RepoPatch p - => PatchSet rt p wS wX - -> PatchSet rt p wS wX -misplacedPatches ps = - -- Filter the repository keeping only with the tags, ordered from the - -- most recent. - case filter isTag $ mapRL info $ newset2RL ps of - [] -> ps - (lt:_) -> - -- Take the most recent tag, and split the repository in, - -- the clean PatchSet "up to" the tag (ts), and a RL of - -- patches after the tag (r). - case splitOnTag lt ps of - Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r) - _ -> impossible -- Because the tag is in ps. - --- @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. -readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> IO (PatchSet rt p Origin wR) -readRepo repo@(Repo r rf _ _) - | formatHas HashedInventory rf = HashedRepo.readRepo repo r - | otherwise = do Sealed ps <- Old.readOldRepo r - return $ unsafeCoerceP ps - --- | XOR of all hashes of the patches' metadata. --- It enables to quickly see whether two repositories --- have the same patches, independently of their order. --- It relies on the assumption that the same patch cannot --- be present twice in a repository. --- This checksum is not cryptographically secure, --- see http://robotics.stanford.edu/~xb/crypto06b/ . -repoXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wR -> IO SHA1 -repoXor repo = do - hashes <- mapRL (makePatchname . info) . newset2RL <$> readRepo repo - return $ foldl' sha1Xor zero hashes diff --git a/src/Darcs/Repository/InternalTypes.hs b/src/Darcs/Repository/InternalTypes.hs --- a/src/Darcs/Repository/InternalTypes.hs +++ b/src/Darcs/Repository/InternalTypes.hs @@ -14,22 +14,31 @@ -- along with this program; if not, write to the Free Software Foundation, -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -{-# LANGUAGE CPP #-} - - -module Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) - , extractCache, modifyCache +module Darcs.Repository.InternalTypes ( Repository, PristineType(..) + , repoCache, modifyCache + , repoPatchType + , repoFormat + , repoLocation + , withRepoLocation + , repoPristineType + , coerceR + , coerceU + , coerceT + , mkRepo ) where import Prelude () import Darcs.Prelude +import Data.Coerce ( coerce ) import Data.List ( nub, sortBy ) import Darcs.Repository.Cache ( Cache (..) , compareByLocality ) import Darcs.Repository.Format ( RepoFormat ) -import Darcs.Patch ( RepoPatch, RepoType ) +import Darcs.Patch ( RepoType ) +import Darcs.Patch.Type ( PatchType(..) ) +import Darcs.Util.File ( withCurrentDirectory ) -data Pristine +data PristineType = NoPristine | PlainPristine | HashedPristine @@ -42,14 +51,41 @@ -- and the tentative state, which represents work in progress that will -- eventually become the new recorded state unless something goes wrong. data Repository (rt :: RepoType) (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate = - Repo !String !RepoFormat !Pristine Cache deriving ( Show ) + Repo !String !RepoFormat !PristineType Cache deriving ( Show ) -extractCache :: Repository rt p wR wU wT -> Cache -extractCache (Repo _ _ _ c) = c +repoLocation :: Repository rt p wR wU wT -> String +repoLocation (Repo loc _ _ _) = loc +withRepoLocation :: Repository rt p wR wU wT -> IO a -> IO a +withRepoLocation repo = withCurrentDirectory (repoLocation repo) + +repoFormat :: Repository rt p wR wU wT -> RepoFormat +repoFormat (Repo _ fmt _ _) = fmt + +repoPristineType :: Repository rt p wR wU wT -> PristineType +repoPristineType (Repo _ _ pr _) = pr + +repoCache :: Repository rt p wR wU wT -> Cache +repoCache (Repo _ _ _ c) = c + -- | 'modifyCache' @repository function@ modifies the cache of -- @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'. -modifyCache :: forall rt p wR wU wT . (RepoPatch p) => Repository rt p wR wU wT -> (Cache -> Cache) -> Repository rt p wR wU wT +modifyCache :: forall rt p wR wU wT . Repository rt p wR wU wT -> (Cache -> Cache) -> Repository rt p wR wU wT modifyCache (Repo dir rf pristine cache) f = Repo dir rf pristine $ cmap ( sortBy compareByLocality . nub ) $ f cache where cmap g (Ca c) = Ca (g c) + +repoPatchType :: Repository rt p wR wU wT -> PatchType rt p +repoPatchType _ = PatchType + +coerceR :: Repository rt p wR wU wT -> Repository rt p wR' wU wT +coerceR = coerce + +coerceU :: Repository rt p wR wU wT -> Repository rt p wR wU' wT +coerceU = coerce + +coerceT :: Repository rt p wR wU wT -> Repository rt p wR wU wT' +coerceT = coerce + +mkRepo :: String -> RepoFormat -> PristineType -> Cache -> Repository rt p wR wU wT +mkRepo = Repo diff --git a/src/Darcs/Repository/Inventory.hs b/src/Darcs/Repository/Inventory.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Inventory.hs @@ -0,0 +1,239 @@ +module Darcs.Repository.Inventory + ( Inventory(..) + , HeadInventory + , InventoryEntry + , ValidHash(..) + , InventoryHash + , PatchHash + , PristineHash + , inventoryPatchNames + , parseInventory + , showInventory + , showInventoryPatches + , showInventoryEntry + , emptyInventory + , pokePristineHash + , peekPristineHash + , skipPristineHash + , pristineName + -- properties + , prop_inventoryParseShow + , prop_peekPokePristineHash + , prop_skipPokePristineHash + ) where + +import Prelude () +import Darcs.Prelude hiding ( take ) + +import Control.Applicative ( optional, many ) +import Control.Monad ( guard ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo ) +import Darcs.Patch.ReadMonads + ( ParserM, parseStrictly, string, skipSpace, take, takeTillChar ) +import Darcs.Patch.Show ( ShowPatchFor(..) ) +import Darcs.Repository.Cache ( okayHash ) +import Darcs.Util.Hash ( sha256sum ) +import Darcs.Util.Printer + ( Doc, (<>), (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS ) + +-- * Hash validation + +-- TODO the ValidHash class and the newtypes for the various hashes +-- really don't belong here. They should be moved to D.R.Cache or +-- perhaps a separate module. Also, the validation should be extended +-- see D.R.Cache.checkHash. + +class ValidHash a where + getValidHash :: a -> String + mkValidHash :: String -> a + +newtype InventoryHash = InventoryHash String + deriving (Eq, Show) + +instance ValidHash InventoryHash where + getValidHash (InventoryHash h) = h + mkValidHash s + | okayHash s = InventoryHash s + | otherwise = error "Bad inventory hash!" + +newtype PatchHash = PatchHash String + deriving (Eq, Show) + +instance ValidHash PatchHash where + getValidHash (PatchHash h) = h + mkValidHash s + | okayHash s = PatchHash s + | otherwise = error "Bad patch hash!" + +newtype PristineHash = PristineHash String + deriving (Eq, Show) + +instance ValidHash PristineHash where + getValidHash (PristineHash h) = h + mkValidHash s + | okayHash s = PristineHash s + | otherwise = error "Bad pristine hash!" + +-- * Inventories + +-- Note: this type and the commented out parser combinators for it +-- aren't actually used (except for testing). They are left here to +-- serve as documentation for the API we would like to use but won't +-- because of efficiency: we want to be able to access the pristine +-- hash with forcing a complete parse of the head inventory. Thus we +-- retain the lower-level peek/poke/skip API for the pristine hash. +type HeadInventory = (PristineHash, Inventory) + +data Inventory = Inventory + { inventoryParent :: Maybe InventoryHash + , inventoryPatches :: [InventoryEntry] + } deriving (Eq, Show) + +-- The 'String' is the (hashed) patch filename. +type InventoryEntry = (PatchInfo, PatchHash) + +inventoryPatchNames :: Inventory -> [String] +inventoryPatchNames = map (getValidHash . snd) . inventoryPatches + +emptyInventory :: Inventory +emptyInventory = Inventory Nothing [] + +-- * Parsing + +{- +parseHeadInventory :: B.ByteString -> Maybe HeadInventory +parseHeadInventory = fmap fst . parse pHeadInv +-} + +parseInventory :: B.ByteString -> Maybe Inventory +parseInventory = fmap fst . parseStrictly pInv + +{- +pHeadInv :: ParserM m => m HeadInventory +pHeadInv = (,) <$> pInvPristine <*> pInv + +pInvPristine :: ParserM m => m ValidHash +pInvPristine = do + string pristineName + skipSpace + pHash +-} + +pInv :: ParserM m => m Inventory +pInv = Inventory <$> pInvParent <*> pInvPatches + +pInvParent :: ParserM m => m (Maybe InventoryHash) +pInvParent = optional $ do + string parentName + skipSpace + pHash + +pHash :: (ParserM m, ValidHash h) => m h +pHash = do + hash <- BC.unpack <$> pLine + guard (okayHash hash) + return (mkValidHash hash) + +pLine :: ParserM m => m B.ByteString +pLine = takeTillChar '\n' <* take 1 + +pInvPatches :: ParserM m => m [InventoryEntry] +pInvPatches = many pInvEntry + +pInvEntry :: ParserM m => m InventoryEntry +pInvEntry = do + info <- readPatchInfo + skipSpace + string hashName + skipSpace + hash <- pHash + return (info, hash) + +-- * Showing + +showInventory :: Inventory -> Doc +showInventory inv = + showParent (inventoryParent inv) <> + showInventoryPatches (inventoryPatches inv) + +showInventoryPatches :: [InventoryEntry] -> Doc +showInventoryPatches = hcat . map showInventoryEntry + +showInventoryEntry :: InventoryEntry -> Doc +showInventoryEntry (pinf, hash) = + showPatchInfo ForStorage pinf $$ + packedString hashName <+> text (getValidHash hash) <> packedString newline + +showParent :: Maybe InventoryHash -> Doc +showParent (Just (InventoryHash hash)) = + packedString parentName $$ text hash <> packedString newline +showParent Nothing = mempty + +-- * Accessing the pristine hash + +-- | Replace the pristine hash at the start of a raw, unparsed 'HeadInventory' +-- or add it if none is present. +pokePristineHash :: String -> B.ByteString -> Doc +pokePristineHash h inv = + invisiblePS pristineName <> text h $$ invisiblePS (skipPristineHash inv) + +takeHash :: B.ByteString -> Maybe (String, B.ByteString) +takeHash input = do + let (hline,rest) = BC.breakSubstring newline input + let hash = BC.unpack hline + guard $ okayHash hash + return (hash, rest) + +peekPristineHash :: B.ByteString -> String +peekPristineHash inv = + case tryDropPristineName inv of + Just rest -> + case takeHash rest of + Just (h, _) -> h + Nothing -> error $ "Bad hash in inventory!" + Nothing -> sha256sum B.empty + +-- |skipPristineHash drops the 'pristine: HASH' prefix line, if present. +skipPristineHash :: B.ByteString -> B.ByteString +skipPristineHash ps = + case tryDropPristineName ps of + Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest + Nothing -> ps + +tryDropPristineName :: B.ByteString -> Maybe B.ByteString +tryDropPristineName input = + if prefix == pristineName then Just rest else Nothing + where + (prefix, rest) = B.splitAt (B.length pristineName) input + +-- * Key phrases + +pristineName :: B.ByteString +pristineName = BC.pack "pristine:" + +parentName :: B.ByteString +parentName = BC.pack "Starting with inventory:" + +hashName :: B.ByteString +hashName = BC.pack "hash:" + +newline :: B.ByteString +newline = BC.pack "\n" + +-- * Properties + +prop_inventoryParseShow :: Inventory -> Bool +prop_inventoryParseShow inv = + Just inv == parseInventory (renderPS (showInventory inv)) + +prop_peekPokePristineHash :: (PristineHash, B.ByteString) -> Bool +prop_peekPokePristineHash (PristineHash hash, raw) = + hash == peekPristineHash (renderPS (pokePristineHash hash raw)) + +prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool +prop_skipPokePristineHash (PristineHash hash, raw) = + raw == skipPristineHash (renderPS (pokePristineHash hash raw)) diff --git a/src/Darcs/Repository/Job.hs b/src/Darcs/Repository/Job.hs --- a/src/Darcs/Repository/Job.hs +++ b/src/Darcs/Repository/Job.hs @@ -16,15 +16,18 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes #-} {-# LANGUAGE ForeignFunctionInterface #-} module Darcs.Repository.Job ( RepoJob(..) + , IsPrimV1(..) , withRepoLock + , withOldRepoLock , withRepoLockCanFail , withRepository - , withRepositoryDirectory + , withRepositoryLocation + , checkRepoIsNoRebase + , withUMaskFlag ) where import Prelude () @@ -35,12 +38,15 @@ import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.V1 ( RepoPatchV1 ) import Darcs.Patch.V2 ( RepoPatchV2 ) -import Darcs.Patch.Prim.V1 ( Prim ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import Darcs.Patch.Prim ( PrimOf ) +import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.RepoType ( RepoType(..), SRepoType(..), IsRepoType , RebaseType(..), SRebaseType(..), IsRebaseType + , singletonRepoType ) import Darcs.Repository.Flags @@ -49,15 +55,18 @@ import Darcs.Repository.Format ( RepoProperty( Darcs2 , RebaseInProgress + , HashedInventory ) , formatHas , writeProblem ) -import Darcs.Repository.Internal - ( identifyRepository - , revertRepositoryChanges +import Darcs.Repository.Identify ( identifyRepository ) +import Darcs.Repository.Hashed( revertRepositoryChanges ) +import Darcs.Repository.InternalTypes + ( Repository + , repoFormat + , repoLocation ) -import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Rebase ( RebaseJobFlags , startRebaseJob @@ -70,6 +79,7 @@ import Control.Monad ( when ) import Control.Exception ( bracket_, finally ) +import Data.Coerce ( coerce ) import Data.List ( intercalate ) import Foreign.C.String ( CString, withCString ) @@ -78,8 +88,6 @@ import Darcs.Util.Tree ( Tree ) -#include "impossible.h" - getUMask :: UMask -> Maybe String getUMask (YesUMask s) = Just s getUMask NoUMask = Nothing @@ -114,23 +122,23 @@ = -- |The most common @RepoJob@; the underlying action can accept any patch type that -- a darcs repository may use. - RepoJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + RepoJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO a) -- |A job that only works on darcs 1 patches - | V1Job (forall wR wU . Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR -> IO a) + | V1Job (forall wR wU . Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) wR wU wR -> IO a) -- |A job that only works on darcs 2 patches - | V2Job (forall rt wR wU . Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a) + | V2Job (forall rt wR wU . IsRepoType rt => Repository rt (RepoPatchV2 V2.Prim) wR wU wR -> IO a) -- |A job that works on any repository where the patch type @p@ has 'PrimOf' @p@ = 'Prim'. -- -- This was added to support darcsden, which inspects the internals of V1 prim patches. -- -- In future this should be replaced with a more abstract inspection API as part of 'PrimPatch'. - | PrimV1Job (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) + | PrimV1Job (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) => Repository rt p wR wU wR -> IO a) -- A job that works on normal darcs repositories, but will want access to the rebase patch if it exists. - | RebaseAwareJob RebaseJobFlags (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository rt p wR wU wR -> IO a) - | RebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) - | StartRebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) + | RebaseAwareJob RebaseJobFlags (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO a) + | RebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) + | StartRebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) onRepoJob :: RepoJob a -> (forall rt p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository rt p wR wU wR -> IO a) -> Repository rt p wR wU wR -> IO a) @@ -145,38 +153,46 @@ -- | apply a given RepoJob to a repository in the current working directory withRepository :: UseCache -> RepoJob a -> IO a -withRepository useCache = withRepositoryDirectory useCache "." +withRepository useCache = withRepositoryLocation useCache "." -- | This is just an internal type to Darcs.Repository.Job for -- calling runJob in a strongly-typed way data RepoPatchType p where - RepoV1 :: RepoPatchType (RepoPatchV1 Prim) - RepoV2 :: RepoPatchType (RepoPatchV2 Prim) + RepoV1 :: RepoPatchType (RepoPatchV1 V1.Prim) + RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim) -- | This type allows us to check multiple patch types against the -- constraints required by most repository jobs data IsTree p where - IsTree :: (ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => IsTree p + IsTree :: (ApplyState p ~ Tree) => IsTree p checkTree :: RepoPatchType p -> IsTree p checkTree RepoV1 = IsTree checkTree RepoV2 = IsTree +class ApplyState p ~ Tree => IsPrimV1 p where + toPrimV1 :: p wX wY -> Prim wX wY +instance IsPrimV1 V1.Prim where + toPrimV1 = V1.unPrim +instance IsPrimV1 V2.Prim where + toPrimV1 = V2.unPrim + -- | This type allows us to check multiple patch types against the -- constraints required by 'PrimV1Job' data UsesPrimV1 p where - UsesPrimV1 :: (ApplyState p ~ Tree, PrimOf p ~ Prim) => UsesPrimV1 p + UsesPrimV1 :: (ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) => UsesPrimV1 p checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p checkPrimV1 RepoV1 = UsesPrimV1 checkPrimV1 RepoV2 = UsesPrimV1 -- | apply a given RepoJob to a repository in a given url -withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a -withRepositoryDirectory useCache url repojob = do - repo@(Repo _ rf _ _) <- identifyRepository useCache url +withRepositoryLocation :: UseCache -> String -> RepoJob a -> IO a +withRepositoryLocation useCache url repojob = do + repo <- identifyRepository useCache url let + rf = repoFormat repo startRebase = case repojob of StartRebaseJob {} -> True @@ -204,13 +220,17 @@ runJob :: forall rt p rtDummy pDummy wR wU a . (IsRepoType rt, RepoPatch p) - => RepoPatchType p -> SRepoType rt -> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a -runJob patchType (SRepoType isRebase) (Repo dir rf t c) repojob = do + => RepoPatchType p + -> SRepoType rt + -> Repository rtDummy pDummy wR wU wR + -> RepoJob a + -> IO a +runJob patchType (SRepoType isRebase) repo repojob = do -- The actual type the repository should have is only known when -- when this function is called, so we need to "cast" it to its proper type let - therepo = Repo dir rf t c :: Repository rt p wR wU wR + therepo = coerce repo :: Repository rt p wR wU wR patchTypeString :: String patchTypeString = @@ -230,7 +250,8 @@ [] -> "" _ -> " " ++ intercalate "+" repoAttributes - debugMessage $ "Identified " ++ patchTypeString ++ repoAttributesString ++ " repo: " ++ dir + debugMessage $ "Identified " ++ patchTypeString ++ repoAttributesString ++ + " repo: " ++ repoLocation repo case repojob of RepoJob job -> @@ -284,24 +305,47 @@ -- taking a lock withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a withRepoLock dry useCache uw um repojob = - withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) -> - do maybe (return ()) fail $ writeProblem rf + withRepository useCache $ onRepoJob repojob $ \job repository -> + do maybe (return ()) fail $ writeProblem (repoFormat repository) let name = "./"++darcsdir++"/lock" withUMaskFlag um $ if dry == YesDryRun then job repository else withLock name (revertRepositoryChanges repository uw >> job repository) --- | apply a given RepoJob to a repository in the current working directory, --- taking a lock. If lock not takeable, do nothing. -withRepoLockCanFail :: UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO () -withRepoLockCanFail useCache uw um repojob = - withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) -> - do maybe (return ()) fail $ writeProblem rf +-- | run a lock-taking job in an old-fashion repository. +-- only used by `darcs optimize upgrade`. +withOldRepoLock :: RepoJob a -> IO a +withOldRepoLock repojob = + withRepository NoUseCache $ onRepoJob repojob $ \job repository -> + do let name = "./"++darcsdir++"/lock" + withLock name $ job repository + +-- | Apply a given RepoJob to a repository in the current working directory, +-- taking a lock. If lock not takeable, do nothing. If old-fashioned +-- repository, do nothing. The job must not touch pending or pending.tentative, +-- because there is no call to revertRepositoryChanges. This entry point is +-- currently only used for attemptCreatePatchIndex. +withRepoLockCanFail :: UseCache -> RepoJob () -> IO () +withRepoLockCanFail useCache repojob = + withRepository useCache $ onRepoJob repojob $ \job repository -> + let rf = repoFormat repository in + if formatHas HashedInventory rf then do + maybe (return ()) fail $ writeProblem rf let name = "./"++darcsdir++"/lock" - withUMaskFlag um $ do - eitherDone <- withLockCanFail name (revertRepositoryChanges repository uw >> job repository) - case eitherDone of - Left _ -> debugMessage "Lock could not be obtained, not doing the job." - Right _ -> return () + eitherDone <- withLockCanFail name (job repository) + case eitherDone of + Left _ -> debugMessage "Lock could not be obtained, not doing the job." + Right _ -> return () + else debugMessage "Not doing the job because this is an old-fashioned repository." +-- | If the 'RepoType' of the given repo indicates that we have 'NoRebase', +-- then 'Just' the repo with the refined type, else 'Nothing'. +-- NB The amount of types we have to import to make this simple check is ridiculous! +checkRepoIsNoRebase :: forall rt p wR wU wT. IsRepoType rt + => Repository rt p wR wU wT + -> Maybe (Repository ('RepoType 'NoRebase) p wR wU wT) +checkRepoIsNoRebase repo = + case singletonRepoType :: SRepoType rt of + SRepoType SNoRebase -> Just repo + SRepoType SIsRebase -> Nothing diff --git a/src/Darcs/Repository/Match.hs b/src/Darcs/Repository/Match.hs --- a/src/Darcs/Repository/Match.hs +++ b/src/Darcs/Repository/Match.hs @@ -15,12 +15,9 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-} - module Darcs.Repository.Match ( getNonrangeMatch - , getFirstMatch , getOnePatchset ) where @@ -29,7 +26,6 @@ import Darcs.Patch.Match ( getNonrangeMatchS - , getFirstMatchS , nonrangeMatcherIsTag , getMatchingTag , matchAPatchset @@ -49,15 +45,14 @@ import Darcs.Repository.Flags ( WithWorkingDir (WithWorkingDir) ) import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) -import Darcs.Repository.Internal - ( Repository, readRepo, createPristineDirectoryTree ) +import Darcs.Repository.InternalTypes ( Repository ) +import Darcs.Repository.Hashed + ( readRepo, createPristineDirectoryTree ) import Darcs.Util.Tree ( Tree ) import Darcs.Util.Path ( toFilePath ) -#include "impossible.h" - getNonrangeMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> [MatchFlag] @@ -68,13 +63,7 @@ | otherwise -> fail "Index range is not allowed for this command." _ -> getNonrangeMatchS fs -getFirstMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> [MatchFlag] - -> IO () -getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs) - -getOnePatchset :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +getOnePatchset :: (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT -> [MatchFlag] -> IO (SealedPatchSet rt p Origin) @@ -89,7 +78,7 @@ context_f (Context f:_) = f context_f (_:xs) = context_f xs -withRecordedMatch :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +withRecordedMatch :: (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT -> (PatchSet rt p Origin wR -> DefaultIO ()) -> IO () diff --git a/src/Darcs/Repository/Merge.hs b/src/Darcs/Repository/Merge.hs --- a/src/Darcs/Repository/Merge.hs +++ b/src/Darcs/Repository/Merge.hs @@ -21,15 +21,34 @@ module Darcs.Repository.Merge ( tentativelyMergePatches , considerMergeToWorking + , announceMergeConflicts ) where import Prelude () import Darcs.Prelude -import Control.Monad ( when ) -import Darcs.Util.Tree( Tree ) +import Control.Monad ( when, unless ) +import Data.List.Ordered ( nubSort ) +import System.Exit ( exitSuccess ) +import Darcs.Util.Tree( Tree ) import Darcs.Util.External ( backupByCopying ) + +import Darcs.Patch + ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles + , fromPrims, effect, WrappedNamed + , listConflictedFiles ) +import Darcs.Patch.Prim ( PrimPatch ) +import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Patch.Depends( merge2FL ) +import Darcs.Patch.Named.Wrapped ( activecontents, anonymous, namedIsInternal ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully ) +import Darcs.Patch.Progress( progressFL ) +import Darcs.Patch.Witnesses.Ordered + ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), + mapFL_FL, concatFL, filterOutFLFL ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal ) + import Darcs.Repository.Flags ( UseIndex , ScanKnown @@ -41,32 +60,31 @@ , Compression (..) , WantGuiPause (..) , DiffAlgorithm (..) + , UseCache(..) + , LookForMoves(..) + , LookForReplaces(..) ) -import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles, - fromPrims, effect ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Depends( merge2FL ) -import Darcs.Patch.Named.Wrapped ( activecontents, anonymous ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully ) -import Darcs.Patch.Progress( progressFL ) -import Darcs.Patch.Witnesses.Ordered - ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), - mapFL_FL, concatFL ) -import Darcs.Patch.Witnesses.Sealed( Sealed(Sealed), seal ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) -import Darcs.Repository.InternalTypes( Repository(..) ) -import Darcs.Repository.State( unrecordedChanges, readUnrecorded ) +import Darcs.Repository.Hashed + ( tentativelyAddPatches_ + , applyToTentativePristine + , tentativelyRemovePatches_ + , UpdatePristine(..) ) +import Darcs.Repository.Identify ( identifyRepository ) +import Darcs.Repository.InternalTypes ( Repository ) +import Darcs.Repository.Pending ( setTentativePending, readPending ) import Darcs.Repository.Resolution ( standardResolution, externalResolution ) -import Darcs.Repository.Internal ( announceMergeConflicts, - checkUnrecordedConflicts, MakeChanges(..), - setTentativePending, tentativelyAddPatch_, - applyToTentativePristine, - tentativelyReplacePatches, - UpdatePristine(..) ) +import Darcs.Repository.State ( unrecordedChanges, readUnrecorded ) + +import Darcs.Util.Prompt ( promptYorn ) +import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Progress( debugMessage ) +import Darcs.Util.Printer.Color (fancyPrinters) +import Darcs.Util.Printer ( text, ($$), redText, putDocLnWith, ($$) ) +data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) + tentativelyMergePatches_ :: forall rt p wR wU wT wY wX - . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => MakeChanges -> Repository rt p wR wU wT -> String -> AllowConflicts -> UpdateWorking @@ -76,16 +94,14 @@ -> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) -tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge wantGuiPause - compression verbosity reorder diffingOpts@(_, _, dflag) usi themi = do - let us = mapFL_FL hopefully usi - them = mapFL_FL hopefully themi - ((pc :: FL (PatchInfoAnd rt p) wT wMerged) :/\: us_merged) - <- return $ merge2FL (progressFL "Merging us" usi) - (progressFL "Merging them" themi) - pend <- unrecordedChanges diffingOpts r Nothing +tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge + wantGuiPause compression verbosity reorder diffingOpts@(_, _, dflag) us them = do + (them_merged :/\: us_merged) + <- return $ merge2FL (progressFL "Merging us" us) + (progressFL "Merging them" them) + pend <- unrecordedChanges diffingOpts NoLookForMoves NoLookForReplaces r Nothing anonpend <- n2pia `fmap` anonymous (fromPrims pend) - pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) + pend' :/\: pw <- return $ merge (them_merged :\/: anonpend :>: NilFL) let pwprim = concatFL $ progressFL "Examining patches for conflicts" $ mapFL_FL (activecontents . hopefully) pw Sealed standard_resolved_pw <- return $ standardResolution pwprim @@ -93,10 +109,11 @@ when (allowConflicts == YesAllowConflictsAndMark) $ mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw debugMessage "Announcing conflicts..." - have_conflicts <- announceMergeConflicts cmd allowConflicts externalMerge standard_resolved_pw + have_conflicts <- + announceMergeConflicts cmd allowConflicts externalMerge standard_resolved_pw debugMessage "Checking for unrecorded conflicts..." have_unrecorded_conflicts <- checkUnrecordedConflicts updateWorking $ - mapFL_FL hopefully pc + mapFL_FL hopefully them_merged debugMessage "Reading working directory..." working <- readUnrecorded r Nothing debugMessage "Working out conflicts in actual working directory..." @@ -111,47 +128,31 @@ (effect us +>+ pend) (effect them) pwprim debugMessage "Applying patches to the local directories..." when (mc == MakeChanges) $ do - let doChanges :: FL (PatchInfoAnd rt p) wX wT -> IO (Repository rt p wR wU wMerged) - -- This first case is a possible optimisation: if 'usi' is empty, then - -- the merge2FL call above will return pc = themi, but the wMerged - -- witness is quantified in the :/\: constructor so we lose the - -- information that wX=wT => wMerged=wY so we have to coerce. - -- TODO: it's not really clear why if this is an optimisation in - -- practice, as pc would be trivial to calculate in this case and - -- there aren't any obvious memory benefits. - doChanges NilFL = applyps r (unsafeCoercePEnd themi) - doChanges _ = applyps r pc - r' <- doChanges usi + -- these two cases result in the same trees (that's the idea of + -- merging), so we only operate on the set of patches and do the + -- adaption of pristine and pending in the common code below + r' <- case reorder of + NoReorder -> do + tentativelyAddPatches_ DontUpdatePristine r + compression verbosity updateWorking them_merged + Reorder -> do + -- we do not actually remove any effect in the end, so + -- it would be wrong to update the unrevert bundle or + -- the working tree or pending + r1 <- tentativelyRemovePatches_ DontUpdatePristineNorRevert r + compression NoUpdateWorking + (filterOutFLFL (namedIsInternal . hopefully) us) + r2 <- tentativelyAddPatches_ DontUpdatePristine r1 + compression verbosity NoUpdateWorking them + tentativelyAddPatches_ DontUpdatePristine r2 + compression verbosity NoUpdateWorking + (filterOutFLFL (namedIsInternal . hopefully) us_merged) + -- must use the original r, not the updated one here: + applyToTentativePristine r verbosity them_merged setTentativePending r' updateWorking (effect pend' +>+ pw_resolution) - when (reorder == Reorder) $ - -- TODO: we end up applying the merged remote patches on top of the unmerged - -- local patches, then commuting out the unmerged local patches and finally - -- adding the merged local patches. - -- It would better to just remove the unmerged local patche, then apply the - -- unmerged remote patches and then the merged local patches. - -- The handling of 'unrecorded' might complicate this slightly so this - -- refactoring may be better deferred until we have reliable witness tracking - -- for repositories. - tentativelyReplacePatches r' compression YesUpdateWorking verbosity us_merged return $ seal (effect pwprim +>+ pw_resolution) - where - mapAdd :: Repository rt p wM wL wI -> FL (PatchInfoAnd rt p) wI wJ - -> IO (Repository rt p wM wL wJ) - mapAdd repo NilFL = return repo - mapAdd repo (a:>:as) = do - repo' <- tentativelyAddPatch_ DontUpdatePristine repo - compression verbosity updateWorking a - mapAdd repo' as - applyps :: Repository rt p wM wL wI -> FL (PatchInfoAnd rt p) wI wJ - -> IO (Repository rt p wM wL wJ) - applyps repo ps = do - debugMessage "Adding patches to inventory..." - repo' <- mapAdd repo ps - debugMessage "Applying patches to pristine..." - applyToTentativePristine repo verbosity ps - return repo' -tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause @@ -163,7 +164,7 @@ tentativelyMergePatches = tentativelyMergePatches_ MakeChanges -considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause @@ -173,4 +174,57 @@ -> FL (PatchInfoAnd rt p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges + + +announceMergeConflicts :: (PrimPatch p) + => String + -> AllowConflicts + -> ExternalMerge + -> FL p wX wY + -> IO Bool +announceMergeConflicts cmd allowConflicts externalMerge resolved_pw = + case nubSort $ listTouchedFiles resolved_pw of + [] -> return False + cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark] + || externalMerge /= NoExternalMerge + then do putDocLnWith fancyPrinters $ + redText "We have conflicts in the following files:" $$ text (unlines cfs) + return True + else do putDocLnWith fancyPrinters $ + redText "There are conflicts in the following files:" $$ text (unlines cfs) + fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++ + "If you would rather apply the patch and mark the conflicts,\n"++ + "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++ + "These can set as defaults by adding\n"++ + " "++cmd++" mark-conflicts\n"++ + "to "++darcsdir++"/prefs/defaults in the target repo. " + +checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p + => UpdateWorking + -> FL (WrappedNamed rt p) wT wY + -> IO Bool +checkUnrecordedConflicts NoUpdateWorking _ + = return False -- because we are called by `darcs convert` hence we don't care +checkUnrecordedConflicts _ pc = + do repository <- identifyRepository NoUseCache "." + cuc repository + where cuc :: Repository rt p wR wU wT -> IO Bool + cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT)) + case mpend of + NilFL -> return False + pend -> + case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of + _ :/\: pend' -> + case listConflictedFiles pend' of + [] -> return False + fs -> do putStrLn ("You have conflicting local changes to:\n" + ++ unwords fs) + confirmed <- promptYorn "Proceed?" + unless confirmed $ + do putStrLn "Cancelled." + exitSuccess + return True + fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB + fromPrims_ = fromPrims + diff --git a/src/Darcs/Repository/Motd.hs b/src/Darcs/Repository/Motd.hs deleted file mode 100644 --- a/src/Darcs/Repository/Motd.hs +++ /dev/null @@ -1,46 +0,0 @@ --- Copyright (C) 2002-2004 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -module Darcs.Repository.Motd - ( getMotd - , showMotd - ) where - -import Prelude () -import Darcs.Prelude - -import Control.Monad ( unless ) -import qualified Data.ByteString as B (null, hPut, empty, ByteString) -import System.IO ( stdout ) - -import Darcs.Util.External ( fetchFilePS, Cachable(..) ) -import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.Exception ( catchall ) - --- | Fetch and return the message of the day for a given repository. -getMotd :: String -> IO B.ByteString -getMotd repo = fetchFilePS motdPath (MaxAge 600) `catchall` return B.empty - where - motdPath = repo ++ "/" ++ darcsdir ++ "/prefs/motd" - --- | Display the message of the day for a given repository, -showMotd :: String -> IO () -showMotd repo = do - motd <- getMotd repo - unless (B.null motd) $ do - B.hPut stdout motd - putStrLn $ replicate 22 '*' diff --git a/src/Darcs/Repository/Old.hs b/src/Darcs/Repository/Old.hs --- a/src/Darcs/Repository/Old.hs +++ b/src/Darcs/Repository/Old.hs @@ -15,11 +15,8 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables #-} - - module Darcs.Repository.Old ( readOldRepo, - revertTentativeChanges, oldRepoFailMsg ) where + oldRepoFailMsg ) where import Prelude () import Darcs.Prelude @@ -33,62 +30,61 @@ patchInfoAndPatch, actually, unavailable ) -import qualified Data.ByteString.Char8 as BC (break, pack) +import qualified Data.ByteString as B ( ByteString, null ) +import qualified Data.ByteString.Char8 as BC ( break, pack, unpack ) import Darcs.Patch ( RepoPatch, IsRepoType, WrappedNamed, readPatch ) - +import Darcs.Patch.ReadMonads as RM ( parseStrictly ) import Darcs.Patch.Witnesses.Ordered ( RL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) -import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfos, showPatchInfo ) +import Darcs.Patch.Info ( PatchInfo(..), makePatchname, readPatchInfo, displayPatchInfo ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) import Darcs.Util.External ( gzFetchFilePS , Cachable(..) - , cloneFile ) -import Darcs.Util.Lock ( writeBinFile ) -import Darcs.Util.Printer ( renderString, RenderMode(..) ) +import Darcs.Util.Printer ( renderString ) import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Hash ( sha1PS ) +import Darcs.Util.IsoDate ( readUTCDateOldFashioned, showIsoDateTime ) import Control.Exception ( catch, IOException ) -#include "impossible.h" - readOldRepo :: (IsRepoType rt, RepoPatch p) => String -> IO (SealedPatchSet rt p Origin) -readOldRepo d = do - realdir <- toPath `fmap` ioAbsoluteOrRemote d - let k = "Reading inventory of repository "++d - beginTedious k - readRepoPrivate k realdir "inventory" `catch` +readOldRepo repo_dir = do + realdir <- toPath `fmap` ioAbsoluteOrRemote repo_dir + let task = "Reading inventory of repository "++repo_dir + beginTedious task + readRepoPrivate task realdir "inventory" `catch` (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) readRepoPrivate :: (IsRepoType rt, RepoPatch p) => String -> FilePath -> FilePath -> IO (SealedPatchSet rt p Origin) -readRepoPrivate k d iname = do - i <- gzFetchFilePS (d darcsdir iname) Uncachable - finishedOneIO k iname - let parse inf = parse2 inf $ d darcsdir "patches" makeFilename inf - (mt, is) = case BC.break ('\n' ==) i of +readRepoPrivate task repo_dir inventory_name = do + inventory <- gzFetchFilePS (repo_dir darcsdir inventory_name) Uncachable + finishedOneIO task inventory_name + let parse inf = parse2 inf $ repo_dir darcsdir "patches" makeFilename inf + (mt, is) = case BC.break ('\n' ==) inventory of (swt,pistr) | swt == BC.pack "Starting with tag:" -> case readPatchInfos pistr of (t:ids) -> (Just t,reverse ids) [] -> bug "bad inventory in readRepoPrivate" - _ -> (Nothing, reverse $ readPatchInfos i) + _ -> (Nothing, reverse $ readPatchInfos inventory) Sealed ts <- unseal seal `fmap` unsafeInterleaveIO (read_ts parse mt) Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) return $ seal (PatchSet ts ps) where read_ts :: RepoPatch p => (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd rt p wB))) -> Maybe PatchInfo -> IO (Sealed (RL (Tagged rt p) Origin)) - read_ts _ Nothing = do endTedious k + read_ts _ Nothing = do endTedious task return $ seal NilRL read_ts parse (Just tag0) = - do debugMessage $ "Looking for inventory for:\n"++ renderString Encode (showPatchInfo tag0) + do debugMessage $ "Looking for inventory for:\n"++ renderString (displayPatchInfo tag0) i <- unsafeInterleaveIO $ - do x <- gzFetchFilePS (d darcsdir "inventories" makeFilename tag0) Uncachable - finishedOneIO k (renderString Encode (showPatchInfo tag0)) + do x <- gzFetchFilePS (repo_dir darcsdir "inventories" makeFilename tag0) Uncachable + finishedOneIO task (renderString (displayPatchInfo tag0)) return x let (mt, is) = case BC.break ('\n' ==) i of (swt,pistr) | swt == BC.pack "Starting with tag:" -> @@ -128,12 +124,30 @@ Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy return $ seal $ f y x - -revertTentativeChanges :: IO () -revertTentativeChanges = - do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory") - writeBinFile (darcsdir++"/tentative_pristine") "" - oldRepoFailMsg :: String oldRepoFailMsg = "ERROR: repository upgrade required, try `darcs optimize upgrade`\n" ++ "See http://wiki.darcs.net/OF for more details." + +-- | This makes darcs-1 (non-hashed repos) filenames. +-- +-- The name consists of three segments: +-- +-- * timestamp (ISO8601-compatible yyyymmmddHHMMSS; +-- note that the old-fashioned (non-hashed) format expects this date to +-- be exactly as in the patch, /ignoring/ any timezone info, +-- which is why we use 'readUTCDateOldFashioned' here) +-- +-- * SHA1 hash of the author +-- +-- * SHA1 hash of the patch name, author, date, log, and \"inverted\" +-- flag. +makeFilename :: PatchInfo -> String +makeFilename pi = showIsoDateTime d++"-"++sha1_a++"-"++ (show $ makePatchname pi) ++ ".gz" + where d = readUTCDateOldFashioned $ BC.unpack $ _piDate pi + sha1_a = take 5 $ show $ sha1PS $ _piAuthor pi + +readPatchInfos :: B.ByteString -> [PatchInfo] +readPatchInfos inv | B.null inv = [] +readPatchInfos inv = case parseStrictly readPatchInfo inv of + Just (pinfo,r) -> pinfo : readPatchInfos r + _ -> [] diff --git a/src/Darcs/Repository/Packs.hs b/src/Darcs/Repository/Packs.hs --- a/src/Darcs/Repository/Packs.hs +++ b/src/Darcs/Repository/Packs.hs @@ -1,26 +1,50 @@ +{-| +License : GPL-2 + +Packs are an optimization that enable faster repository cloning over HTTP. +A pack is actually a @tar.gz@ file that contains many files that would otherwise +have to be transfered one by one (which is much slower over HTTP). + +Two packs are created at the same time by 'createPacks': + + 1. The basic pack, contains the latest recorded version of the working tree. + 2. The patches pack, contains the set of patches of the repository. + +The paths of these files are @_darcs\/packs\/basic.tar.gz@ and +@_darcs\/packs\/patches.tar.gz@. There is also @_darcs\/packs\/pristine@ which +indicates the pristine hash at the moment of the creation of the packs. This +last file is useful to determine whether the basic pack is in sync with the +current pristine of the repository. +-} + module Darcs.Repository.Packs ( fetchAndUnpackBasic , fetchAndUnpackPatches , packsDir + , createPacks ) where import qualified Codec.Archive.Tar as Tar +import Codec.Archive.Tar.Entry ( fileEntry, toTarPath ) import Codec.Compression.GZip as GZ ( compress, decompress ) - import Control.Concurrent.Async ( withAsync ) -import Control.Exception ( Exception, IOException, throwIO, catch ) -import Control.Monad ( void ) +import Control.Exception ( Exception, IOException, throwIO, catch, finally ) +import Control.Monad ( void, when, unless ) import System.IO.Error ( isAlreadyExistsError ) +import System.IO.Unsafe ( unsafeInterleaveIO ) -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.List ( isPrefixOf ) +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.List ( isPrefixOf, sort ) import Data.Maybe( catMaybes, listToMaybe ) import System.Directory ( createDirectoryIfMissing , renameFile + , removeFile , doesFileExist + , getModificationTime ) import System.FilePath ( () + , (<.>) , takeFileName , splitPath , joinPath @@ -28,8 +52,22 @@ ) import System.Posix.Files ( createLink ) +import Darcs.Util.ByteString ( gzReadFilePS ) import Darcs.Util.Lock ( withTemp ) import Darcs.Util.External ( Cachable(..), fetchFileLazyPS ) +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Progress ( debugMessage ) + +import Darcs.Patch ( IsRepoType, RepoPatch ) +import Darcs.Patch.PatchInfoAnd ( extractHash ) +import Darcs.Patch.Witnesses.Ordered ( mapFL ) +import Darcs.Patch.Set ( patchSet2FL ) + +import Darcs.Repository.InternalTypes ( Repository ) +import qualified Darcs.Repository.Hashed as HashedRepo +import Darcs.Repository.Hashed ( filterDirContents, readRepo, readHashedPristineRoot ) +import Darcs.Repository.Format + ( identifyRepoFormat, formatHas, RepoProperty ( HashedInventory ) ) import Darcs.Repository.Cache ( fetchFileUsingCache , HashedDir(..) , Cache(..) @@ -39,12 +77,12 @@ , bucketFolder , CacheType(Directory) ) - -import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.Progress ( debugMessage ) +import Darcs.Repository.Old ( oldRepoFailMsg ) -packsDir :: String -packsDir = "packs" +packsDir, basicPack, patchesPack :: String +packsDir = "packs" +basicPack = "basic.tar.gz" +patchesPack = "patches.tar.gz" fetchAndUnpack :: FilePath -> HashedDir @@ -60,11 +98,11 @@ -- Patches pack can miss some new patches of the repository. -- So we download pack asynchonously and alway do a complete pass -- of individual patch files. - withAsync (fetchAndUnpack "patches.tar.gz" HashedInventoriesDir cache remote) $ \_ -> do + withAsync (fetchAndUnpack patchesPack HashedInventoriesDir cache remote) $ \_ -> do fetchFilesUsingCache cache HashedPatchesDir paths fetchAndUnpackBasic :: Cache -> FilePath -> IO () -fetchAndUnpackBasic = fetchAndUnpack "basic.tar.gz" HashedPristineDir +fetchAndUnpackBasic = fetchAndUnpack basicPack HashedPristineDir unpackTar :: Exception e => Cache -> HashedDir -> Tar.Entries e -> IO () unpackTar _ _ Tar.Done = return () @@ -87,7 +125,7 @@ _ -> fail "Unexpected non-file tar entry" where writeFile' Nothing path content = withTemp $ \tmp -> do - BL.writeFile tmp content + BLC.writeFile tmp content renameFile tmp path writeFile' (Just ca) path content = do let fileFullPath = case splitPath path of @@ -115,3 +153,58 @@ cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of Cache Directory Writable x' -> Just x' _ -> Nothing + +-- | Create packs from the current recorded version of the repository. +createPacks :: (IsRepoType rt, RepoPatch p) + => Repository rt p wR wU wT -> IO () +createPacks repo = flip finally (mapM_ removeFileIfExists + [ darcsdir "meta-filelist-inventories" + , darcsdir "meta-filelist-pristine" + , basicTar <.> "part" + , patchesTar <.> "part" + ]) $ do + rf <- identifyRepoFormat "." + -- function is exposed in API so could be called on non-hashed repo + unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg + createDirectoryIfMissing False (darcsdir packsDir) + -- pristine hash + Just hash <- readHashedPristineRoot repo + writeFile ( darcsdir packsDir "pristine" ) hash + -- pack patchesTar + ps <- mapFL hashedPatchFileName . patchSet2FL <$> readRepo repo + is <- map ((darcsdir "inventories") ) <$> HashedRepo.listInventories + writeFile (darcsdir "meta-filelist-inventories") . unlines $ + map takeFileName is + -- Note: tinkering with zlib's compression parameters does not make + -- any noticeable difference in generated archive size; + -- switching to bzip2 would provide ~25% gain OTOH. + BLC.writeFile (patchesTar <.> "part") . GZ.compress . Tar.write =<< + mapM fileEntry' ((darcsdir "meta-filelist-inventories") : ps ++ + reverse is) + renameFile (patchesTar <.> "part") patchesTar + -- pack basicTar + pr <- sortByMTime =<< dirContents "pristine.hashed" + writeFile (darcsdir "meta-filelist-pristine") . unlines $ + map takeFileName pr + BLC.writeFile (basicTar <.> "part") . GZ.compress . Tar.write =<< mapM fileEntry' ( + [ darcsdir "meta-filelist-pristine" + , darcsdir "hashed_inventory" + ] ++ reverse pr) + renameFile (basicTar <.> "part") basicTar + where + basicTar = darcsdir packsDir basicPack + patchesTar = darcsdir packsDir patchesPack + fileEntry' x = unsafeInterleaveIO $ do + content <- BLC.fromChunks . return <$> gzReadFilePS x + tp <- either fail return $ toTarPath False x + return $ fileEntry tp content + dirContents d = map ((darcsdir d) ) <$> + filterDirContents d (const True) + hashedPatchFileName x = case extractHash x of + Left _ -> fail "unexpected unhashed patch" + Right h -> darcsdir "patches" h + sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$> + getModificationTime x) xs + removeFileIfExists x = do + ex <- doesFileExist x + when ex $ removeFile x diff --git a/src/Darcs/Repository/PatchIndex.hs b/src/Darcs/Repository/PatchIndex.hs --- a/src/Darcs/Repository/PatchIndex.hs +++ b/src/Darcs/Repository/PatchIndex.hs @@ -1,41 +1,42 @@ -{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} --- Copyright (C) 2009-2010 Benedikt Schmidt --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. +{-| +License : GPL-2 +The patch-index stores additional information that is extracted from +the PatchSet for the repository to speed up certain commands (namely +@log@ and @annotate@). More precisely, for every file tracked by the +repository, it stores the list of patches that touch it. + +When created, patch-index lives in @_darcs\/patch_index\/@, and it +should be automatically maintained each time the set of patches of +the repository is updated. + +Patch-index can also be explicitely disabled by creating a file +@_darcs\/no_patch_index@. "Explicitely disabed" means that no command +should attempt to automatically create the patch-index. + +See for more information. +-} module Darcs.Repository.PatchIndex ( doesPatchIndexExist, isPatchIndexDisabled, isPatchIndexInSync, canUsePatchIndex, - canCreatePI, createPIWithInterrupt, createOrUpdatePatchIndexDisk, deletePatchIndex, - dumpPatchIndex, - filterPatches, + attemptCreatePatchIndex, PatchFilter, maybeFilterPatches, getRelevantSubsequence, - piTest, - attemptCreatePatchIndex + dumpPatchIndex, + piTest ) where -import Prelude hiding ( pi, (<$>) ) +import Prelude () +import Darcs.Prelude + import Data.Binary ( encodeFile, decodeFile ) import Data.Word ( Word32 ) import Data.Int ( Int8 ) @@ -51,44 +52,28 @@ import Control.Applicative ( (<$>) ) import System.Directory ( createDirectory, renameDirectory, doesFileExist, doesDirectoryExist ) import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) ) -import Darcs.Repository.InternalTypes ( Repository(..) ) -import Darcs.Repository.HashedRepo ( readRepo ) +import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat ) import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal, seal2, unsafeUnseal ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..), info ) import Darcs.Util.Lock ( withPermDir, rmRecursive ) -import Darcs.Patch ( RepoPatch, IsRepoType, listTouchedFiles ) +import Darcs.Patch ( RepoPatch, listTouchedFiles ) import Darcs.Util.Path ( FileName, fp2fn, fn2fp, toFilePath ) -import Darcs.Patch.Apply ( applyToFileMods, ApplyState(..) ) -import Darcs.Patch.Set ( newset2FL, Origin, newset2FL ) -import Darcs.Patch.Patchy ( Commute ) +import Darcs.Patch.Apply ( ApplyState(..) ) +import Darcs.Patch.Set ( PatchSet(..), patchSet2FL, Origin, patchSet2FL ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Patch.Index.Types +import Darcs.Patch.Index.Monad ( applyToFileMods, makePatchID ) import System.FilePath( () ) import System.IO (openFile, IOMode(WriteMode), hClose) import qualified Data.ByteString as B -import Darcs.Util.Crypt.SHA256 (sha256sum ) -import Darcs.Util.Crypt.SHA1 ( SHA1(..), showAsHex ) +import Darcs.Util.Hash ( sha256sum, showAsHex ) import Darcs.Util.Tree ( Tree(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.SignalHandler ( catchInterrupt ) -#include "impossible.h" -{- ----------------------------------------------------------------------------- - The patch index stores additional information that is extracted from - the PatchSet for the repository to speed up certain commands. - - createPatchIndexDisk: - Create the on-disk patch-index index from scratch. - updatePatchIndexDisk: - Update the on-disk patch-index index. - ----------------------------------------------------------------------------- -} - --- --------------------------------------------------------------------- --- Data structures for the patch-index - data FileIdSpan = FidSpan !FileId -- the fileid has some fixed name in the !PatchId -- span starting here @@ -128,26 +113,13 @@ infom::InfoMap } --- | an empty patch-index -emptyPatchIndex :: PatchIndex -emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty - -- | On-disk version of patch index -- version 1 is the one introduced in darcs 2.10 -- 2 changes the pids order to newer-to-older version :: Int8 version = 2 --- --------------------------------------------------------------------- --- Query the patch-index - -getInventoryHash :: FilePath -> IO String -getInventoryHash repodir = do - inv <- B.readFile (repodir darcsdir "hashed_inventory") - return $ sha256sum inv - --- --------------------------------------------------------------------- --- create patch-index +type PIM a = State PatchIndex a -- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given -- patch index pindex @@ -155,12 +127,12 @@ applyPatchMods pmods pindex = flip execState pindex $ mapM_ goList pmods where goList :: (PatchId, [PatchMod FileName]) -> PIM () - -- nubSeq handles invalid patch in darcs repo: - -- move with identical target name "rename darcs_patcher to darcs-patcher." goList (pid, mods) = do modify (\pind -> pind{pids = pid:pids pind}) mapM_ (curry go pid) (nubSeq mods) - + -- nubSeq handles invalid patch in darcs repo: + -- move with identical target name "rename darcs_patcher to darcs-patcher." + nubSeq = map head . group go :: (PatchId, PatchMod FileName) -> PIM () go (pid, PCreateFile fn) = do fid <- createFidStartSpan fn pid @@ -196,11 +168,6 @@ Just [] -> error $ "applyPatchMods: impossible, no entry for "++show fn ++" in FileIdSpans in duplicate, empty list" --- --------------------------------------------------------------------- --- Update and query patch index - -type PIM a = State PatchIndex a - -- | create new filespan for created file createFidStartSpan :: FileName -> PatchId -> PIM FileId createFidStartSpan fn pstart = do @@ -309,24 +276,18 @@ Nothing -> error "lookupFids' : could not find file" else return [] --- | remove sequential duplicates -nubSeq :: Eq a => [a] -> [a] -nubSeq = map head . group - --- --------------------------------------------------------------------- --- Create/Update patch-index on disk - --- | create patch index that corresponds to all patches in repo +-- | Creates patch index that corresponds to all patches in repo. createPatchIndexDisk - :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO () -createPatchIndexDisk repository@(Repo r _ _ _) = do - rawpatches <- newset2FL `fmap` readRepo repository r - let patches = mapFL Sealed2 rawpatches + :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> PatchSet rt p Origin wR + -> IO () +createPatchIndexDisk repository ps = do + let patches = mapFL Sealed2 $ patchSet2FL ps createPatchIndexFrom repository $ patches2patchMods patches S.empty -- | convert patches to patchmods -patches2patchMods :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) +patches2patchMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree) => [Sealed2 (PatchInfoAnd rt p)] -> Set FileName -> [(PatchId, [PatchMod FileName])] patches2patchMods patches fns = snd $ mapAccumL go fns patches where @@ -387,20 +348,22 @@ -- | update the patch index to the current state of the repository updatePatchIndexDisk - :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO () -updatePatchIndexDisk repo@(Repo repodir _ _ _) = do + :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> PatchSet rt p Origin wR + -> IO () +updatePatchIndexDisk repo patches = do + let repodir = repoLocation repo (_,_,pid2idx,pindex) <- loadPatchIndex repodir -- check that patch index is up to date - patches <- newset2FL `fmap` readRepo repo repodir - let pidsrepo = mapFL (makePatchID . info) patches + let flpatches = patchSet2FL patches + let pidsrepo = mapFL (makePatchID . info) flpatches (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo pindex' = removePidSuffix pid2idx oldpids pindex filenames = fpSpans2fileNames (fpspans pindex') cdir = repodir indexDir -- reread to prevent holding onto patches for too long - rawpatches <- newset2FL `fmap` readRepo repo repodir - let newpatches = drop len_common $ mapFL seal2 rawpatches + let newpatches = drop len_common $ mapFL seal2 flpatches newpmods = patches2patchMods newpatches filenames inv_hash <- getInventoryHash repodir storePatchIndex repodir cdir inv_hash (applyPatchMods newpmods pindex') @@ -414,18 +377,21 @@ -- | 'createPatchIndexFrom repo pmods' creates a patch index from the given -- patchmods. -createPatchIndexFrom :: RepoPatch p => Repository rt p wR wU wT +createPatchIndexFrom :: Repository rt p wR wU wT -> [(PatchId, [PatchMod FileName])] -> IO () -createPatchIndexFrom (Repo repodir _ _ _) pmods = do +createPatchIndexFrom repo pmods = do inv_hash <- getInventoryHash repodir storePatchIndex repodir cdir inv_hash (applyPatchMods pmods emptyPatchIndex) - where cdir = repodir indexDir - + where repodir = repoLocation repo + cdir = repodir indexDir + emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty --- --------------------------------------------------------------------- --- Load/Store patch-Index +getInventoryHash :: FilePath -> IO String +getInventoryHash repodir = do + inv <- B.readFile (repodir darcsdir "hashed_inventory") + return $ sha256sum inv --- | load patch-index from disk +-- | Load patch-index from disk along with some meta data. loadPatchIndex :: FilePath -> IO (Int8, String, Map PatchId Int, PatchIndex) loadPatchIndex repodir = do let pindex_dir = repodir indexDir @@ -437,65 +403,66 @@ fpspans <- loadFpMap (pindex_dir fpMapFile) return (v, inv_hash, pid2idx, PatchIndex pids fidspans fpspans infom) --- | load patch-index, --- | ensuring that whenever loaded, the patch-index --- | can actually be read by the current version of darcs, --- | and up to date. -loadSafePatchIndex :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +-- | If patch-index is useful as it is now, read it. If not, create or update it, then read it. +loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT - -> IO (Map PatchId Int, PatchIndex) -loadSafePatchIndex repo@(Repo repodir _ _ _) = do + -> PatchSet rt p Origin wR -- ^ PatchSet of the repository, used if we need to create the patch-index. + -> IO PatchIndex +loadSafePatchIndex repo ps = do + let repodir = repoLocation repo can_use <- isPatchIndexInSync repo - (_,_,pid2idx,pi) <- + (_,_,_,pi) <- if can_use then loadPatchIndex repodir - else do createOrUpdatePatchIndexDisk repo + else do createOrUpdatePatchIndexDisk repo ps loadPatchIndex repodir - return (pid2idx, pi) + return pi --- | check if patch-index exits for this repository +-- | Read-only. Checks if patch-index exists for this repository +-- it works by checking if: +-- +-- 1. @_darcs\/patch_index\/@ and its corresponding files are all present +-- 2. patch index version is the one handled by this version of Darcs doesPatchIndexExist :: FilePath -> IO Bool doesPatchIndexExist repodir = do - filesArePresent <- fmap and $ mapM (doesFileExist . (pindex_dir )) + filesArePresent <- and <$> mapM (doesFileExist . (pindex_dir )) [repoStateFile, pidsFile, touchMapFile, fidMapFile, fpMapFile] if filesArePresent - then do (v, _, _, _) <- loadPatchIndex repodir + then do v <- piVersion return (v == version) -- consider PI only of on-disk format is the current one else return False where pindex_dir = repodir indexDir + piVersion = fst <$> loadRepoState (pindex_dir repoStateFile) --- | check if noPatchIndex exists +-- | Read-only. Checks if @_darcs\/noPatchIndex@ exists, that is, if patch-index is explicitely disabled. isPatchIndexDisabled :: FilePath -> IO Bool isPatchIndexDisabled repodir = doesFileExist (repodir darcsdir noPatchIndex) --- | create or update patch index -createOrUpdatePatchIndexDisk :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO () -createOrUpdatePatchIndexDisk repo@(Repo repodir _ _ _)= do +-- | Create or update patch index +-- +-- 1. if @_darcs\/no_patch_index@ exists, delete it +-- 2. if patch index exists, update it +-- 3. if not, create it from scratch +createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () +createOrUpdatePatchIndexDisk repo ps = do + let repodir = repoLocation repo rmRecursive (repodir darcsdir noPatchIndex) `catch` \(_ :: IOError) -> return () dpie <- doesPatchIndexExist repodir if dpie - then updatePatchIndexDisk repo - else createPatchIndexDisk repo - --- | Checks whether a patch index can (and should) be created. If we are not in --- an old-fashioned repo, and if we haven't been told not to, then we should --- create a patch index if it doesn't already exist. -canCreatePI :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT - -> IO Bool -canCreatePI (Repo repodir format _ _) = - (not . or) <$> sequence [ doesntHaveHashedInventory format - , isPatchIndexDisabled repodir - , doesPatchIndexExist repodir - ] - where - doesntHaveHashedInventory = return . not . formatHas HashedInventory + then updatePatchIndexDisk repo ps + else createPatchIndexDisk repo ps --- | see if the default is to use patch index or not --- | creates Patch index, if it does not exist, and noPatchIndex is not set -canUsePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO Bool -canUsePatchIndex (Repo repodir _ _ _) = do +-- | Read-only. Checks the two following things: +-- +-- 1. 'doesPatchIndexExist' +-- 2. 'isPatchIndexDisabled' +-- +-- Then only if it exists and it is not explicitely disabled, returns @True@, else returns @False@ +-- (or an error if it exists and is explicitely disabled at the same time). +canUsePatchIndex :: Repository rt p wR wU wT -> IO Bool +canUsePatchIndex repo = do + let repodir = repoLocation repo piExists <- doesPatchIndexExist repodir piDisabled <- isPatchIndexDisabled repodir case (piExists, piDisabled) of @@ -504,18 +471,22 @@ (True, True) -> error "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify." (False, False) -> return False -createPIWithInterrupt :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO () -createPIWithInterrupt repo@(Repo repodir _ _ _) = do - putStrLn "Creating a patch index, please wait. To stop press Ctrl-C" - (do - createPatchIndexDisk repo - putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir) +-- | Creates patch-index (ignoring whether it is explicitely disabled). +-- If it is ctrl-c'ed, then aborts, delete patch-index and mark it as disabled. +createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () +createPIWithInterrupt repo ps = do + let repodir = repoLocation repo + putStrLn "Creating a patch index, please wait. To stop press Ctrl-C" + (do + createPatchIndexDisk repo ps + putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir) --- | check if patch-index is in sync with repository -isPatchIndexInSync :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO Bool -isPatchIndexInSync (Repo repodir _ _ _) = do +-- | Checks if patch-index exists and is in sync with repository (more precisely with @_darcs\/hashed_inventory@). +-- That is, checks if patch-index can be used as it is now. +isPatchIndexInSync :: Repository rt p wR wU wT -> IO Bool +isPatchIndexInSync repo = do + let repodir = repoLocation repo dpie <- doesPatchIndexExist repodir if dpie then do @@ -524,7 +495,7 @@ return (inv_hash == inv_hash_pindex) else return False --- | store patch-index on disk +-- | Stores patch-index on disk. storePatchIndex :: FilePath -> FilePath -> String -> PatchIndex -> IO () storePatchIndex repodir cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do createDirectory cdir `catch` \(_ :: IOError) -> return () @@ -556,7 +527,7 @@ storeFidMap :: FilePath -> FileIdSpans -> IO () storeFidMap fp fidm = encodeFile fp $ M.map (map (\(FidSpan a b c) -> (a, b, toIdxM c))) fidm - where toIdxM (Nothing) = zero + where toIdxM Nothing = zero toIdxM (Just pid) = pid loadFidMap :: FilePath -> IO FileIdSpans @@ -567,7 +538,7 @@ storeFpMap :: FilePath -> FilePathSpans -> IO () storeFpMap fp fidm = encodeFile fp $ M.map (map (\(FpSpan a b c) -> (a, b, toIdxM c))) fidm - where toIdxM (Nothing) = zero + where toIdxM Nothing = zero toIdxM (Just pid) = pid loadFpMap :: FilePath -> IO FilePathSpans @@ -575,9 +546,6 @@ where toPidM pid | pid == zero = Nothing | otherwise = Just pid -zero :: PatchId -zero = PID $ SHA1 0 0 0 0 0 - storeInfoMap :: FilePath -> InfoMap -> IO () storeInfoMap fp infom = encodeFile fp $ M.map (\fi -> (isFile fi, touching fi)) infom @@ -585,30 +553,17 @@ loadInfoMap :: FilePath -> IO InfoMap loadInfoMap fp = M.map (\(isF,pids) -> FileInfo isF pids) <$> decodeFile fp --- | Base directory for the patch index -indexDir :: String +indexDir, repoStateFile, pidsFile, fidMapFile, fpMapFile, + touchMapFile, noPatchIndex :: String indexDir = darcsdir "patch_index" - -repoStateFile :: String repoStateFile = "repo_state" - -pidsFile :: String pidsFile = "patch_ids" - -fidMapFile :: String fidMapFile = "fid_map" - -fpMapFile :: String fpMapFile = "fp_map" - -touchMapFile :: String touchMapFile = "touch_map" - -noPatchIndex :: String noPatchIndex = "no_patch_index" ------------------------------------------------------------------------ --- Delete patch index +-- | Deletes patch-index (@_darcs\/patch_index\/@ and its contents) and mark repository as disabled (creates @_darcs\/no_patch_index@). deletePatchIndex :: FilePath -> IO () deletePatchIndex repodir = do exists <- doesDirectoryExist indexDir @@ -618,9 +573,6 @@ (openFile (repodir darcsdir noPatchIndex) WriteMode >>= hClose) `catch` \(e :: IOError) -> error $ "Error: Could not disable patch index\n" ++ show e ------------------------------------------------------------------------ --- Dump information in patch index - dumpRepoState :: [PatchId] -> String dumpRepoState = unlines . map pid2string @@ -648,34 +600,38 @@ fpSpans2filePaths' :: FileIdSpans -> [FilePath] fpSpans2filePaths' fidSpans = [fn2fp fp | (fp, _) <- M.toList fidSpans] -dumpPatchIndex :: FilePath -> IO () -dumpPatchIndex repodir = do - (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- loadPatchIndex repodir - putStrLn $ "Inventory hash:" ++ inv_hash - putStrLn "=================" - putStrLn "Repo state:" - putStrLn "===========" - putStrLn $ dumpRepoState pids - putStrLn "Fileid spans:" - putStrLn "=============" - putStrLn $ dumpFileIdSpans fidspans - putStrLn "Filepath spans:" - putStrLn "==============" - putStrLn $ dumpFilePathSpans fpspans - putStrLn "Info Map:" - putStrLn "=========" - putStrLn $ dumpTouchingMap infom - putStrLn "Files:" - putStrLn "==============" - putStrLn $ unlines $ fpSpans2filePaths fpspans infom +-- | Checks if patch index can be created and build it with interrupt. +attemptCreatePatchIndex + :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () +attemptCreatePatchIndex repo ps = do + canCreate <- canCreatePI repo + when canCreate $ createPIWithInterrupt repo ps ------------------------------------------------------------------------ --- Filtering functions based on FilePaths --- returns an RL in which the order of patches matters, for annotate to use -getRelevantSubsequence :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) - => Sealed ((RL a) wK) -> Repository rt p wR wU wR -> [FileName] -> IO (Sealed ((RL a) Origin)) -getRelevantSubsequence pxes repository fns = do - (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository +-- | Checks whether a patch index can (and should) be created. If we are not in +-- an old-fashioned repo, and if we haven't been told not to, then we should +-- create a patch index if it doesn't already exist. +canCreatePI :: Repository rt p wR wU wT -> IO Bool +canCreatePI repo = + (not . or) <$> sequence [ doesntHaveHashedInventory (repoFormat repo) + , isPatchIndexDisabled repodir + , doesPatchIndexExist repodir + ] + where + repodir = repoLocation repo + doesntHaveHashedInventory = return . not . formatHas HashedInventory + +-- | Returns an RL in which the order of patches matters. Useful for the @annotate@ command. +-- If patch-index does not exist and is not explicitely disabled, silently create it. +-- (Also, if it is out-of-sync, which should not happen, silently update it). +getRelevantSubsequence :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) + => Sealed ((RL a) wK) -- ^ Sequence of patches you want to filter + -> Repository rt p wR wU wR -- ^ The repository (to attempt loading patch-index from its path) + -> PatchSet rt p Origin wR -- ^ PatchSet of repository (in case we need to create patch-index) + -> [FileName] -- ^ File(s) about which you want patches from given sequence + -> IO (Sealed ((RL a) Origin)) -- ^ Filtered sequence of patches. +getRelevantSubsequence pxes repository ps fns = do + pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repository ps let fids = map (\fn -> evalState (lookupFid fn) pi) fns pidss = map ((\(FileInfo _ a) -> a).fromJust.(`M.lookup` infom)) fids pids = S.unions pidss @@ -686,38 +642,58 @@ => FL a wX wY -> RL a wB wX -> S.Set Word32 -> RL a wP wQ keepElems NilFL acc _ = unsafeCoerceP acc keepElems (x:>:xs) acc pids - | (short $ makePatchID $ info x) `S.member` pids = keepElems xs (acc:<:x) pids - | otherwise = keepElems (unsafeCoerceP xs) acc pids - --- | filter given patches so as to keep only the patches that modify the given files -filterPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) => Repository rt p wR wU wT -> [FilePath] -> [Sealed2 a] -> IO [Sealed2 a] -filterPatches repository fps ops = do - (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository - let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps - npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids - return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops + | short (makePatchID $ info x) `S.member` pids = keepElems xs (acc:<:x) pids + | otherwise = keepElems (unsafeCoerceP xs) acc pids type PatchFilter rt p = [FilePath] -> [Sealed2 (PatchInfoAnd rt p)] -> IO [Sealed2 (PatchInfoAnd rt p)] --- | If a patch index is available, filter given patches so as to keep only the patches that --- modify the given files. If none is available, return the original input. +-- | If a patch index is available, returns a filter that takes a list of files and returns +-- a @PatchFilter@ that only keeps patches that modify the given list of files. +-- If patch-index cannot be used, return the original input. +-- If patch-index does not exist and is not explicitely disabled, silently create it. +-- (Also, if it is out-of-sync, which should not happen, silently update it). maybeFilterPatches - :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT - -> PatchFilter rt p -maybeFilterPatches repo fps ops = do + :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- ^ The repository + -> PatchSet rt p Origin wR -- ^ PatchSet of patches of repository (in case patch-index needs to be created) + -> PatchFilter rt p -- ^ PatchFilter ready to be used by SelectChanges. +maybeFilterPatches repo ps fps ops = do usePI <- canUsePatchIndex repo - -- in theory we could change the type signature to make this function staged, - -- but it doesn't seem worth it. - if usePI then filterPatches repo fps ops else return ops - + if usePI + then do + pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repo ps + let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps + npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids + return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops + else return ops ------------------------------------------------------------------------ --- Test patch index +-- | Dump information in patch index. Patch-index should be checked to exist beforehand. Read-only. +dumpPatchIndex :: FilePath -> IO () +dumpPatchIndex repodir = do + (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- loadPatchIndex repodir + putStrLn $ unlines $ + [ "Inventory hash:" ++ inv_hash + , "=================" + , "Repo state:" + , "===========" + , dumpRepoState pids + , "Fileid spans:" + , "=============" + , dumpFileIdSpans fidspans + , "Filepath spans:" + , "==============" + , dumpFilePathSpans fpspans + , "Info Map:" + , "=========" + , dumpTouchingMap infom + , "Files:" + , "==============" + ] ++ fpSpans2filePaths fpspans infom -piTest :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO () -piTest repository = do - (_, PatchIndex rpids fidspans fpspans infom) <- loadSafePatchIndex repository +-- | Read-only sanity check on patch-index. Patch-index should be checked to exist beforehand. It may not be in sync with repository. +piTest :: FilePath -> IO () +piTest repodir = do + (_,_,_,PatchIndex rpids fidspans fpspans infom) <- loadPatchIndex repodir let pids = reverse rpids -- test fidspans @@ -760,9 +736,4 @@ isInOrder [] _ = True isInOrder _ [] = False --- | Check if patch index can be created and build it with interrupt. -attemptCreatePatchIndex - :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO () -attemptCreatePatchIndex repo = do - canCreate <- canCreatePI repo - when canCreate $ createPIWithInterrupt repo + diff --git a/src/Darcs/Repository/Pending.hs b/src/Darcs/Repository/Pending.hs --- a/src/Darcs/Repository/Pending.hs +++ b/src/Darcs/Repository/Pending.hs @@ -16,15 +16,16 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Repository.Pending ( readPending - , readTentativePending - , writeTentativePending + , siftForPending + , tentativelyRemoveFromPending + , finalizePending + , makeNewPending + , tentativelyAddToPending + , setTentativePending + , prepend -- deprecated interface: - , readNewPending - , writeNewPending , pendingName ) where @@ -32,21 +33,57 @@ import Darcs.Prelude import Control.Applicative -import qualified Data.ByteString as BS ( empty ) +import qualified Data.ByteString as B ( empty ) +import Control.Exception ( catch, IOException ) +import Data.Maybe ( fromMaybe ) + +import Darcs.Util.Printer ( errorDoc ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.Lock ( writeDocBinFile ) -import Darcs.Repository.InternalTypes ( Repository(..) ) -import Darcs.Patch ( readPatch, RepoPatch, PrimOf ) +import Darcs.Util.Lock + ( writeDocBinFile + , removeFileMayNotExist + ) +import Darcs.Repository.InternalTypes ( Repository, withRepoLocation ) +import Darcs.Repository.Flags + ( UpdateWorking (..)) +import Darcs.Patch + ( readPatch, RepoPatch, PrimOf, tryToShrink + , primIsHunk, primIsBinary, commute, invert + , primIsAddfile, primIsAdddir, commuteFLorComplain + , effect, primIsSetpref, applyToTree ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) +import Darcs.Patch.Progress (progressFL) +import Darcs.Patch.Permutations ( commuteWhatWeCanFL + , removeFL + ) + +import Darcs.Patch.Prim ( tryShrinkingInverse + , PrimPatch + ) import Darcs.Patch.Read ( ReadPatch(..), bracketedFL ) import Darcs.Patch.ReadMonads ( ParserM ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Util.Exception ( catchall ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal ) -import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) ) +import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Util.Tree ( Tree ) +import Darcs.Util.Exception ( catchall ) +import Darcs.Util.Workaround ( renameFile ) +import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) +import Darcs.Patch.Witnesses.Sealed + ( Sealed(Sealed), mapSeal, seal + , FlippedSeal(FlippedSeal) + , flipSeal + ) +import Darcs.Patch.Witnesses.Unsafe + ( unsafeCoerceP, unsafeCoercePStart ) +import Darcs.Patch.Witnesses.Ordered + ( FL(..), RL(..), (:>)(..), (+>+) + , lengthFL, allFL, filterOutFLFL + , reverseFL, mapFL ) import Darcs.Util.ByteString ( gzReadFilePS ) -import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat ) +import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat, (<+>) ) +import Darcs.Util.Progress ( debugMessage ) pendingName :: String pendingName = darcsdir ++ "/patches/pending" @@ -77,21 +114,22 @@ readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT -> IO (Sealed (FL prim wX)) readPendingFile suffix _ = do - pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return BS.empty + pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return B.empty return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ pend -- Wrapper around FL where printed format uses { } except around singletons. -- Now that the Show behaviour of FL p can be customised (using --- showFLBehavior), we could instead change the general behaviour of FL Prim; +-- showFLBehavior (*)), we could instead change the general behaviour of FL Prim; -- but since the pending code can be kept nicely compartmentalised, it's nicer -- to do it this way. +-- (*) bf: This function does not exist. newtype FLM p wX wY = FLM { unFLM :: FL p wX wY } instance ReadPatch p => ReadPatch (FLM p) where readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}' instance ShowPatchBasic p => ShowPatchBasic (FLM p) where - showPatch = showMaybeBracketedFL showPatch '{' '}' . unFLM + showPatch f = showMaybeBracketedFL (showPatch f) '{' '}' . unFLM readMaybeBracketedFL :: forall m p wX . ParserM m => (forall wY . m (Sealed (p wY))) -> Char -> Char @@ -126,4 +164,228 @@ name = pendingName ++ suffix writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO () -writePatch f p = writeDocBinFile f $ showPatch p <> text "\n" +writePatch f p = writeDocBinFile f $ showPatch ForStorage p <> text "\n" + +-- | @siftForPending ps@ simplifies the candidate pending patch @ps@ +-- through a combination of looking for self-cancellations +-- (sequences of patches followed by their inverses), coalescing, +-- and getting rid of any hunk/binary patches we can commute out +-- the back +-- +-- The visual image of sifting can be quite helpful here. We are +-- repeatedly tapping (shrinking) the patch sequence and +-- shaking it (sift). Whatever falls out is the pending we want +-- to keep. We do this until the sequence looks about as clean as +-- we can get it +siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX) +siftForPending simple_ps = + if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps + then seal oldps + else fromJust $ do + Sealed x <- return $ sift NilFL $ reverseFL oldps + return $ case tryToShrink x of + ps | lengthFL ps < lengthFL oldps -> siftForPending ps + | otherwise -> seal ps + where + oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps + -- get rid of any hunk/binary patches that we can commute out the + -- back (ie. we work our way backwards, pushing the patches down + -- to the very end and popping them off; so in (addfile f :> hunk) + -- we can nuke the hunk, but not so in (hunk :> replace) + sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC) + sift sofar NilRL = seal sofar + sift sofar (ps:<:p) | primIsHunk p || primIsBinary p = + case commuteFLorComplain (p :> sofar) of + Right (sofar' :> _) -> sift sofar' ps + Left _ -> sift (p:>:sofar) ps + sift sofar (ps:<:p) = sift (p:>:sofar) ps + +-- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending' +-- that works without having to do any commutation. It either returns a +-- sifted pending (if the input is simple enough for this crude approach) +-- or has no effect. +crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY +crudeSift xs = + if isSimple xs then filterOutFLFL ishunkbinary xs else xs + where + ishunkbinary :: prim wA wB -> EqCheck wA wB + ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq + | otherwise = NotEq + +-- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it +-- adds a patch to the repository (eg. with apply or record). +-- Think of it as one part of transferring patches from pending to +-- somewhere else. +-- +-- Question (Eric Kow): how do we detect patch equivalence? +tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p) + => Repository rt p wR wU wT + -> UpdateWorking + -> PatchInfoAnd rt p wX wY + -> IO () +tentativelyRemoveFromPending _ NoUpdateWorking _ = return () +tentativelyRemoveFromPending repo YesUpdateWorking p = do + Sealed pend <- readTentativePending repo + -- Question (Eric Kow): why does pending being all simple matter for + -- changepref patches in p? isSimple includes changepref, so what do + -- adddir/etc have to do with it? Why don't we we systematically + -- crudeSift/not? + let effectp = if isSimple pend + then crudeSift $ effect p + else effect p + Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) + (unsafeCoercePStart pend) + writeTentativePending repo (unsafeCoercePStart newpend) + where + -- @rmpend effect pending@ removes as much of @effect@ from @pending@ + -- as possible + -- + -- Note that @effect@ and @pending@ must start from the same context + -- This is not a bad thing to assume because @effect@ is a patch we want to + -- add to the repository anyway so it'd kind of have to start from wR anyway + -- + -- Question (Eric Kow), ok then why not + -- @PatchInfoAnd p wR wY@ in the type signature above? + rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB) + rmpend NilFL x = Sealed x + rmpend _ NilFL = Sealed NilFL + rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys + rmpend (x:>:xs) ys = + case commuteWhatWeCanFL (x:>xs) of + a:>x':>b -> case rmpend a ys of + Sealed ys' -> case commute (invert (x':>:b) :> ys') of + Just (ys'' :> _) -> seal ys'' + Nothing -> seal $ invert (x':>:b)+>+ys' + -- DJR: I don't think this last case should be + -- reached, but it also shouldn't lead to corruption. + +-- | A sequence of primitive patches (candidates for the pending patch) +-- is considered simple if we can reason about their continued status as +-- pending patches solely on the basis of them being hunk/binary patches. +-- +-- Simple here seems to mean that all patches are either hunk/binary +-- patches, or patches that cannot (indirectly) depend on hunk/binary +-- patches. For now, the only other kinds of patches in this category +-- are changepref patches. +-- +-- It might be tempting to add, say, adddir patches but it's probably not a +-- good idea because Darcs also inverts patches a lot in its reasoning so an +-- innocent addir may be inverted to a rmdir which in turn may depend on +-- a rmfile, which in turn depends on a hunk/binary. Likewise, we would +-- not want to add move patches to this category for similar reasons of +-- a potential dependency chain forming. +isSimple :: PrimPatch prim => FL prim wX wY -> Bool +isSimple = + allFL isSimp + where + isSimp x = primIsHunk x || primIsBinary x || primIsSetpref x + +-- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the +-- @pendPs@ could be applied to pristine if we wanted to, and if so +-- writes it to disk. If it can't be applied, @pendPs@ must +-- be somehow buggy, so we save it for forensics and crash. +makeNewPending :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> UpdateWorking + -> FL (PrimOf p) wT wY + -> Tree IO -- ^recorded state of the repository, to check if pending can be applied + -> IO () +makeNewPending _ NoUpdateWorking _ _ = return () +makeNewPending repo YesUpdateWorking origp recordedState = + withRepoLocation repo $ + do let newname = pendingName ++ ".new" + debugMessage $ "Writing new pending: " ++ newname + Sealed sfp <- return $ siftForPending origp + writeNewPending repo sfp + Sealed p <- readNewPending repo + -- We don't ever use the resulting tree. + _ <- catch (applyToTree p recordedState) $ \(err :: IOException) -> do + let buggyname = pendingName ++ "_buggy" + renameFile newname buggyname + errorDoc $ text ("There was an attempt to write an invalid pending! " ++ show err) + $$ text "If possible, please send the contents of" + <+> text buggyname + $$ text "along with a bug report." + renameFile newname pendingName + debugMessage $ "Finished writing new pending: " ++ newname + +-- | Replace the pending patch with the tentative pending. +-- If @NoUpdateWorking@, this merely deletes the tentative pending +-- without replacing the current one. +-- +-- Question (Eric Kow): shouldn't this also delete the tentative +-- pending if @YesUpdateWorking@? I'm just puzzled by the seeming +-- inconsistency of the @NoUpdateWorking@ doing deletion, but +-- @YesUpdateWorking@ not bothering. +finalizePending :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> UpdateWorking + -> Tree IO + -> IO () +finalizePending repo NoUpdateWorking _ = + withRepoLocation repo $ removeFileMayNotExist pendingName +finalizePending repo updateWorking@YesUpdateWorking recordedState = + withRepoLocation repo $ do + Sealed tpend <- readTentativePending repo + Sealed new_pending <- return $ siftForPending tpend + makeNewPending repo updateWorking new_pending recordedState + +-- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@ +-- appends @ps@ to the pending patch. +-- +-- It has no effect with @NoUpdateWorking@. +-- +-- This fuction is unsafe because it accepts a patch that works on the +-- tentative pending and we don't currently track the state of the +-- tentative pending. +tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p + => Repository rt p wR wU wT + -> UpdateWorking + -> FL (PrimOf p) wX wY + -> IO () +tentativelyAddToPending _ NoUpdateWorking _ = return () +tentativelyAddToPending repo YesUpdateWorking patch = + withRepoLocation repo $ do + Sealed pend <- readTentativePending repo + FlippedSeal newpend_ <- return $ + newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch + writeTentativePending repo (unsafeCoercePStart newpend_) + where + newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC + newpend NilFL patch_ = flipSeal patch_ + newpend p patch_ = flipSeal $ p +>+ patch_ + +-- | setTentativePending is basically unsafe. It overwrites the pending +-- state with a new one, not related to the repository state. +setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p + => Repository rt p wR wU wT + -> UpdateWorking + -> FL (PrimOf p) wX wY + -> IO () +setTentativePending _ NoUpdateWorking _ = return () +setTentativePending repo YesUpdateWorking patch = do + Sealed prims <- return $ siftForPending patch + withRepoLocation repo $ writeTentativePending repo (unsafeCoercePStart prims) + +-- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch +-- It's used right before removing @ps@ from the repo. This ensures that +-- the pending patch can still be applied on top of the recorded state. +-- +-- This function is basically unsafe. It overwrites the pending state +-- with a new one, not related to the repository state. +prepend :: forall rt p wR wU wT wX wY. RepoPatch p + => Repository rt p wR wU wT + -> UpdateWorking + -> FL (PrimOf p) wX wY + -> IO () +prepend _ NoUpdateWorking _ = return () +prepend repo YesUpdateWorking patch = do + Sealed pend <- readTentativePending repo + Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch + writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_) + where + newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA) + newpend NilFL patch_ = seal patch_ + newpend p patch_ = seal $ patch_ +>+ p + + diff --git a/src/Darcs/Repository/Prefs.hs b/src/Darcs/Repository/Prefs.hs --- a/src/Darcs/Repository/Prefs.hs +++ b/src/Darcs/Repository/Prefs.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. - -{-# LANGUAGE CPP #-} - module Darcs.Repository.Prefs ( addToPreflist , deleteSources @@ -39,12 +36,15 @@ , FileType(..) , filetypeFunction , getCaches - , binariesFileHelp - , boringFileHelp , globalCacheDir , globalPrefsDirDoc , globalPrefsDir - , oldGlobalCacheDir + , getMotd + , showMotd + , prefsUrl + , prefsDirPath + -- * documentation of prefs files + , prefsFilesHelp ) where import Prelude () @@ -56,28 +56,28 @@ import Data.List ( nub, isPrefixOf, union, sortBy, lookup ) import Data.Maybe ( isJust, fromMaybe, mapMaybe, catMaybes, maybeToList ) import qualified Control.Exception as C -import qualified Data.ByteString as B ( empty ) +import qualified Data.ByteString as B ( empty, null, hPut, ByteString ) import qualified Data.ByteString.Char8 as BC ( unpack ) import System.Directory ( getAppUserDataDirectory, doesDirectoryExist, createDirectory, doesFileExist ) import System.Environment ( getEnvironment ) import System.FilePath.Posix ( normalise, dropTrailingPathSeparator, () ) import System.IO.Error ( isDoesNotExistError ) -import System.IO ( stderr ) +import System.IO ( stdout, stderr ) import System.Info ( os ) import Text.Regex ( Regex, mkRegex, matchRegex ) import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..), compareByLocality ) -import Darcs.Util.External ( gzFetchFilePS , Cachable( Cachable )) +import Darcs.Util.External ( gzFetchFilePS , fetchFilePS, Cachable(..)) import Darcs.Repository.Flags( UseCache (..), DryRun (..), SetDefault (..), RemoteRepos (..) ) -import Darcs.Util.Lock( readBinFile, writeBinFile ) +import Darcs.Util.Lock( readTextFile, writeTextFile ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory ) -import Darcs.Util.Printer( hPutDocLn, text, RenderMode(..) ) +import Darcs.Util.Printer( hPutDocLn, text ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.File ( osxCacheDir, xdgCacheDir, removeFileMayNotExist ) @@ -91,9 +91,8 @@ setPreflist "binaries" defaultBinaries setPreflist "motd" [] -{-# NOINLINE defaultBoring #-} defaultBoring :: [String] -defaultBoring = map ("# " ++) boringFileHelp ++ +defaultBoring = map ("# " ++) boringFileInternalHelp ++ [ "" , "### compiler and interpreter intermediate files" , "# haskell (ghc) interfaces" @@ -156,8 +155,6 @@ , "(^|/)SCCS($|/)" , "# darcs" , "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)" - , "^\\.darcs-temp-mail$" - , "-darcs-backup[[:digit:]]+$" , "# gnu arch" , "(^|/)(\\+|,)" , "(^|/)vssver\\.scc$" @@ -191,12 +188,12 @@ , "(^|.*/)\\.emacs\\.desktop(\\.lock)?$" ] -boringFileHelp :: [String] -boringFileHelp = +boringFileInternalHelp :: [String] +boringFileInternalHelp = [ "This file contains a list of extended regular expressions, one per" , "line. A file path matching any of these expressions will be filtered" - , "out during `darcs add', or when the `--look-for-adds' flag is passed" - , "to `darcs whatsnew' and `record'. The entries in " + , "out during `darcs add`, or when the `--look-for-adds` flag is passed" + , "to `darcs whatsnew` and `record`. The entries in " ++ globalPrefsDirDoc ++ "boring (if" , "it exists) supplement those in this file." , "" @@ -252,18 +249,6 @@ | osx = (( "darcs") `fmap`) `fmap` osxCacheDir | otherwise = (( "darcs") `fmap`) `fmap` xdgCacheDir --- |oldGlobalCacheDir is the old cache path @~/.darcs/cache@ --- now ony used with read-only access. -oldGlobalCacheDir :: IO (Maybe FilePath) -oldGlobalCacheDir - = do dir <- (( "cache") `fmap`) `fmap` globalPrefsDir - case dir of - Nothing -> return Nothing - Just d -> do exists <- doesDirectoryExist d - if exists - then return $ Just d - else return Nothing - -- |tryMakeBoringRegexp attempts to create a Regex from a given String. The -- evaluation is forced, to ensure any malformed exceptions are thrown here, -- and not later. @@ -273,7 +258,7 @@ regex = C.evaluate (Just $! mkRegex input) handleBadRegex :: C.SomeException -> IO (Maybe Regex) - handleBadRegex _ = hPutDocLn Encode stderr warning >> return Nothing + handleBadRegex _ = hPutDocLn stderr warning >> return Nothing warning = text $ "Warning: Ignored invalid boring regex: " ++ input @@ -302,10 +287,10 @@ nonComment _ = True getPrefLines :: FilePath -> IO [String] -getPrefLines f = removeCRsCommentsAndConflicts `fmap` readBinFile f +getPrefLines f = removeCRsCommentsAndConflicts `fmap` readTextFile f where removeCRsCommentsAndConflicts = - filter notconflict . noncomments . map stripCr . lines + filter notconflict . noncomments . map stripCr startswith [] _ = True startswith (x : xs) (y : ys) = x == y && startswith xs ys startswith _ _ = False @@ -325,7 +310,6 @@ | TextFile deriving (Eq) -{-# 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). @@ -333,7 +317,7 @@ -- Note that while this matches .gz and .GZ, it will not match .gZ, -- i.e. it is not truly case insensitive. defaultBinaries :: [String] -defaultBinaries = map ("# "++) binariesFileHelp ++ +defaultBinaries = map ("# "++) binariesFileInternalHelp ++ [ "\\." ++ regexToMatchOrigOrUpper e ++ "$" | e <- extensions ] where regexToMatchOrigOrUpper e = "(" ++ e ++ "|" ++ map toUpper e ++ ")" @@ -363,8 +347,8 @@ , "zip" ] -binariesFileHelp :: [String] -binariesFileHelp = +binariesFileInternalHelp :: [String] +binariesFileInternalHelp = [ "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 " @@ -402,7 +386,7 @@ hasprefs <- doesDirectoryExist prefs unless hasprefs $ createDirectory prefs pl <- getPreflist pref - writeBinFile (prefs ++ pref) . unlines $ union [value] pl + writeTextFile (prefs ++ pref) . unlines $ union [value] pl getPreflist :: String -> IO [String] getPreflist p = findPrefsDirectory >>= @@ -417,14 +401,14 @@ setPreflist p ls = withPrefsDirectory $ \prefs -> do haspref <- doesDirectoryExist prefs when haspref $ - writeBinFile (prefs ++ p) (unlines ls) + writeTextFile (prefs ++ p) (unlines ls) defPrefval :: String -> String -> IO String defPrefval p d = fromMaybe d `fmap` getPrefval p getPrefval :: String -> IO (Maybe String) getPrefval p = do - pl <- getPreflist "prefs" + pl <- getPreflist prefsDir return $ case map snd $ filter ((== p) . fst) $ map (break (== ' ')) pl of [val] -> case words val of [] -> Nothing @@ -433,8 +417,8 @@ setPrefval :: String -> String -> IO () setPrefval p v = do - pl <- getPreflist "prefs" - setPreflist "prefs" $ updatePrefVal pl p v + pl <- getPreflist prefsDir + setPreflist prefsDir $ updatePrefVal pl p v updatePrefVal :: [String] -> String -> String -> [String] updatePrefVal prefList p newVal = @@ -442,10 +426,10 @@ changePrefval :: String -> String -> String -> IO () changePrefval p f t = do - pl <- getPreflist "prefs" + pl <- getPreflist prefsDir ov <- getPrefval p let newval = maybe t (\old -> if old == f then t else old) ov - setPreflist "prefs" $ updatePrefVal pl p newval + setPreflist prefsDir $ updatePrefVal pl p newval fixRepoPath :: String -> IO FilePath fixRepoPath p @@ -513,12 +497,7 @@ `fmap` (gzFetchFilePS (repodir sourcesFile) Cachable `catchall` return B.empty) - oldGlobalcachedir <- oldGlobalCacheDir globalcachedir <- globalCacheDir - let oldGlobalcache = if nocache then [] - else case oldGlobalcachedir of - Nothing -> [] - Just d -> [Cache Directory NotWritable d] let globalcache = if nocache then [] else case globalcachedir of @@ -530,7 +509,6 @@ thatrepo = [Cache Repo NotWritable repodir] tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++ here ++ thatrepo ++ filterExternalSources there - ++ oldGlobalcache return $ Ca $ sortBy compareByLocality tempCache where sourcesFile = darcsdir ++ "/prefs/sources" @@ -551,3 +529,158 @@ if isValidLocalPath repodir then there else filter (not . isValidLocalPath . cacheSource) there + +-- | Fetch and return the message of the day for a given repository. +getMotd :: String -> IO B.ByteString +getMotd repo = fetchFilePS motdPath (MaxAge 600) `catchall` return B.empty + where + motdPath = repo ++ "/" ++ darcsdir ++ "/prefs/motd" + +-- | Display the message of the day for a given repository, +showMotd :: String -> IO () +showMotd repo = do + motd <- getMotd repo + unless (B.null motd) $ do + B.hPut stdout motd + putStrLn $ replicate 22 '*' + +prefsUrl :: FilePath -> String +prefsUrl r = r ++ "/"++darcsdir++"/prefs" + +prefsDir :: FilePath +prefsDir = "prefs" + +prefsDirPath :: FilePath +prefsDirPath = darcsdir prefsDir + +prefsFilesHelp :: [(String,String)] +prefsFilesHelp = + [ ("motd", unlines + [ "The `_darcs/prefs/motd` file may contain a 'message of the day' which" + , "will be displayed to users who clone or pull from the repository without" + , "the `--quiet` option."]) + , ("email", unlines + [ "The `_darcs/prefs/email` file is used to provide the e-mail address for" + , "your repository that others will use when they `darcs send` a patch back" + , "to you. The contents of the file should simply be an e-mail address."]) + , ("post", unlines + [ "If `_darcs/prefs/post` exists in the target repository, `darcs send ` will" + , "upload to the URL contained in that file, which may either be a `mailto:`" + , "URL, or an `http://` URL. In the latter case, the patch is posted to that URL."]) + , ("author", unlines + [ "The `_darcs/prefs/author` file contains the email address (or name) to" + , "be used as the author when patches are recorded in this repository," + , "e.g. `David Roundy `. This file overrides the" + , "contents of the environment variables `$DARCS_EMAIL` and `$EMAIL`."]) + , ("defaults", unlines + [ "Default values for darcs commands. Each line of this file has the" + , "following form:" + , "" + , " COMMAND FLAG VALUE" + , "" + , "where `COMMAND` is either the name of the command to which the default" + , "applies, or `ALL` to indicate that the default applies to all commands" + , "accepting that flag. The `FLAG` term is the name of the long argument" + , "option without the `--`, i.e. `verbose` rather than `--verbose`." + , "Finally, the `VALUE` option can be omitted if the flag does not involve" + , "a value. If the value has spaces in it, use single quotes, not double" + , "quotes, to surround it. Each line only takes one flag. To set multiple" + , "defaults for the same command (or for `ALL` commands), use multiple lines." + , "" + , "Note that the use of `ALL` easily can have unpredicted consequences," + , "especially if commands in newer versions of darcs accepts flags that" + , "they did not in previous versions. Only use safe flags with `ALL`." + , "" + , "For example, if your system clock is bizarre, you could instruct darcs to" + , "always ignore the file modification times by adding the following line:" + , "" + , " ALL ignore-times" + , "" + , "There are some options which are meant specifically for use in" + , "`_darcs/prefs/defaults`. One of them is `--disable`. As the name" + , "suggests, this option will disable every command that got it as" + , "argument. So, if you are afraid that you could damage your repositories" + , "by inadvertent use of a command like amend, add the following line:" + , "" + , " amend disable" + , "" + , "Also, a global preferences file can be created with the name" + , "`.darcs/defaults` in your home directory. Options present there will be" + , "added to the repository-specific preferences if they do not conflict."]) + , ("sources", unlines + [ "The `_darcs/prefs/sources` file is used to indicate alternative locations" + , "from which to download patches. This file contains lines such as:" + , "" + , " cache:/home/droundy/.cache/darcs" + , " readonly:/home/otheruser/.cache/darcs" + , " repo:http://darcs.net" + , "" + , "This would indicate that darcs should first look in" + , "`/home/droundy/.cache/darcs` for patches that might be missing, and if" + , "the patch is not there, it should save a copy there for future use." + , "In that case, darcs will look in `/home/otheruser/.cache/darcs` to see if" + , "that user might have downloaded a copy, but will not try to save a copy" + , "there, of course. Finally, it will look in `http://darcs.net`. Note that" + , "the `sources` file can also exist in `~/.darcs/`. Also note that the" + , "sources mentioned in your `sources` file will be tried *before* the" + , "repository you are pulling from. This can be useful in avoiding" + , "downloading patches multiple times when you pull from a remote" + , "repository to more than one local repository." + , "" + , "A global cache is enabled by default in your home directory. The cache" + , "allows darcs to avoid re-downloading patches (for example, when doing a" + , "second darcs clone of the same repository), and also allows darcs to use" + , "hard links to reduce disk usage." + , "" + , "Note that the cache directory should reside on the same filesystem as" + , "your repositories, so you may need to vary this. You can also use" + , "multiple cache directories on different filesystems, if you have several" + , "filesystems on which you use darcs."]) + , ("boring", unlines + [ "The `_darcs/prefs/boring` file may contain a list of regular expressions" + , "describing files, such as object files, that you do not expect to add to" + , "your project. A newly created repository has a boring file that includes" + , "many common source control, backup, temporary, and compiled files." + , "" + , "You may want to have the boring file under version control. To do this" + , "you can use darcs setpref to set the value 'boringfile' to the name of" + , "your desired boring file (e.g. `darcs setpref boringfile .boring`, where" + , "`.boring` is the repository path of a file that has been darcs added to" + , "your repository). The boringfile preference overrides" + , "`_darcs/prefs/boring`, so be sure to copy that file to the boringfile." + , "" + , "You can also set up a 'boring' regexps file in your home directory, named" + , "`~/.darcs/boring`, which will be used with all of your darcs repositories." + , "" + , "Any file not already managed by darcs and whose repository path" + , "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 `darcs add newdir newdir/*`" + , "without accidentally adding a bunch of object files. It is also used" + , "when the `--look-for-adds` flag is given to whatsnew or record. Note" + , "that once a file has been added to darcs, it is not considered boring," + , "even if it matches the boring file filter."]) + , ("binaries", unlines + [ "The `_darcs/prefs/binaries` file may contain a list of regular" + , "expressions describing files that should be treated as binary files rather" + , "than text files. Darcs automatically treats files containing characters" + , "`^Z` or `NULL` within the first 4096 bytes as being binary files." + , "You probably will want to have the binaries file under version control." + , "To do this you can use `darcs setpref` to set the value 'binariesfile'" + , "to the name of your desired binaries file" + , "(e.g. `darcs setpref binariesfile ./.binaries`, where `.binaries` is a" + , "file that has been darcs added to your repository). As with the boring" + , "file, you can also set up a `~/.darcs/binaries` file if you like."]) + , ("defaultrepo", unlines + [ "Contains the URL of the default remote repository used by commands `pull`," + , "`push`, `send` and `optimize relink`. Darcs edits this file automatically" + , "or when the flag `--set-default` is used."]) + , ("tmpdir", unlines + [ "By default temporary directories are created in `/tmp`, or if that doesn't" + , "exist, in `_darcs` (within the current repo). This can be overridden by" + , "specifying some other directory in the file `_darcs/prefs/tmpdir` or the" + , "environment variable `$DARCS_TMPDIR` or `$TMPDIR`."]) + , ("prefs", unlines + [ "Contains the preferences set by the command `darcs setprefs`." + , "Do not edit manually."]) + ] diff --git a/src/Darcs/Repository/Rebase.hs b/src/Darcs/Repository/Rebase.hs --- a/src/Darcs/Repository/Rebase.hs +++ b/src/Darcs/Repository/Rebase.hs @@ -1,7 +1,6 @@ -- Copyright (C) 2009-2012 Ganesh Sittampalam -- -- BSD3 -{-# LANGUAGE CPP #-} module Darcs.Repository.Rebase ( RebaseJobFlags(..) , withManualRebaseUpdate @@ -52,7 +51,7 @@ , removeFromFormat , writeRepoFormat ) -import Darcs.Repository.Internal +import Darcs.Repository.Hashed ( tentativelyAddPatch , tentativelyAddPatch_ , tentativelyAddPatches_ @@ -64,19 +63,17 @@ , readRepo , UpdatePristine(..) ) -import Darcs.Repository.InternalTypes ( Repository(..) ) +import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) +import Darcs.Util.Printer ( ePutDocLn, text ) import Darcs.Util.Progress ( debugMessage ) - import Darcs.Util.Tree ( Tree ) import Control.Exception ( finally ) import System.FilePath.Posix ( () ) -#include "impossible.h" - -- | Some common flags that are needed to run rebase jobs. -- Normally flags are captured directly by the implementation of the specific -- job's function, but the rebase infrastructure needs to do work on the repository @@ -98,7 +95,7 @@ -> IO (Repository rt p wR wU wT2, x) withManualRebaseUpdate (RebaseJobFlags compr verb uw) r subFunc | SRepoType SIsRebase <- singletonRepoType :: SRepoType rt - = do patches <- readTentativeRepo r + = do patches <- readTentativeRepo r (repoLocation r) let go :: PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x) go (PatchSet _ NilRL) = bug "trying to recontext rebase without rebase patch at head (tag)" go (PatchSet _ (_ :<: q)) = @@ -151,9 +148,8 @@ => Repository ('RepoType 'IsRebase) p wR wU wR -> RebaseJobFlags -> IO () -checkSuspendedStatus repo@(Repo _ rf _ _) flags@(RebaseJobFlags compr _verb uw) = do - allpatches <- readRepo repo - (_, Sealed2 ps) <- return $ takeAnyRebase allpatches +checkSuspendedStatus repo flags@(RebaseJobFlags compr _verb uw) = do + (_, Sealed2 ps) <- takeAnyRebase <$> readRepo repo case countToEdit ps of 0 -> do debugMessage "Removing the rebase patch file..." @@ -168,9 +164,11 @@ (rebase, _, _) <- takeHeadRebase <$> readRepo repo' repo'' <- tentativelyRemovePatches repo' compr uw (rebase :>: NilFL) finalizeRepositoryChanges repo'' uw compr - writeRepoFormat (removeFromFormat RebaseInProgress rf) (darcsdir "format") + writeRepoFormat + (removeFromFormat RebaseInProgress (repoFormat repo)) + (darcsdir "format") putStrLn "Rebase finished!" - n -> putStrLn $ "Rebase in progress: " ++ show n ++ " suspended patches" + n -> ePutDocLn $ text $ "Rebase in progress: " ++ show n ++ " suspended patches" moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR @@ -191,14 +189,13 @@ finalizeRepositoryChanges repo'''' uw compr return repo'''' -displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO () +displaySuspendedStatus :: RepoPatch p => Repository ('RepoType 'IsRebase) p wR wU wR -> IO () displaySuspendedStatus repo = do - allpatches <- readRepo repo - (_, Sealed2 ps) <- return $ takeAnyRebase allpatches - putStrLn $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches" + (_, Sealed2 ps) <- takeAnyRebase <$> readRepo repo + ePutDocLn $ text $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches" maybeDisplaySuspendedStatus - :: (RepoPatch p, ApplyState p ~ Tree) + :: RepoPatch p => SRebaseType rebaseType -> Repository ('RepoType rebaseType) p wR wU wR -> IO () maybeDisplaySuspendedStatus SIsRebase repo = displaySuspendedStatus repo maybeDisplaySuspendedStatus SNoRebase _ = return () @@ -207,7 +204,9 @@ => Repository ('RepoType 'IsRebase) p wR wU wT -> RebaseJobFlags -> IO (Repository ('RepoType 'IsRebase) p wR wU wT) -startRebaseIfNecessary repo@(Repo _ rf _ _) (RebaseJobFlags compr verb uw) = +startRebaseIfNecessary repo (RebaseJobFlags compr verb uw) = + let rf = repoFormat repo + in if formatHas RebaseInProgress rf then return repo else do -- TODO this isn't under the repo lock, and it should be 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,5 +1,3 @@ -{-# LANGUAGE CPP, PatternGuards #-} - module Darcs.Repository.Repair ( replayRepository, checkIndex, replayRepositoryInTemp, RepositoryConsistency(..) ) @@ -26,8 +24,8 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Repair ( Repair(applyAndTryToFix) ) -import Darcs.Patch.Info ( showPatchInfoUI ) -import Darcs.Patch.Set ( Origin, PatchSet(..), newset2FL, newset2RL ) +import Darcs.Patch.Info ( displayPatchInfo ) +import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2FL, patchSet2RL ) import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent ) import Darcs.Repository.Flags @@ -36,10 +34,10 @@ RepoProperty ( HashedInventory ), formatHas ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) import Darcs.Repository.HashedIO ( cleanHashdir ) -import Darcs.Repository.HashedRepo ( readHashedPristineRoot, writeAndReadPatch ) -import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) +import Darcs.Repository.Hashed ( readHashedPristineRoot, writeAndReadPatch ) +import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation ) import Darcs.Repository.Prefs ( filetypeFunction ) -import Darcs.Repository.Internal ( readRepo ) +import Darcs.Repository.Hashed ( readRepo ) import Darcs.Repository.State ( readRecorded , readIndex @@ -52,7 +50,7 @@ import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Lock( rmRecursive, withTempDir ) -import Darcs.Util.Printer ( Doc, putDocLn, text, RenderMode(..) ) +import Darcs.Util.Printer ( Doc, putDocLn, text ) import Darcs.Util.Printer.Color ( showDoc ) import Darcs.Util.Hash( Hash(NoHash), encodeBase16 ) @@ -62,9 +60,7 @@ import Darcs.Util.Tree.Plain( readPlainTree ) import Darcs.Util.Index( updateIndex ) -import qualified Data.ByteString.Char8 as BS - -#include "impossible.h" +import qualified Data.ByteString.Char8 as BC replaceInFL :: FL (PatchInfoAnd rt a) wX wY -> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)] @@ -79,12 +75,12 @@ => Repository rt p wR wU wT -> Compression -> FL (PatchInfoAnd rt p) Origin wR -> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool) applyAndFix _ _ NilFL = return (NilFL, True) -applyAndFix r@(Repo r' _ _ c) compr psin = +applyAndFix r compr psin = do liftIO $ beginTedious k liftIO $ tediousSize k $ lengthFL psin (repaired, ok) <- aaf psin liftIO $ endTedious k - orig <- liftIO $ newset2FL `fmap` readRepo r + orig <- liftIO $ patchSet2FL `fmap` readRepo r return (replaceInFL orig repaired, ok) where k = "Replaying patch" aaf :: FL (PatchInfoAnd rt p) wW wZ -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool) @@ -95,28 +91,30 @@ Just err -> liftIO $ putDocLn err Nothing -> return () let !winfp = winfo p -- assure that 'p' can be garbage collected. - liftIO $ finishedOneIO k $ showDoc Encode $ showPatchInfoUI $ unWPatchInfo winfp + liftIO $ finishedOneIO k $ showDoc $ displayPatchInfo $ unWPatchInfo winfp (ps', restok) <- aaf ps case mp' of Nothing -> return (ps', restok) - Just (e,pp) -> liftIO $ do putStrLn e - p' <- withCurrentDirectory r' $ writeAndReadPatch c compr pp - return (Sealed2 (winfp :||: p'):ps', False) + Just (e,pp) -> liftIO $ do + putStrLn e + p' <- withCurrentDirectory (repoLocation r) $ + writeAndReadPatch (repoCache r) compr pp + return (Sealed2 (winfp :||: p'):ps', False) data RepositoryConsistency rt p wX = RepositoryConsistent | BrokenPristine (Tree IO) | BrokenPatches (Tree IO) (PatchSet rt p Origin wX) -checkUniqueness :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +checkUniqueness :: (IsRepoType rt, RepoPatch p) => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO () checkUniqueness putVerbose putInfo repository = do putVerbose $ text "Checking that patch names are unique..." r <- readRepo repository - case hasDuplicate $ mapRL info $ newset2RL r of + case hasDuplicate $ mapRL info $ patchSet2RL r of Nothing -> return () Just pinf -> do putInfo $ text "Error! Duplicate patch name:" - putInfo $ showPatchInfoUI pinf + putInfo $ displayPatchInfo pinf fail "Duplicate patches found." hasDuplicate :: Ord a => [a] -> Maybe a @@ -139,7 +137,7 @@ putVerbose $ text "Applying patches..." patches <- readRepo repo debugMessage "Fixing any broken patches..." - let psin = newset2FL patches + let psin = patchSet2FL patches repair = applyAndFix repo compr psin ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay @@ -161,7 +159,7 @@ cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO () cleanupRepositoryReplay r = do - let c = extractCache r + let c = repoCache r rf <- identifyRepoFormat "." unless (formatHas HashedInventory rf) $ rmRecursive $ darcsdir ++ "/pristine.hashed" @@ -207,8 +205,8 @@ format paths = unlines $ map ((" " ++) . anchorPath "") paths mismatches_disp = unlines [ anchorPath "" p ++ - "\n index: " ++ BS.unpack (encodeBase16 h1) ++ - "\n working: " ++ BS.unpack (encodeBase16 h2) + "\n index: " ++ BC.unpack (encodeBase16 h1) ++ + "\n working: " ++ BC.unpack (encodeBase16 h2) | (p, h1, h2) <- mismatches ] unless (quiet || null index_extra) $ putStrLn $ "Extra items in index!\n" ++ format index_extra diff --git a/src/Darcs/Repository/Resolution.hs b/src/Darcs/Repository/Resolution.hs --- a/src/Darcs/Repository/Resolution.hs +++ b/src/Darcs/Repository/Resolution.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.Repository.Resolution ( standardResolution , externalResolution diff --git a/src/Darcs/Repository/State.hs b/src/Darcs/Repository/State.hs --- a/src/Darcs/Repository/State.hs +++ b/src/Darcs/Repository/State.hs @@ -25,7 +25,7 @@ ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir , maybeRestrictSubpaths -- * Diffs - , unrecordedChanges, unrecordedChangesWithPatches, readPending + , unrecordedChanges, readPending -- * Trees , readRecorded, readUnrecorded, readRecordedAndPending, readWorking , readPendingAndWorking, readUnrecordedFiltered @@ -33,16 +33,17 @@ , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..) -- * Utilities , filterOutConflicts - -- * Detection of changes - , getMovesPs, getReplaces + -- * Pending-related functions that depend on repo state + , addPendingDiffToPending, addToPending ) where import Prelude () import Darcs.Prelude -import Control.Monad( when, foldM ) +import Control.Monad ( when, foldM, forM ) +import Control.Monad.State ( StateT, runStateT, get, put, liftIO ) import Control.Exception ( catch, IOException ) -import Data.Maybe ( isJust, fromJust ) +import Data.Maybe ( isJust ) import Data.Ord ( comparing ) import Data.List ( sortBy, union, delete ) import Text.Regex( matchRegex ) @@ -50,45 +51,46 @@ import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile ) import System.FilePath ( () ) import qualified Data.ByteString as B - ( readFile, drop, writeFile, empty, concat ) + ( ByteString, readFile, drop, writeFile, empty, concat ) import qualified Data.ByteString.Char8 as BC ( pack, unpack, split ) import qualified Data.ByteString.Lazy as BL ( toChunks ) -import Darcs.Patch ( effect, RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims - , PrimPatch, primIsHunk, maybeApplyToTree +import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrims + , PrimPatch, maybeApplyToTree , tokreplace, forceTokReplace, move ) import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths ) -import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+), mapFL_FL +import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+) , (:>)(..), reverseRL, reverseFL - , mapFL, concatFL, toFL ) + , mapFL, concatFL, toFL, nullFL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal , freeGap, emptyGap, joinGap, FreeLeft, Gap(..) ) -import Darcs.Patch.Commute ( selfCommuter ) +import Darcs.Patch.Commute ( selfCommuter, commuteFL ) import Darcs.Patch.CommuteFn ( commuterIdRL ) -import Darcs.Patch.Permutations ( partitionConflictingFL, partitionRL ) +import Darcs.Patch.Permutations ( partitionConflictingFL, genCommuteWhatWeCanRL ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) -import Darcs.Patch.Prim.V1 () -- instances Commute Prim and PrimPatch Prim -import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) ) -import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize ) +import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks ) -import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) ) +import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) + , UpdateWorking(..), LookForMoves(..), LookForReplaces(..) ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Repository.InternalTypes ( Repository(..) ) +import Darcs.Repository.InternalTypes ( Repository, repoFormat ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) import qualified Darcs.Repository.Pending as Pending import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) import Darcs.Repository.Diff ( treeDiff ) -import Darcs.Util.Path( AnchoredPath(..), anchorPath, floatPath, Name(..), fn2fp, - SubPath, sp2fn, filterPaths - , parents, replacePrefixPath, anchoredRoot - , toFilePath, simpleSubPath, normPath, floatSubPath ) +import Darcs.Util.Path + ( AnchoredPath(..), anchorPath, floatPath, fn2fp + , SubPath, sp2fn, filterPaths, FileName + , parents, replacePrefixPath, anchoredRoot + , toFilePath, simpleSubPath, normPath, floatSubPath, makeName + ) import Darcs.Util.Hash( Hash( NoHash ) ) import Darcs.Util.Tree( Tree, restrict, FilterTree, expand, emptyTree, overlay, find , ItemType(..), itemType, readBlob, modifyTree, findFile, TreeItem(..) @@ -101,23 +103,26 @@ newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m } --- TODO: We wrap the pending patch inside RepoPatch here, to avoid the --- requirement to propagate an (ApplyState (PrimOf p) ~ ApplyState p) --- constraint everywhere. When we have GHC 7.2 as a minimum requirement, we can --- lift this constraint into RepoPatch superclass context and remove this hack. -readPendingLL :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO (Sealed ((FL p) wT)) -readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` Pending.readPending repo - -- | 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. -restrictSubpaths :: forall rt p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree) +restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m) restrictSubpaths repo subpaths = do - Sealed pending <- readPendingLL repo + Sealed pending <- Pending.readPending repo + restrictSubpathsAfter pending repo subpaths + +-- | Like 'restrictSubpaths' but with the pending patch passed as a parameter. +-- The 'Repository' parameter is not used, we need it only to avoid +-- abiguous typing of @p@. +restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree) + => FL (PrimOf p) wT wP + -> Repository rt p wR wU wT + -> [SubPath] + -> IO (TreeFilter m) +restrictSubpathsAfter pending _repo subpaths = do let paths = map (fn2fp . sp2fn) subpaths paths' = paths `union` effectOnFilePaths pending paths anchored = map floatPath paths' @@ -125,28 +130,26 @@ restrictPaths = Tree.filter (filterPaths anchored) return (TreeFilter restrictPaths) -maybeRestrictSubpaths :: forall rt p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT +maybeRestrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree) + => FL (PrimOf p) wT wP + -> Repository rt p wR wU wT -> Maybe [SubPath] -> IO (TreeFilter m) -maybeRestrictSubpaths repo = maybe (return $ TreeFilter id) (restrictSubpaths repo) +maybeRestrictSubpaths pending repo = + maybe (return $ TreeFilter id) (restrictSubpathsAfter pending repo) -- |Is the given path in (or equal to) the _darcs metadata directory? inDarcsDir :: AnchoredPath -> Bool -inDarcsDir (AnchoredPath (Name x:_)) | x == BC.pack darcsdir = True +inDarcsDir (AnchoredPath (x:_)) | x == makeName darcsdir = True inDarcsDir _ = False --- | 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.) +-- | Construct a 'TreeFilter' that removes any boring files that are not also +-- contained in the argument 'Tree'. -- --- 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. -restrictBoring :: forall m . Tree m -> IO (TreeFilter m) +-- The standard use case is for the argument to be the recorded state, possibly +-- with further patches applied, so as not to discard any files already known +-- to darcs. The result is usually applied to the full working state. +restrictBoring :: Tree m -> IO (TreeFilter m) restrictBoring guide = do boring <- boringRegexps let boring' p | inDarcsDir p = False @@ -160,99 +163,120 @@ -- | Construct a Tree filter that removes any darcs metadata files the -- Tree might have contained. -restrictDarcsdir :: forall m . TreeFilter m +restrictDarcsdir :: TreeFilter m restrictDarcsdir = TreeFilter $ Tree.filter $ \p _ -> not (inDarcsDir p) --- | For a repository and an optional list of paths (when Nothing, 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 list of paths is given, at --- least the files that live under any of these paths in either recorded or --- unrecorded will be included in the resulting patch. NB. More patches may be --- included in this list, eg. the full contents of the pending patch. This is --- usually not a problem, since selectChanges will properly filter the results --- anyway. --- --- 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 :: forall rt p wR wU wT . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository rt p wR wU wT - -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU) -unrecordedChanges = unrecordedChangesWithPatches NilFL NilFL +{- | +For a repository and an optional list of paths (when 'Nothing', 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 list of paths is given, at +least the files that live under any of these paths in either recorded or +unrecorded will be included in the resulting patch. NB. More patches may be +included in this list, eg. the full contents of the pending patch. This is +usually not a problem, since selectChanges will properly filter the results +anyway. -unrecordedChangesWithPatches :: forall rt p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => FL (PrimOf p) wX wT -- look-for-moves patches - -> FL (PrimOf p) wT wT -- look-for-replaces patches - -> (UseIndex, ScanKnown, DiffAlgorithm) -> Repository rt p wR wU wT - -> Maybe [SubPath] - -> IO (FL (PrimOf p) wT wU) -unrecordedChangesWithPatches movPs replPs opts r paths = do - (pending :> working) <- readPendingAndWorkingWithPatches movPs replPs opts r paths - return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movPs +>+ replPs) +>+ working) +This also depends on the options given: --- | Mostly a helper function to 'unrecordedChangesWithPatches', returning the pending --- patch plus `patches` and the subsequent diff from working as two different patches -readPendingAndWorkingWithPatches :: forall rt p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => FL (PrimOf p) wZ wT -- look-for-moves patches - -> FL (PrimOf p) wT wT -- look-for-replaces patches - -> (UseIndex, ScanKnown, DiffAlgorithm) - -> Repository rt p wR wU wT - -> Maybe [SubPath] - -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU) -readPendingAndWorkingWithPatches _ _ _ r@(Repo _ rf _ _) _ | formatHas NoWorkingDir rf = do - IsEq <- return $ workDirLessRepoWitness r - return (NilFL :> NilFL) -readPendingAndWorkingWithPatches movPs replPs (useidx', scan, dflag) repo mbpaths = do - let allPatches = movPs +>+ replPs - let useidx = case allPatches of - NilFL -> useidx' - _ -> IgnoreIndex - (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo - all_current_with_patches <- applyToTree allPatches all_current +--look-for-moves: Detect pending file moves using the index. The resulting + patches are added to pending and taken into consideration, when filtering + the tree according to the given path list. - relevant <- maybeRestrictSubpaths repo mbpaths - let getIndex = applyToTree movPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) - current = applyTreeFilter relevant all_current_with_patches +--look-for-adds: Include files in the working state that do not exist in the + recorded + pending state. - working <- filteredWorking useidx scan relevant getIndex current - ft <- filetypeFunction - Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX)) - IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU) - return (effect pending :> diff) +--include-boring: Include even boring files. -readPendingAndWorking :: forall rt p wR wU wT . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +--look-for-replaces: Detect pending replace patches. Like detected moves, + these are added to the pending patch. Note that, like detected moves, + these are mere proposals for the user to consider or reject. + +--ignore-times: 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). + + Note that use of the index is also disabled when we detect moves or + replaces, since this implies that the index is out of date. +-} +unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree) + => (UseIndex, ScanKnown, DiffAlgorithm) + -> LookForMoves + -> LookForReplaces + -> Repository rt p wR wU wT + -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU) +unrecordedChanges dopts lfm lfr r paths = do + (pending :> working) <- readPendingAndWorking dopts lfm lfr r paths + return $ sortCoalesceFL (pending +>+ working) + +-- Implementation note: it is important to do things in the right order: we +-- first have to read the pending patch, then detect moves, then detect adds, +-- then detect replaces. +readPendingAndWorking :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) + -> LookForMoves + -> LookForReplaces -> Repository rt p wR wU wT -> Maybe [SubPath] -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU) -readPendingAndWorking = readPendingAndWorkingWithPatches NilFL NilFL +readPendingAndWorking _ _ _ r _ | formatHas NoWorkingDir (repoFormat r) = do + IsEq <- return $ workDirLessRepoWitness r + return (NilFL :> NilFL) +readPendingAndWorking (useidx, scan, diffalg) lfm lfr repo mbpaths = do + (pending_tree, working_tree, pending) <- + readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths + (pending_tree_with_replaces, Sealed replaces) <- + getReplaces lfr diffalg repo pending_tree working_tree + ft <- filetypeFunction + wrapped_diff <- treeDiff diffalg ft pending_tree_with_replaces working_tree + case unFreeLeft wrapped_diff of + Sealed diff -> do + return (pending +>+ unsafeCoercePEnd replaces :> unsafeCoercePEnd diff) --- | @filteredWorking useidx scan relevant getIndex pending_tree@ reads the +readPendingAndMovesAndUnrecorded + :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> UseIndex + -> ScanKnown + -> LookForMoves + -> Maybe [SubPath] + -> IO ( Tree IO -- pristine with (pending + moves) + , Tree IO -- working + , FL (PrimOf p) wT wU -- pending + moves + ) +readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths = do + (pending_tree, Sealed pending) <- readPending repo + moves <- getMoves lfm repo mbpaths + let pending' = pending +>+ moves + relevant <- maybeRestrictSubpaths pending' repo mbpaths + pending_tree' <- + applyTreeFilter relevant <$> applyToTree moves pending_tree + let useidx' = if nullFL moves then useidx else IgnoreIndex + index <- + applyToTree moves =<< I.updateIndex =<< + applyTreeFilter relevant <$> readIndex repo + working_tree <- filteredWorking useidx' scan relevant index pending_tree' + return (pending_tree', working_tree, unsafeCoercePEnd pending') + +-- | @filteredWorking useidx scan relevant index pending_tree@ reads the -- working tree and filters it according to options and @relevant@ file paths. -- The @pending_tree@ is understood to have @relevant@ already applied and is -- used (only) if @useidx == 'IgnoreIndex'@ and @scan == 'ScanKnown'@ to act as -- a guide for filtering the working tree. - --- TODO: untangle the arguments and make this more orthogonal +-- Note that even if @useidx '==' 'IgnoreIndex'@, the index is still used +-- to avoid filtering boring files that darcs knows about (see 'restrictBoring'). filteredWorking :: UseIndex - -> ScanKnown - -> TreeFilter IO - -> IO (Tree IO) - -> Tree IO - -> IO (Tree IO) -filteredWorking useidx scan relevant getIndex pending_tree = do - index <- getIndex + -> ScanKnown + -> TreeFilter IO + -> Tree IO + -> Tree IO + -> IO (Tree IO) +filteredWorking useidx scan relevant index pending_tree = do applyTreeFilter restrictDarcsdir <$> case scan of ScanKnown -> case useidx of - UseIndex -> getIndex + UseIndex -> return index IgnoreIndex -> do guide <- expand pending_tree applyTreeFilter relevant . restrict guide <$> readPlainTree "." @@ -271,14 +295,14 @@ -- | Witnesses the fact that in the absence of a working directory, we -- pretend that the working dir updates magically to the tentative state. workDirLessRepoWitness :: Repository rt p wR wU wT -> EqCheck wU wT -workDirLessRepoWitness (Repo _ rf _ _) - | formatHas NoWorkingDir rf = unsafeCoerceP IsEq - | otherwise = NotEq +workDirLessRepoWitness r + | formatHas NoWorkingDir (repoFormat r) = unsafeCoerceP IsEq + | otherwise = NotEq -- | 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. -readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO (Tree IO) +readRecorded :: Repository rt p wR wU wT -> IO (Tree IO) readRecorded _repo = do let h_inventory = darcsdir "hashed_inventory" hashed <- doesFileExist h_inventory @@ -290,7 +314,8 @@ (pris_line:_) -> do let hash = decodeDarcsHash $ B.drop 9 pris_line size = decodeDarcsSize $ B.drop 9 pris_line - when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line + when (hash == NoHash) $ + fail $ "Bad pristine root: " ++ show pris_line readDarcsHashed (darcsdir "pristine.hashed") (size, hash) else do have_pristine <- doesDirectoryExist $ darcsdir "pristine" have_current <- doesDirectoryExist $ darcsdir "current" @@ -309,7 +334,8 @@ readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO) readUnrecorded repo mbpaths = do - relevant <- maybeRestrictSubpaths repo mbpaths + Sealed pending <- Pending.readPending repo + relevant <- maybeRestrictSubpaths pending repo mbpaths readIndex repo >>= I.updateIndex . applyTreeFilter relevant -- | A variant of 'readUnrecorded' that takes the UseIndex and ScanKnown @@ -320,28 +346,25 @@ => Repository rt p wR wU wT -> UseIndex -> ScanKnown + -> LookForMoves -> Maybe [SubPath] -> IO (Tree IO) -readUnrecordedFiltered repo useidx scan mbpaths = do - (all_current, _) <- readPending repo -- we have no need for the pending patch - relevant <- maybeRestrictSubpaths repo mbpaths - let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) - current = applyTreeFilter relevant all_current - filteredWorking useidx scan relevant getIndex current +readUnrecordedFiltered repo useidx scan lfm mbpaths = do + (_, working_tree, _) <- + readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths + return working_tree -- | Obtains a Tree corresponding to the complete working copy of the -- repository (modified and non-modified files). readWorking :: IO (Tree IO) -readWorking = expand =<< (nodarcs `fmap` readPlainTree ".") - where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir) +readWorking = expand =<< (applyTreeFilter restrictDarcsdir <$> readPlainTree ".") --- | Obtains the same Tree as 'readRecorded' would but with the additional side --- effect of reading/checking the pending patch. +-- | Obtains the recorded 'Tree' with the pending patch applied. readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO (Tree IO) readRecordedAndPending repo = fst `fmap` readPending repo --- | Obtains a Tree corresponding to the recorded state of the repository --- and a pending patch to go with it. The pending patch should start at the +-- | Obtains the recorded 'Tree' with the pending patch applied, plus +-- the pending patch itself. The pending patch should start at the -- recorded state (we even verify that it applies, and degrade to -- renaming pending and starting afresh if it doesn't), but we've set to -- say it starts at the tentative state. @@ -349,84 +372,99 @@ -- Question (Eric Kow) Is this a bug? Darcs.Repository.Pending.readPending -- says it is readPending :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL p wT)) -readPending repo = - do Sealed pending <- readPendingLL repo - pristine <- readRecorded repo - catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ (err :: IOException) -> do + => Repository rt p wR wU wT + -> IO (Tree IO, Sealed (FL (PrimOf p) wT)) +readPending repo = do + pristine <- readRecorded repo + Sealed pending <- Pending.readPending repo + catch ((\t -> (t, seal pending)) <$> applyToTree pending pristine) $ + \(err :: IOException) -> do putStrLn $ "Yikes, pending has conflicts! " ++ show err putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy" renameFile (darcsdir "patches" "pending") (darcsdir "patches" "pending_buggy") return (pristine, seal NilFL) +index_file, index_invalid :: FilePath +index_file = darcsdir "index" +index_invalid = darcsdir "index_invalid" + -- | 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 _ = B.writeFile (darcsdir "index_invalid") B.empty +invalidateIndex _ = B.writeFile index_invalid B.empty -readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO I.Index +readIndex :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO I.Index readIndex repo = do - invalid <- doesFileExist $ darcsdir "index_invalid" - exists <- doesFileExist $ darcsdir "index" - formatValid <- if exists - then I.indexFormatValid $ darcsdir "index" - else return True - when (exists && not formatValid) $ removeFile $ darcsdir "index" + (invalid, exists, formatValid) <- checkIndex if not exists || invalid || not formatValid then do pris <- readRecordedAndPending repo - idx <- I.updateIndexFrom (darcsdir "index") darcsTreeHash pris - when invalid $ removeFile $ darcsdir "index_invalid" + idx <- I.updateIndexFrom index_file darcsTreeHash pris + when invalid $ removeFile index_invalid return idx - else I.readIndex (darcsdir "index") darcsTreeHash + else I.readIndex index_file darcsTreeHash -updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO () +updateIndex :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () updateIndex repo = do - invalid <- doesFileExist $ darcsdir "index_invalid" - exists <- doesFileExist $ darcsdir "index" - formatValid <- if exists - then I.indexFormatValid $ darcsdir "index" + (invalid, _, _) <- checkIndex + pris <- readRecordedAndPending repo + _ <- I.updateIndexFrom index_file darcsTreeHash pris + when invalid $ removeFile index_invalid + +checkIndex :: IO (Bool, Bool, Bool) +checkIndex = do + invalid <- doesFileExist $ index_invalid + exists <- doesFileExist index_file + formatValid <- if exists + then I.indexFormatValid index_file else return True - when (exists && not formatValid) $ removeFile $ darcsdir "index" - pris <- readRecordedAndPending repo - _ <- I.updateIndexFrom (darcsdir "index") darcsTreeHash pris - when invalid $ removeFile $ darcsdir "index_invalid" + when (exists && not formatValid) $ removeFile index_file + return (invalid, exists, formatValid) -- |Remove any patches (+dependencies) from a sequence that -- conflict with the recorded or unrecorded changes in a repo -filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => RL (PatchInfoAnd rt p) wX wT -- ^Recorded patches from repository, starting from - -- same context as the patches to filter - -> Repository rt p wR wU wT -- ^Repository itself, used for grabbing unrecorded changes - -> FL (PatchInfoAnd rt p) wX wZ -- ^Patches to filter - -> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX)) -- ^(True iff any patches were removed, possibly filtered patches) +filterOutConflicts + :: (RepoPatch p, ApplyState p ~ Tree) + => RL (PatchInfoAnd rt p) wX wT -- ^Recorded patches from repository, starting from + -- same context as the patches to filter + -> Repository rt p wR wU wT -- ^Repository itself, used for grabbing + -- unrecorded changes + -> FL (PatchInfoAnd rt p) wX wZ -- ^Patches to filter + -> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX)) + -- ^True iff any patches were removed, + -- possibly filtered patches filterOutConflicts us repository them = do let commuter = commuterIdRL selfCommuter unrec <- fmap n2pia . anonymous . fromPrims - =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository Nothing + =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) + NoLookForMoves NoLookForReplaces repository Nothing them' :> rest <- return $ partitionConflictingFL commuter them (us :<: unrec) return (check rest, Sealed them') where check :: FL p wA wB -> Bool check NilFL = False check _ = True --- |Automatically detect file moves using the index -getMovesPs :: forall rt p wR wU wB prim. - (PrimConstruct prim, PrimCanonize prim, RepoPatch p, - ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository rt p wR wU wR - -> Maybe [SubPath] - -> IO (FL prim wB wB) -getMovesPs repository files = mkMovesFL <$> getMovedFiles repository files +-- | Automatically detect file moves using the index. +-- TODO: This function lies about the witnesses. +getMoves :: forall rt p wR wU wT wB prim. + (RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p) + => LookForMoves + -> Repository rt p wR wU wT + -> Maybe [SubPath] + -> IO (FL prim wB wB) +getMoves NoLookForMoves _ _ = return NilFL +getMoves YesLookForMoves repository files = + mkMovesFL <$> getMovedFiles repository files where mkMovesFL [] = NilFL mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs - getMovedFiles :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository rt p wR wU wR + getMovedFiles :: Repository rt p wR wU wT -> Maybe [SubPath] -> IO [(AnchoredPath, AnchoredPath, ItemType)] getMovedFiles repo fs = do @@ -439,19 +477,23 @@ new <- sortBy (comparing snd) <$> (addIDs . map (\(a,b) -> (a, itemType b)) . Tree.list =<< expand =<< applyTreeFilter nonboring <$> readPlainTree ".") - let match (x:xs) (y:ys) | snd x > snd y = match (x:xs) ys - | snd x < snd y = match xs (y:ys) - | snd (fst x) /= snd (fst y) = match xs ys - | otherwise = (fst (fst x), fst (fst y), snd (fst x)):match xs ys + let match (x:xs) (y:ys) + | snd x > snd y = match (x:xs) ys + | snd x < snd y = match xs (y:ys) + | snd (fst x) /= snd (fst y) = match xs ys + | otherwise = (fst (fst x), fst (fst y), snd (fst x)):match xs ys match _ _ = [] movedfiles = match old new - fmovedfiles = case fs of - Nothing -> movedfiles - Just subpath -> filter (\(f1,f2,_) -> any (`elem` selfiles) [f1,f2]) movedfiles - where selfiles = map (floatPath . toFilePath) subpath + fmovedfiles = + case fs of + Nothing -> movedfiles + Just subpath -> + filter (\(f1, f2, _) -> any (`elem` selfiles) [f1, f2]) movedfiles + where selfiles = map (floatPath . toFilePath) subpath return (resolve fmovedfiles) - resolve :: [(AnchoredPath, AnchoredPath, ItemType)] -> [(AnchoredPath, AnchoredPath, ItemType)] + resolve :: [(AnchoredPath, AnchoredPath, ItemType)] + -> [(AnchoredPath, AnchoredPath, ItemType)] resolve xs = fixPaths $ sortMoves $ deleteCycles xs where -- Input relation is left-and-right-unique. Makes cycle detection easier. @@ -495,66 +537,120 @@ -- | Search for possible replaces between the recordedAndPending state -- and the unrecorded (or working) state. Return a Sealed FL list of -- replace patches to be applied to the recordedAndPending state. -getReplaces :: forall rt p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, - ApplyState (PrimOf p) ~ Tree, wX ~ wR) - => (UseIndex, ScanKnown, DiffAlgorithm) - -> Repository rt p wR wU wT - -> Maybe [SubPath] - -> IO (Sealed (FL (PrimOf p) wX)) -getReplaces (useindex, scan, dopts) repo files = do - relevant <- maybeRestrictSubpaths repo files - working <- readUnrecordedFiltered repo useindex scan files - pending <- applyTreeFilter relevant <$> readRecordedAndPending repo +getReplaces :: forall rt p wR wU wT + . (RepoPatch p, ApplyState p ~ Tree) + => LookForReplaces + -> DiffAlgorithm + -> Repository rt p wR wU wT + -> Tree IO -- ^ pending tree (including possibly detected moves) + -> Tree IO -- ^ working tree + -> IO (Tree IO, -- new pending tree + Sealed (FL (PrimOf p) wU)) +getReplaces NoLookForReplaces _ _ pending _ = return (pending, Sealed NilFL) +getReplaces YesLookForReplaces diffalg _repo pending working = do ftf <- filetypeFunction - - Sealed changes <- unFreeLeft <$> treeDiff dopts ftf pending working - _ :> hunks <- return $ partitionRL primIsHunk $ reverseFL changes - let allModifiedTokens = concat $ mapFL modifiedTokens (reverseRL hunks) + Sealed changes <- unFreeLeft <$> treeDiff diffalg ftf pending working + let allModifiedTokens = concat $ mapFL modifiedTokens changes replaces = rmInvalidReplaces allModifiedTokens - mapSeal concatFL . toFL <$> - mapM (\(f,a,b) -> doReplace defaultToks pending - (fromJust $ simpleSubPath $ fn2fp $ normPath f) - (BC.unpack a) (BC.unpack b)) replaces - where -- get individual tokens that have been modified - modifiedTokens (FP f (Hunk _ old new)) = -- old and new are list of lines (= 1 bytestring per line) - map (\(a,b) -> (f, a, b)) (concatMap checkModified $ - filter (\(a,b) -> length a == length b) -- only keep lines with same number of tokens - $ zip (map breakToTokens old) (map breakToTokens new)) - modifiedTokens _ = error "modifiedTokens: Not Hunk patch" + (patches, new_pending) <- + flip runStateT pending $ + forM replaces $ \(f,a,b) -> + doReplace defaultToks + (fromJust $ simpleSubPath $ fn2fp $ normPath f) + (BC.unpack a) (BC.unpack b) + return (new_pending, mapSeal concatFL $ toFL patches) + where + modifiedTokens :: PrimOf p wX wY -> [(FileName, B.ByteString, B.ByteString)] + modifiedTokens p = case isHunk p of + Just (FileHunk f _ old new) -> + map (\(a,b) -> (f, a, b)) (concatMap checkModified $ + filter (\(a,b) -> length a == length b) -- only keep lines with same number of tokens + $ zip (map breakToTokens old) (map breakToTokens new)) + Nothing -> [] - -- from a pair of token lists, create a pair of modified token lists - checkModified = filter (\(a,b) -> a/=b) . uncurry zip + -- from a pair of token lists, create a pair of modified token lists + checkModified = filter (\(a,b) -> a/=b) . uncurry zip - rmInvalidReplaces [] = [] - rmInvalidReplaces ((f,old,new):rs) - | any (\(f',a,b) -> f' == f && old == a && b /= new) rs = -- inconsistency detected - rmInvalidReplaces $ filter (\(f'',a',_) -> f'' /= f || a' /= old) rs - rmInvalidReplaces (r:rs) = r:rmInvalidReplaces (filter (/=r) rs) + rmInvalidReplaces [] = [] + rmInvalidReplaces ((f,old,new):rs) + | any (\(f',a,b) -> f' == f && old == a && b /= new) rs = + -- inconsistency detected + rmInvalidReplaces $ filter (\(f'',a',_) -> f'' /= f || a' /= old) rs + rmInvalidReplaces (r:rs) = r:rmInvalidReplaces (filter (/=r) rs) - doReplace toks pend f old new = do - let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p - pendReplaced <- maybeReplace pend - if pendReplaced - then return $ joinGap (:>:) (freeGap replacePatch) (emptyGap NilFL) - else getForceReplace f toks pend old new - where - replacePatch = tokreplace (toFilePath f) toks old new + doReplace toks f old new = do + pend <- get + mpend' <- liftIO $ maybeApplyToTree replacePatch pend + case mpend' of + Nothing -> getForceReplace f toks old new + Just pend' -> do + put pend' + return $ joinGap (:>:) (freeGap replacePatch) (emptyGap NilFL) + where + replacePatch = tokreplace (toFilePath f) toks old new - getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO -> String -> String - -> IO (FreeLeft (FL prim)) - getForceReplace f toks tree old new = do - let path = floatSubPath f - -- It would be nice if we could fuse the two traversals here, that is, - -- expandPath and findFile. OTOH it is debatable whether adding a new - -- effectful version of findFile to Darcs.Util.Tree is justified. - expandedTree <- expandPath tree path - content <- case findFile expandedTree path of - Just blob -> readBlob blob - Nothing -> error $ "getForceReplace: not in tree: " ++ show path - let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old) - (B.concat $ BL.toChunks content) - tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent - ftf <- filetypeFunction - normaliseNewTokPatch <- treeDiff dopts ftf expandedTree tree' - return . joinGap (+>+) normaliseNewTokPatch $ freeGap $ - tokreplace (toFilePath f) toks old new :>: NilFL + getForceReplace :: (PrimPatch prim, ApplyState prim ~ Tree) + => SubPath -> String -> String -> String + -> StateT (Tree IO) IO (FreeLeft (FL prim)) + getForceReplace f toks old new = do + let path = floatSubPath f + -- the tree here is the "current" pending state + tree <- get + -- It would be nice if we could fuse the two traversals here, that is, + -- expandPath and findFile. OTOH it is debatable whether adding a new + -- effectful version of findFile to Darcs.Util.Tree is justified. + expandedTree <- liftIO $ expandPath tree path + content <- case findFile expandedTree path of + Just blob -> liftIO $ readBlob blob + Nothing -> bug $ "getForceReplace: not in tree: " ++ show path + let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old) + (B.concat $ BL.toChunks content) + tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent + ftf <- liftIO $ filetypeFunction + normaliseNewTokPatch <- liftIO $ treeDiff diffalg ftf expandedTree tree' + -- make sure we can apply them to the pending state + patches <- return $ joinGap (+>+) normaliseNewTokPatch $ freeGap $ + tokreplace (toFilePath f) toks old new :>: NilFL + mtree'' <- case unFreeLeft patches of + Sealed ps -> liftIO $ maybeApplyToTree ps tree + case mtree'' of + Nothing -> bug "getForceReplace: unable to apply detected force replaces" + Just tree'' -> do + put tree'' + return patches + + +-- | Add an 'FL' of patches started from the pending state to the pending patch. +-- TODO: add witnesses for pending so we can make the types precise: currently +-- the passed patch can be applied in any context, not just after pending. +addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> UpdateWorking + -> FreeLeft (FL (PrimOf p)) -> IO () +addPendingDiffToPending _ NoUpdateWorking _ = return () +addPendingDiffToPending repo uw@YesUpdateWorking newP = do + (toPend :> _) <- + readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) + NoLookForMoves NoLookForReplaces repo Nothing + invalidateIndex repo + case unFreeLeft newP of + (Sealed p) -> do recordedState <- readRecorded repo + Pending.makeNewPending repo uw (toPend +>+ p) recordedState + +-- | Add an 'FL' of patches starting from the working state to the pending patch, +-- including as much extra context as is necessary (context meaning +-- dependencies), by commuting the patches to be added past as much of the +-- changes between pending and working as is possible, and including anything +-- that doesn't commute, and the patch itself in the new pending patch. +addToPending :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> UpdateWorking + -> FL (PrimOf p) wU wY -> IO () +addToPending _ NoUpdateWorking _ = return () +addToPending repo uw@YesUpdateWorking p = do + (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) + NoLookForMoves NoLookForReplaces repo Nothing + invalidateIndex repo + case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of + (toP' :> p' :> _excessUnrec) -> do + recordedState <- readRecorded repo + Pending.makeNewPending repo uw + (toPend +>+ reverseRL toP' +>+ p') recordedState diff --git a/src/Darcs/Repository/Test.hs b/src/Darcs/Repository/Test.hs --- a/src/Darcs/Repository/Test.hs +++ b/src/Darcs/Repository/Test.hs @@ -35,30 +35,24 @@ import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Prompt ( askUser ) import Darcs.Repository.Prefs ( getPrefval ) -import Darcs.Patch - ( RepoPatch ) -import Darcs.Repository.Internal - ( setScriptsExecutable - , withTentative - ) +import Darcs.Repository.Hashed ( withTentative ) +import Darcs.Repository.Working ( setScriptsExecutable ) import Darcs.Repository.Flags ( LeaveTestDir(..) , Verbosity(..) , SetScriptsExecutable(..) , RunTest (..) + , HookConfig (..) ) import Darcs.Repository.InternalTypes - ( Repository(..) ) + ( Repository, repoLocation ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Lock ( withTempDir , withPermDir ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Util.Tree ( Tree ) - getTest :: Verbosity -> IO (IO ExitCode) getTest verb = let putInfo s = when (verb /= Quiet) $ putStr s @@ -71,8 +65,8 @@ putInfo "Running test...\n" runTest testcode putInfo -runPosthook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode -runPosthook mPostHook askPostHook verb repodir +runPosthook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode +runPosthook (HookConfig mPostHook askPostHook) verb repodir = do ph <- getPosthook mPostHook askPostHook withCurrentDirectory repodir $ runHook verb "Posthook" ph @@ -91,8 +85,8 @@ _ -> putStrLn "Posthook cancelled..." >> return Nothing else return $ Just command -runPrehook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode -runPrehook mPreHookCmd askPreHook verb repodir = +runPrehook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode +runPrehook (HookConfig mPreHookCmd askPreHook) verb repodir = do ph <- getPrehook mPreHookCmd askPreHook withCurrentDirectory repodir $ runHook verb "Prehook" ph @@ -121,8 +115,7 @@ else hPutStrLn stderr $ cname++" failed!" return ec -testTentative :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT +testTentative :: Repository rt p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable @@ -139,8 +132,7 @@ return ec -testAny :: RepoPatch p - => (Repository rt p wR wU wT +testAny :: (Repository rt p wR wU wT -> ((AbsolutePath -> IO ExitCode) -> IO ExitCode) -> (AbsolutePath -> IO ExitCode) -> IO ExitCode ) @@ -150,10 +142,12 @@ -> SetScriptsExecutable -> Verbosity -> IO ExitCode -testAny withD repository@(Repo dir _ _ _) doRunTest ltd sse verb = +testAny withD repository doRunTest ltd sse verb = debugMessage "Considering whether to test..." >> - if doRunTest == NoRunTest then return ExitSuccess else withCurrentDirectory dir $ - do let putInfo = if verb == Quiet then const (return ()) else putStrLn + if doRunTest == NoRunTest + then return ExitSuccess + else withCurrentDirectory (repoLocation repository) $ do + let putInfo = if verb == Quiet then const (return ()) else putStrLn debugMessage "About to run test if it exists." testline <- getPrefval "test" case testline of diff --git a/src/Darcs/Repository/Working.hs b/src/Darcs/Repository/Working.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Working.hs @@ -0,0 +1,75 @@ +module Darcs.Repository.Working + ( applyToWorking + , setScriptsExecutable + , setScriptsExecutablePatches + ) where + +import Control.Monad ( when, unless, filterM ) +import System.Directory ( doesFileExist ) + +import qualified Data.ByteString as B ( readFile + , isPrefixOf + ) +import qualified Data.ByteString.Char8 as BC (pack) + +import Darcs.Util.File ( withCurrentDirectory ) +import Darcs.Util.Progress ( debugMessage ) +import Darcs.Util.Workaround ( setExecutable ) +import Darcs.Util.Tree ( Tree ) +import Darcs.Util.Path ( anchorPath ) +import qualified Darcs.Util.Tree as Tree + +import Darcs.Patch ( RepoPatch, apply, listTouchedFiles ) +import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Patch.Prim ( PrimOf ) +import Darcs.Patch.Witnesses.Ordered + ( FL(..) ) +import Darcs.Patch.Dummy ( DummyPatch ) +import Darcs.Patch.Inspect ( PatchInspect ) + +import Darcs.Repository.Format ( RepoProperty( NoWorkingDir ), formatHas ) +import Darcs.Repository.Flags ( Verbosity(..) ) +import Darcs.Repository.InternalTypes + ( Repository + , repoFormat + , repoLocation + , coerceU ) +import Darcs.Repository.ApplyPatches ( runTolerantly, runSilently ) +import Darcs.Repository.State ( readWorking ) + +applyToWorking :: (ApplyState p ~ Tree, RepoPatch p) + => Repository rt p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY + -> IO (Repository rt p wR wY wT) +applyToWorking repo verb patch = + do + unless (formatHas NoWorkingDir (repoFormat repo)) $ + withCurrentDirectory (repoLocation repo) $ + if verb == Quiet + then runSilently $ apply patch + else runTolerantly $ apply patch + return $ coerceU repo + +-- | Sets scripts in or below the current directory executable. +-- A script is any file that starts with the bytes '#!'. +-- This is used for --set-scripts-executable. +setScriptsExecutable_ :: PatchInspect p => Maybe (p wX wY) -> IO () +setScriptsExecutable_ pw = do + debugMessage "Making scripts executable" + tree <- readWorking + paths <- case pw of + Just ps -> filterM doesFileExist $ listTouchedFiles ps + Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ] + let setExecutableIfScript f = + do contents <- B.readFile f + when (BC.pack "#!" `B.isPrefixOf` contents) $ do + debugMessage ("Making executable: " ++ f) + setExecutable f True + mapM_ setExecutableIfScript paths + +setScriptsExecutable :: IO () +setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch wX wY)) + +setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO () +setScriptsExecutablePatches = setScriptsExecutable_ . Just + + diff --git a/src/Darcs/UI/ApplyPatches.hs b/src/Darcs/UI/ApplyPatches.hs --- a/src/Darcs/UI/ApplyPatches.hs +++ b/src/Darcs/UI/ApplyPatches.hs @@ -11,22 +11,24 @@ import Control.Exception ( catch, fromException, SomeException, throwIO ) import Control.Monad ( when, unless ) +import qualified Data.ByteString.Char8 as BC import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.UI.Commands ( putVerbose , putInfo - , printDryRunMessageAndExit , setEnvDarcsPatches ) +import Darcs.UI.Commands.Util ( printDryRunMessageAndExit ) import Darcs.UI.CommandsAux ( checkPaths ) import Darcs.UI.Flags - ( DarcsFlag, verbosity, compression, reorder, allowConflicts, externalMerge + ( DarcsFlag, verbosity, compress, reorder, allowConflicts, externalMerge , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges - , hasXmlOutput, getReply, getCc, getSendmailCmd, hasSummary, dryRun + , xmlOutput, reply, getCc, getSendmailCmd, dryRun ) import qualified Darcs.UI.Options.All as O +import Darcs.UI.Options ( (?) ) import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit ) import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Repository @@ -38,7 +40,7 @@ , setScriptsExecutablePatches ) import Darcs.Repository.Job ( RepoJob(RepoJob) ) -import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description, PrimOf ) +import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL, nullFL ) @@ -63,7 +65,7 @@ -> [DarcsFlag] -> (forall rt p wR wU . ( IsRepoType rt, ApplierRepoTypeConstraint pa rt - , RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree + , RepoPatch p, ApplyState p ~ Tree ) => (PatchProxy p -> Repository rt p wR wU wR -> IO ())) -> RepoJob () @@ -71,7 +73,7 @@ applyPatches :: forall rt p wR wU wT wX wZ . ( ApplierRepoTypeConstraint pa rt, IsRepoType rt - , RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree + , RepoPatch p, ApplyState p ~ Tree ) => pa -> PatchProxy p @@ -91,18 +93,18 @@ standardApplyPatches :: forall rt p wR wU wT wX wZ - . (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => String -> [DarcsFlag] -> String -> Repository rt p wR wU wT -> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wZ -> IO () standardApplyPatches cmdName opts from_whom repository us' to_be_applied = do printDryRunMessageAndExit cmdName - (verbosity opts) - (hasSummary O.NoSummary opts) - (dryRun opts) - (hasXmlOutput opts) + (verbosity ? opts) + (O.summary ? opts) + (dryRun ? opts) + (xmlOutput ? opts) (isInteractive True opts) to_be_applied - when (nullFL to_be_applied && reorder opts == O.NoReorder) $ do + when (nullFL to_be_applied && reorder ? opts == O.NoReorder) $ do putStrLn $ "You don't want to " ++ cmdName ++ " any patches, so I'm exiting!" exitSuccess checkPaths opts to_be_applied @@ -113,30 +115,30 @@ setEnvDarcsPatches to_be_applied Sealed pw <- tentativelyMergePatches repository cmdName (allowConflicts opts) YesUpdateWorking - (externalMerge opts) (wantGuiPause opts) - (compression opts) (verbosity opts) - (reorder opts) (diffingOpts opts) + (externalMerge ? opts) (wantGuiPause opts) + (compress ? opts) (verbosity ? opts) + (reorder ? opts) (diffingOpts opts) us' to_be_applied invalidateIndex repository testTentativeAndMaybeExit repository - (verbosity opts) - (testChanges opts) - (setScriptsExecutable opts) + (verbosity ? opts) + (testChanges ? opts) + (setScriptsExecutable ? opts) (isInteractive True opts) "those patches do not pass the tests." (cmdName ++ " them") Nothing - withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts) - _ <- applyToWorking repository (verbosity opts) pw `catch` \(e :: SomeException) -> + withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts) + _ <- applyToWorking repository (verbosity ? opts) pw `catch` \(e :: SomeException) -> fail ("Error applying patch to working dir:\n" ++ show e) - when (setScriptsExecutable opts == O.YesSetScriptsExecutable) $ + when (setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $ setScriptsExecutablePatches pw return () - case (nullFL to_be_applied, reorder opts == O.Reorder) of + case (nullFL to_be_applied, reorder ? opts == O.Reorder) of (True,True) -> putInfo opts $ text $ "Nothing to " ++ cmdName ++ ", finished reordering." (False,True) -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing and reordering." _ -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing." redirectOutput :: [DarcsFlag] -> String -> IO () -> IO () -redirectOutput opts to doit = case getReply opts of +redirectOutput opts to doit = case reply ? opts of Nothing -> doit Just from -> withStdoutTemp $ \tempf -> doitAndCleanup `catch` sendit tempf from where @@ -171,7 +173,7 @@ -- an email. sanitizeFile :: FilePath -> IO String -sanitizeFile f = sanitize `fmap` readBinFile f +sanitizeFile f = sanitize . BC.unpack <$> readBinFile f where sanitize s = wash $ remove_backspaces "" s wash ('\000':s) = "\\NUL" ++ wash s wash ('\026':s) = "\\EOF" ++ wash s diff --git a/src/Darcs/UI/Commands.hs b/src/Darcs/UI/Commands.hs --- a/src/Darcs/UI/Commands.hs +++ b/src/Darcs/UI/Commands.hs @@ -15,12 +15,13 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands ( CommandControl ( CommandData, HiddenCommand, GroupName ) , DarcsCommand ( .. ) , WrappedCommand(..) , wrappedCommandName + , wrappedCommandDescription , commandAlias , commandStub , commandOptions @@ -28,12 +29,7 @@ , withStdOpts , disambiguateCommands , CommandArgs(..) - , getCommandHelp - , getCommandMiniHelp , getSubcommands - , usage - , usageHelper - , subusage , extractCommands , extractAllCommands , normalCommand @@ -46,7 +42,6 @@ , putWarning , putVerboseWarning , abortRun - , printDryRunMessageAndExit , setEnvDarcsPatches , setEnvDarcsFiles , defaultRepo @@ -62,50 +57,41 @@ import Prelude hiding ( (^) ) import Control.Monad ( when, unless ) import Data.List ( sort, isPrefixOf ) -import Data.Maybe ( catMaybes ) import Darcs.Util.Tree ( Tree ) import System.Console.GetOpt ( OptDescr ) -import System.Exit ( exitSuccess ) import System.IO ( stderr ) -#ifndef WIN32 -import System.Posix.Env ( setEnv ) - +import System.IO.Error ( catchIOError ) +import System.Environment ( setEnv ) import Darcs.Patch ( listTouchedFiles ) import qualified Darcs.Patch ( summary ) -#endif -import Darcs.Patch ( RepoPatch, xmlSummary, Patchy ) +import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( toXml ) import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository , amNotInRepository, findRepository ) import Darcs.Repository.Prefs ( defaultrepo ) -import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags ) +import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags, (?) ) import Darcs.UI.Options.All - ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, hooks - , Verbosity(..), verbosity, Summary(..), DryRun(..), dryRun, XmlOutput(..) ) + ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, HooksConfig, hooks + , Verbosity(..), DryRun(..), dryRun + ) -import Darcs.UI.Flags ( remoteRepos, workRepo, DarcsFlag ) -import Darcs.UI.PrintPatch ( showFriendly ) -import Darcs.UI.Usage ( usageInfo ) +import Darcs.UI.Flags ( DarcsFlag, remoteRepos, workRepo, quiet, verbose ) +import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8 ) import Darcs.Util.Path ( AbsolutePath ) -import Darcs.Util.Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc - , vsep, insertBeforeLastline, prefix, ($$), vcat -#ifndef WIN32 - , renderString -#endif - , RenderMode(..) - ) -#ifndef WIN32 -import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize - , finishedOneIO ) -#endif -import Darcs.Util.Text ( chompTrailingNewline ) +import Darcs.Util.Printer + ( Doc, text, (<+>), ($$), vcat + , putDocLnWith, hPutDocLn, errorDoc, renderString + ) +import Darcs.Util.Printer.Color ( fancyPrinters ) +import Darcs.Util.Progress + ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) extractCommands :: [CommandControl] -> [WrappedCommand] extractCommands ccl = [ cmd | CommandData cmd <- ccl ] @@ -158,7 +144,8 @@ (AbsolutePath, AbsolutePath) -> parsedFlags -> [String] -> IO () , commandPrereq :: [DarcsFlag] -> IO (Either String ()) - , commandGetArgPossibilities :: IO [String] + , commandCompleteArgs :: (AbsolutePath, AbsolutePath) + -> [DarcsFlag] -> [String] -> IO [String] , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] , commandBasicOptions :: [DarcsOptDescr DarcsFlag] @@ -177,7 +164,7 @@ } withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c - -> DarcsOption (UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) b + -> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c withStdOpts basicOpts advancedOpts = basicOpts ^ stdCmdActions ^ anyVerbosity ^ advancedOpts ^ useCache ^ hooks @@ -199,7 +186,7 @@ nodefaults _ _ = return getSubcommands :: DarcsCommand pf -> [CommandControl] -getSubcommands c@(SuperCommand {}) = commandSubCommands c +getSubcommands c@(SuperCommand {}) = commandGroup "Subcommands:" : commandSubCommands c getSubcommands _ = [] commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf @@ -222,120 +209,10 @@ , commandCommand = \_ _ _ -> putStr h } -usage :: [CommandControl] -> String -usage cs = unlines - [ "Usage: darcs COMMAND ..." - , "" - , "Commands:" - , usageHelper cs - , "Use 'darcs COMMAND --help' for help on a single command." - , "Use 'darcs --version' to see the darcs version number." - , "Use 'darcs --exact-version' to see a detailed darcs version." - , "Use 'darcs help patterns' for help on patch matching." - , "Use 'darcs help environment' for help on environment variables." - , "Use 'darcs help manpage' to display help in the manpage format." - , "Use 'darcs help markdown' to display help in the markdown format." - , "" - , "Check bug reports at http://bugs.darcs.net/" - ] - -subusage :: DarcsCommand pf -> String -subusage super = usageInfo header (odesc stdCmdActions) ++ superHelp - where - header = unlines [ unwords [ "Usage:" - , commandProgramName super - , commandName super - , "SUBCOMMAND ..." - ] - , "" - , commandDescription super - , "" - , "Subcommands:" - , usageHelper (getSubcommands super) - , "Options:" - ] - superHelp = '\n' : commandHelp super - -usageHelper :: [CommandControl] -> String -usageHelper xs = usageHelper' (maximum $ 15 : (catMaybes $ map f xs)) xs - where - -- returns length of necessary tabbing this command - f (CommandData c) = Just ((+2) . length . wrappedCommandName $ c) - f _ = Nothing - -usageHelper' :: Int -> [CommandControl] -> String -usageHelper' _ [] = "" -usageHelper' x (HiddenCommand _ : cs) = usageHelper' x cs -usageHelper' x (CommandData c : cs) = " " ++ padSpaces (wrappedCommandName c) x - ++ chompTrailingNewline (wrappedCommandDescription c) - ++ "\n" ++ usageHelper' x cs -usageHelper' x (GroupName n : cs) = "\n" ++ n ++ "\n" ++ usageHelper' x cs - -padSpaces :: String -> Int -> String -padSpaces s n = s ++ replicate (n - length s) ' ' - superName :: Maybe (DarcsCommand pf) -> String superName Nothing = "" superName (Just x) = commandName x ++ " " -getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String -getCommandMiniHelp msuper cmd = unlines - [ getCommandHelpCore msuper cmd - , "" - , unwords [ "See" - , commandProgramName cmd - , "help" - , maybe "" ((++ " ") . commandName) msuper ++ commandName cmd - , "for details." - ] - ] - -getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String -getCommandHelp msuper cmd = basicHelp ++ advancedHelp ++ cmdHelp - where - basicHelp = unlines (reverse basicR) - - advancedHelp = if null advanced - then "" - else '\n' : - unlines ("Advanced options:" : reverse advancedR) - - cmdHelp = '\n' : commandHelp cmd - - -- we could just call usageInfo twice, but then the advanced - -- options might not line up with the basic ones (no short switches) - (advancedR, basicR) = splitAt (length advanced) . reverse . lines $ - combinedUsage - - combinedUsage = let header = getCommandHelpCore msuper cmd ++ subcommands - ++ "\n\nOptions:" - in usageInfo header (basic ++ advanced) - - (basic, advanced) = commandAlloptions cmd - - subcommands = case msuper of - Nothing -> case getSubcommands cmd of - [] -> [] - s -> "\n\nSubcommands:\n" - ++ usageHelper s - -- we don't want to list subcommands if we're already - -- specifying them - Just _ -> "" - -getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String -getCommandHelpCore msuper cmd = - unwords [ "Usage:" - , commandProgramName cmd - , superName msuper ++ commandName cmd - , "[OPTION]..." - , unwords args_help - ] - ++ "\n" ++ commandDescription cmd - where - args_help = case cmd of - (DarcsCommand {}) -> commandExtraArgHelp cmd - _ -> [] - data CommandArgs where CommandOnly :: DarcsCommand parsedFlags -> CommandArgs SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs @@ -366,89 +243,36 @@ potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` wrappedCommandName c] ++ [h | h <- extractHiddenCommands cs, cmd == wrappedCommandName h] -amVerbose :: [DarcsFlag] -> Bool -amVerbose = (== Verbose) . parseFlags verbosity - -amQuiet :: [DarcsFlag] -> Bool -amQuiet = (== Quiet) . parseFlags verbosity - putVerbose :: [DarcsFlag] -> Doc -> IO () -putVerbose flags = when (amVerbose flags) . putDocLn +putVerbose flags = when (verbose flags) . putDocLnWith fancyPrinters putInfo :: [DarcsFlag] -> Doc -> IO () -putInfo flags = unless (amQuiet flags) . putDocLn +putInfo flags = unless (quiet flags) . putDocLnWith fancyPrinters putWarning :: [DarcsFlag] -> Doc -> IO () -putWarning flags = unless (amQuiet flags) . hPutDocLn Encode stderr +putWarning flags = unless (quiet flags) . hPutDocLn stderr putVerboseWarning :: [DarcsFlag] -> Doc -> IO () -putVerboseWarning flags = when (amVerbose flags) . hPutDocLn Encode stderr +putVerboseWarning flags = when (verbose flags) . hPutDocLn stderr abortRun :: [DarcsFlag] -> Doc -> IO () abortRun flags msg = if parseFlags dryRun flags == YesDryRun - then putInfo flags $ text "NOTE:" <+> msg + then putInfo flags $ "NOTE:" <+> msg else errorDoc msg --- | @'printDryRunMessageAndExit' action flags 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\"@ @flags@ is the list of flags --- which were sent to darcs @patches@ is the sequence of patches which would be --- touched by @action@. -printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree) - => String - -> Verbosity -> Summary -> DryRun -> XmlOutput - -> Bool -- interactive - -> FL (PatchInfoAnd rt p) wX wY - -> IO () -printDryRunMessageAndExit action v s d x interactive patches = do - when (d == YesDryRun) $ do - putInfoX . text $ unwords [ "Would" - , action - , "the following changes:" - ] - putDocLn put_mode - putInfoX $ text "" - putInfoX $ text "Making no changes: this is a dry run." - exitSuccess - when (not interactive && s == YesSummary) $ do - putInfoX . text $ unwords [ "Will" - , action - , "the following changes:" - ] - putDocLn put_mode - where - put_mode = if x == YesXml - then text "" $$ - vcat (mapFL (indent . xml_info s) patches) $$ - text "" - else vsep $ mapFL (showFriendly v s) patches - - putInfoX = if x == YesXml then const (return ()) else putDocLn - - xml_info YesSummary = xml_with_summary - xml_info NoSummary = toXml . info - - xml_with_summary hp - | Just p <- hopefullyM hp = insertBeforeLastline (toXml $ info hp) - (indent $ xmlSummary p) - xml_with_summary hp = toXml (info hp) - - indent = prefix " " - -- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with -- info about the given patches, for use in post-hooks. setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree) => FL (PatchInfoAnd rt p) wX wY -> IO () -#ifndef WIN32 setEnvDarcsPatches ps = do let k = "Defining set of chosen patches" + debugMessage $ unlines ("setEnvDarcsPatches:" : listTouchedFiles ps) beginTedious k tediousSize k 3 finishedOneIO k "DARCS_PATCHES" - setEnvCautiously "DARCS_PATCHES" (renderString Encode $ Darcs.Patch.summary ps) + setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps) finishedOneIO k "DARCS_PATCHES_XML" - setEnvCautiously "DARCS_PATCHES_XML" . renderString Encode $ + setEnvCautiously "DARCS_PATCHES_XML" . renderString $ text "" $$ vcat (mapFL (toXml . info) ps) $$ text "" @@ -456,43 +280,37 @@ setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps) endTedious k +-- | Set the DARCS_FILES environment variable to the files touched by the +-- given patch, one per line, for use in post-hooks. +setEnvDarcsFiles :: (PatchInspect p) => p wX wY -> IO () +setEnvDarcsFiles ps = + setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps) + -- | Set some environment variable to the given value, unless said value is -- longer than 10K characters, in which case do nothing. setEnvCautiously :: String -> String -> IO () setEnvCautiously e v | toobig (10 * 1024) v = return () - | otherwise = setEnv e v True + | otherwise = + setEnv e v `catchIOError` (\_ -> setEnv e (decodeLocale (packStringToUTF8 v))) where -- note: not using (length v) because we want to be more lazy than that toobig :: Int -> [a] -> Bool toobig 0 _ = True toobig _ [] = False toobig n (_ : xs) = toobig (n - 1) xs -#else -setEnvDarcsPatches _ = return () -#endif --- | Set the DARCS_FILES environment variable to the files touched by the --- given patch, one per line, for use in post-hooks. -setEnvDarcsFiles :: (PatchInspect p, Patchy p) => p wX wY -> IO () -#ifndef WIN32 -setEnvDarcsFiles ps = - setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps) -#else -setEnvDarcsFiles _ = return () -#endif - defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] -defaultRepo fs = defaultrepo (remoteRepos fs) +defaultRepo fs = defaultrepo (remoteRepos ? fs) amInHashedRepository :: [DarcsFlag] -> IO (Either String ()) -amInHashedRepository fs = R.amInHashedRepository (workRepo fs) +amInHashedRepository fs = R.amInHashedRepository (workRepo ? fs) amInRepository :: [DarcsFlag] -> IO (Either String ()) -amInRepository fs = R.amInRepository (workRepo fs) +amInRepository fs = R.amInRepository (workRepo ? fs) amNotInRepository :: [DarcsFlag] -> IO (Either String ()) -amNotInRepository fs = R.amNotInRepository (workRepo fs) +amNotInRepository fs = R.amNotInRepository (workRepo ? fs) findRepository :: [DarcsFlag] -> IO (Either String ()) -findRepository fs = R.findRepository (workRepo fs) +findRepository fs = R.findRepository (workRepo ? fs) diff --git a/src/Darcs/UI/Commands/Add.hs b/src/Darcs/UI/Commands/Add.hs --- a/src/Darcs/UI/Commands/Add.hs +++ b/src/Darcs/UI/Commands/Add.hs @@ -23,30 +23,23 @@ -- Stability : experimental -- Portability : portable -{-# LANGUAGE CPP #-} -module Darcs.UI.Commands.Add - ( - add - , expandDirs - ) where +module Darcs.UI.Commands.Add ( add ) where import Prelude () import Darcs.Prelude -#include "impossible.h" - -import Prelude hiding ( (^) ) - import Control.Exception ( catch, IOException ) -import Control.Monad ( when, unless, liftM ) +import Control.Monad ( when, unless ) import Data.List ( (\\), nub ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( isNothing, maybeToList ) import Darcs.Util.Printer ( text ) import Darcs.Util.Tree ( Tree, findTree, expand ) -import Darcs.Util.Path ( floatPath, anchorPath, parents, - SubPath, toFilePath, simpleSubPath, toPath, AbsolutePath ) -import System.FilePath.Posix ( takeDirectory, () ) +import Darcs.Util.Path + ( floatPath, anchorPath, parents + , SubPath, toFilePath, AbsolutePath + ) +import System.FilePath.Posix ( takeDirectory ) import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink ) import System.Directory ( getPermissions, readable ) @@ -55,32 +48,30 @@ import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning , nodefaults, amInHashedRepository) +import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase ) +import Darcs.UI.Commands.Util ( expandDirs, doesDirectoryReallyExist ) +import Darcs.UI.Completion ( unknownFileArgs ) import Darcs.UI.Flags ( DarcsFlag - , includeBoring, doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask - , fixSubPaths, verbosity ) + , includeBoring, allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask + , fixSubPaths, quiet ) import Darcs.UI.Options - ( DarcsOption - , (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) + ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O -import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase ) import Darcs.Repository.Flags ( UpdateWorking(..) ) -import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir ) +import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Repository.State ( readRecordedAndPending, updateIndex ) import Darcs.Repository ( withRepoLock , RepoJob(..) , addToPending - , listFiles - , listUnregisteredFiles ) import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter ) -import Darcs.Util.File ( getFileStatus, withCurrentDirectory ) +import Darcs.Util.File ( getFileStatus ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) - addDescription :: String addDescription = "Add new files to version control." @@ -111,38 +102,6 @@ "`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" ++ "unusable on those systems!\n\n" -addBasicOpts :: DarcsOption a - (O.IncludeBoring -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> a) -addBasicOpts = O.includeBoring - ^ O.allowProblematicFilenames - ^ O.recursive - ^ O.workingRepoDir - ^ O.dryRun - -addAdvancedOpts :: DarcsOption a (O.UMask -> a) -addAdvancedOpts = O.umask - -addOpts :: DarcsOption a - (O.IncludeBoring - -> Bool - -> Bool - -> Bool - -> Maybe String - -> O.DryRun - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -addOpts = withStdOpts addBasicOpts addAdvancedOpts - add :: DarcsCommand [DarcsFlag] add = DarcsCommand { commandProgramName = "darcs" @@ -153,8 +112,7 @@ , commandExtraArgHelp = [ " ..." ] , commandCommand = addCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listUnregisteredFiles False - -- bash completion should not offer boring files + , commandCompleteArgs = unknownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc addAdvancedOpts , commandBasicOptions = odesc addBasicOpts @@ -162,6 +120,15 @@ , commandCheckOptions = ocheck addOpts , commandParseOptions = onormalise addOpts } + where + addBasicOpts + = O.includeBoring + ^ O.allowProblematicFilenames + ^ O.recursive + ^ O.repoDir + ^ O.dryRun + addAdvancedOpts = O.umask + addOpts = withStdOpts addBasicOpts addAdvancedOpts addCmd :: (AbsolutePath, AbsolutePath) @@ -181,7 +148,9 @@ addFiles :: [DarcsFlag] -- ^ Command options -> [SubPath] -> IO () -addFiles opts origfiles = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do +addFiles opts origfiles = + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do -- TODO do not expand here, and use findM/findIO or such later -- (needs adding to hashed-storage first though) cur <- expand =<< readRecordedAndPending repository @@ -196,19 +165,19 @@ mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $ flist \\ nboring flist Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring flist - when (nullFL ps && not (null origfiles) && notQuiet) $ + -- TODO whether we fail or not depends on verbosity BAD BAD BAD + when (nullFL ps && not (null origfiles) && not (quiet opts)) $ fail "No files were added" unless gotDryRun $ do addToPending repository YesUpdateWorking ps updateIndex repository where - gotDryRun = dryRun opts == O.YesDryRun + gotDryRun = dryRun ? opts == O.YesDryRun msgs | gotDryRun = dryRunMessages | otherwise = normalMessages - notQuiet = verbosity opts /= O.Quiet -addp :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree) +addp :: forall prim . (PrimPatch prim, ApplyState prim ~ Tree) => AddMessages -> [DarcsFlag] -> Tree IO @@ -319,8 +288,8 @@ msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e return (cur, Nothing, Nothing) parentdir = takeDirectory f - gotAllowCaseOnly = doAllowCaseOnly opts - gotAllowWindowsReserved = doAllowWindowsReserved opts + gotAllowCaseOnly = allowCaseDifferingFilenames ? opts + gotAllowWindowsReserved = allowWindowsReservedFilenames ? opts data AddMessages = AddMessages @@ -352,34 +321,9 @@ } -doesDirectoryReallyExist :: FilePath -> IO Bool -doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f - - -expandDirs :: Bool -> [SubPath] - -> IO [SubPath] -expandDirs doIncludeBoring fs = - do - liftM (map (fromJust . simpleSubPath)) $ - concat `fmap` mapM (expandOne doIncludeBoring . toPath) fs - - -expandOne :: Bool -> FilePath - -> IO [FilePath] -expandOne doIncludeBoring "" = listFiles doIncludeBoring -expandOne doIncludeBoring f = do - isdir <- doesDirectoryReallyExist f - if not isdir - then return [f] - else do - fs <- withCurrentDirectory f (listFiles doIncludeBoring) - return $ f: map (f ) fs - - getParents :: Tree IO -> [FilePath] -> [FilePath] getParents cur = map (anchorPath "") . go . map floatPath where go fs = filter (isNothing . findTree cur) $ concatMap parents fs - diff --git a/src/Darcs/UI/Commands/Amend.hs b/src/Darcs/UI/Commands/Amend.hs --- a/src/Darcs/UI/Commands/Amend.hs +++ b/src/Darcs/UI/Commands/Amend.hs @@ -43,8 +43,9 @@ , amInHashedRepository ) import Darcs.UI.Commands.Util ( announceFiles, testTentativeAndMaybeExit ) +import Darcs.UI.Completion ( modifiedFileArgs, knownFileArgs ) import Darcs.UI.Flags ( DarcsFlag, diffOpts, fixSubPaths ) -import Darcs.UI.Options ( DarcsOption, (^), oparse, odesc, ocheck, defaultFlags ) +import Darcs.UI.Options ( DarcsOption, (^), oparse, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( updatePatchHeader, AskAboutDeps(..) , HijackOptions(..) @@ -70,12 +71,10 @@ , withManualRebaseUpdate , finalizeRepositoryChanges , invalidateIndex - , unrecordedChangesWithPatches + , unrecordedChanges , readRecorded - , listRegisteredFiles ) import Darcs.Repository.Prefs ( globalPrefsDirDoc ) -import Darcs.Repository.State ( getMovesPs, getReplaces ) import Darcs.UI.SelectChanges ( WhichChanges(..) , selectionContextPrim @@ -88,12 +87,10 @@ import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL, mapFL_FL ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.Printer ( putDocLn ) import Darcs.Util.Tree( Tree ) -import Darcs.Repository.Internal ( tentativelyRemoveFromPending ) +import Darcs.Repository.Pending ( tentativelyRemoveFromPending ) amendDescription :: String @@ -151,11 +148,11 @@ ^ O.author ^ O.selectAuthor ^ O.patchname - ^ O.askdeps + ^ O.askDeps ^ O.askLongComment ^ O.keepDate ^ O.lookfor - ^ O.workingRepoDir + ^ O.repoDir ^ O.withContext ^ O.diffAlgorithm @@ -192,10 +189,7 @@ -> O.UMask -> O.SetScriptsExecutable -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool + -> O.HooksConfig -> a) amendOpts = withStdOpts amendBasicOpts amendAdvancedOpts @@ -237,7 +231,7 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = amendCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = amendFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc amendAdvancedOpts , commandBasicOptions = odesc amendBasicOpts @@ -245,7 +239,11 @@ , commandCheckOptions = ocheck amendOpts , commandParseOptions = amendConfig } - + where + amendFileArgs fps flags args = + if (O.amendUnrecord ? flags) + then knownFileArgs fps flags args + else modifiedFileArgs fps flags args amendrecord :: DarcsCommand AmendConfig amendrecord = commandAlias "amend-record" Nothing amend @@ -293,15 +291,9 @@ (_ :> chosenPrims) <- runSelection (effect oldp) context let invPrims = reverseRL (invertFL chosenPrims) addChangesToPatch cfg repository oldp invPrims - else do Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces - then getReplaces (diffingOpts cfg) repository files - else return (Sealed NilFL) - movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves - then getMovesPs repository files - else return NilFL - go =<< unrecordedChangesWithPatches - movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) - (diffingOpts cfg) repository files + else go =<< unrecordedChanges (diffingOpts cfg) + (O.moves (lookfor cfg)) (O.replaces (lookfor cfg)) + repository files -- amending a tag else if hasEditMetadata cfg && isNothing files -- the user is not trying to add new changes to the tag so there is diff --git a/src/Darcs/UI/Commands/Annotate.hs b/src/Darcs/UI/Commands/Annotate.hs --- a/src/Darcs/UI/Commands/Annotate.hs +++ b/src/Darcs/UI/Commands/Annotate.hs @@ -14,22 +14,21 @@ -- along with this program; see the file COPYING. If not, write to -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Annotate ( annotate ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import Control.Arrow ( first ) -import Control.Monad ( unless ) +import Control.Monad ( when ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), useCache, fixSubPaths, umask ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise - , defaultFlags, parseFlags ) +import Darcs.UI.Completion ( knownFileArgs ) +import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths, patchIndexYes ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.State ( readRecorded ) import Darcs.Repository @@ -38,11 +37,9 @@ , RepoJob(..) , readRepo , repoPatchType - , listRegisteredFiles ) -import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex ) -import Darcs.Patch.Set ( newset2RL ) +import Darcs.Patch.Set ( patchSet2RL ) import Darcs.Patch ( invertRL ) import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate ) import Data.ByteString.Lazy ( toChunks ) @@ -57,10 +54,8 @@ import Darcs.Util.Tree( TreeItem(..), readBlob, list, expand ) import Darcs.Util.Tree.Monad( findM, virtualTreeIO ) import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath - , AbsolutePath ) -import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) - -#include "impossible.h" + , AbsolutePath, SubPath ) +import Darcs.Util.Exception ( die ) annotateDescription :: String annotateDescription = "Annotate lines of a file with the last patch that modified it." @@ -74,36 +69,6 @@ , "machine postprocessing." ] -annotateBasicOpts :: DarcsOption a - (Bool - -> [O.MatchFlag] - -> Maybe String - -> a) -annotateBasicOpts = O.machineReadable - ^ O.matchUpToOne - ^ O.workingRepoDir - -annotateAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a) -annotateAdvancedOpts = O.patchIndexYes - -annotateOpts :: DarcsOption a - ( Bool - -> [O.MatchFlag] - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.WithPatchIndex - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts - annotate :: DarcsCommand [DarcsFlag] annotate = DarcsCommand { commandProgramName = "darcs" @@ -114,60 +79,69 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]"] , commandCommand = annotateCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc annotateAdvancedOpts , commandBasicOptions = odesc annotateBasicOpts , commandDefaults = defaultFlags annotateOpts , commandCheckOptions = ocheck annotateOpts , commandParseOptions = onormalise annotateOpts -} + } + where + annotateBasicOpts = O.machineReadable ^ O.matchUpToOne ^ O.repoDir + annotateAdvancedOpts = O.patchIndexYes + annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -annotateCmd _ _ [""] = fail "No filename argument given to annotate!" annotateCmd fps opts args = do - let matchFlags = parseFlags O.matchUpToOne opts - unless (NoPatchIndexFlag `elem` opts) - $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex - withRepository (useCache opts) $ RepoJob $ \repository -> do + fixed_paths <- fixSubPaths fps args + case fixed_paths of + [] -> die "Error: annotate needs a filename to work with" + (fixed_path:_) -> do + when (patchIndexYes ? opts == O.YesPatchIndex) + $ withRepoLockCanFail (useCache ? opts) + $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo) + annotateCmd' opts fixed_path + +annotateCmd' :: [DarcsFlag] -> SubPath -> IO () +annotateCmd' opts fixed_path = withRepository (useCache ? opts) $ RepoJob $ \repository -> do + let matchFlags = parseFlags O.matchUpToOne opts r <- readRepo repository - (origpath:_) <- fixSubPaths fps args recorded <- readRecorded repository - (patches, initial, path') <- if haveNonrangeMatch (repoPatchType repository) matchFlags then do Sealed x <- getOnePatchset repository matchFlags - let fn = [fp2fn $ toFilePath origpath] + let fn = [fp2fn $ toFilePath fixed_path] nonRangeMatch = getNonrangeMatchS matchFlags r (_, [path], _) = withFileNames Nothing fn nonRangeMatch initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS matchFlags r) recorded - return (seal $ newset2RL x, initial, toFilePath path) - else return (seal $ newset2RL r, recorded, toFilePath origpath) + return (seal $ patchSet2RL x, initial, toFilePath path) + else return (seal $ patchSet2RL r, recorded, toFilePath fixed_path) let path = "./" ++ path' found <- findM initial (floatPath $ toFilePath path) -- TODO need to decide about the --machine flag let fmt = if parseFlags O.machineReadable opts then A.machineFormat else A.format + usePatchIndex <- (O.yes (O.patchIndexYes ? opts) &&) <$> canUsePatchIndex repository case found of - Nothing -> fail $ "No such file or directory: " ++ toFilePath path + Nothing -> die $ "Error: no such file or directory: " ++ toFilePath path Just (SubTree s) -> do s' <- expand s let subs = map (fp2fn . (path ) . anchorPath "" . fst) $ list s' showPath (n, File _) = BC.pack (path n) showPath (n, _) = BC.concat [BC.pack (path n), "/"] (Sealed ans_patches) <- do - upi <- canUsePatchIndex repository - if not upi + if not usePatchIndex then return patches - else getRelevantSubsequence patches repository subs + else getRelevantSubsequence patches repository r subs putStrLn $ fmt (BC.intercalate "\n" $ map (showPath . first (anchorPath "")) $ list s') $ - A.annotateDirectory D.MyersDiff (invertRL ans_patches) (fp2fn path) subs + A.annotateDirectory (invertRL ans_patches) (fp2fn path) subs Just (File b) -> do (Sealed ans_patches) <- do - upi <- canUsePatchIndex repository - if not upi + if not usePatchIndex then return patches - else getRelevantSubsequence patches repository [fp2fn path] + else getRelevantSubsequence patches repository r [fp2fn path] con <- BC.concat `fmap` toChunks `fmap` readBlob b - putStrLn $ fmt con $ A.annotate D.MyersDiff (invertRL ans_patches) (fp2fn path) con + putStrLn $ fmt con $ + A.annotateFile (invertRL ans_patches) (fp2fn path) con Just (Stub _ _) -> impossible diff --git a/src/Darcs/UI/Commands/Apply.hs b/src/Darcs/UI/Commands/Apply.hs --- a/src/Darcs/UI/Commands/Apply.hs +++ b/src/Darcs/UI/Commands/Apply.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Apply ( apply, applyCmd , getPatchBundle -- used by darcsden @@ -26,7 +24,6 @@ import Darcs.Prelude import System.Exit ( exitSuccess ) -import Prelude hiding ( (^) ) import Control.Monad ( when ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info ) @@ -35,14 +32,15 @@ , putVerbose , amInHashedRepository ) +import Darcs.UI.Completion ( fileArgs ) import Darcs.UI.Flags ( DarcsFlag - , doHappyForwarding, doReverse, verbosity, useCache, dryRun + , happyForwarding, changesReverse, verbosity, useCache, dryRun , reorder, umask , fixUrl, getCc, getSendmailCmd - , isUnified, getReply + , withContext, reply ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) @@ -53,10 +51,10 @@ , readRepo , filterOutConflicts ) -import Darcs.Patch.Set ( Origin, newset2RL ) -import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf ) +import Darcs.Patch.Set ( Origin, patchSet2RL ) +import Darcs.Patch ( IsRepoType, RepoPatch ) import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI ) +import Darcs.Patch.Info ( PatchInfo, displayPatchInfo ) import Darcs.Patch.Witnesses.Ordered ( RL(..), (:\/:)(..), (:>)(..) , mapRL, nullFL, reverseFL ) @@ -85,13 +83,10 @@ import Darcs.Patch.Bundle ( scanBundle ) import Darcs.Util.Printer ( packedString, vcat, text, empty - , renderString, RenderMode(..) + , renderString ) import Darcs.Util.Tree( Tree ) -#include "impossible.h" - - applyDescription :: String applyDescription = "Apply a patch bundle created by `darcs send'." @@ -138,99 +133,6 @@ stdindefault _ [] = return ["-"] stdindefault _ x = return x -conflictsOpt :: DarcsOption a (Maybe O.AllowConflicts -> a) -conflictsOpt = O.conflicts O.NoAllowConflicts - -applyBasicOpts :: DarcsOption a - (O.Verify - -> O.Reorder - -> Maybe Bool - -> O.DryRun - -> O.XmlOutput - -> [O.MatchFlag] - -> Maybe O.AllowConflicts - -> O.ExternalMerge - -> O.RunTest - -> O.LeaveTestDir - -> Maybe String - -> O.DiffAlgorithm - -> a) -applyBasicOpts - = O.verify - ^ O.reorder - ^ O.interactive - ^ O.dryRunXml - ^ O.matchSeveral - ^ conflictsOpt - ^ O.useExternalMerge - ^ O.test - ^ O.leaveTestDir - ^ O.workingRepoDir - ^ O.diffAlgorithm - -applyAdvancedOpts :: DarcsOption a - (Maybe String - -> Maybe String - -> Bool - -> (Bool, Maybe String) - -> O.UseIndex - -> O.Compression - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.WantGuiPause - -> a) -applyAdvancedOpts - = O.reply - ^ O.ccApply - ^ O.happyForwarding - ^ O.sendmail - ^ O.useIndex - ^ O.compress - ^ O.setScriptsExecutable - ^ O.umask - ^ O.restrictPaths - ^ O.changesReverse - ^ O.pauseForGui - -applyOpts :: DarcsOption a - (O.Verify - -> O.Reorder - -> Maybe Bool - -> O.DryRun - -> O.XmlOutput - -> [O.MatchFlag] - -> Maybe O.AllowConflicts - -> O.ExternalMerge - -> O.RunTest - -> O.LeaveTestDir - -> Maybe String - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> Maybe String - -> Maybe String - -> Bool - -> (Bool, Maybe String) - -> O.UseIndex - -> O.Compression - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.WantGuiPause - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts - apply :: DarcsCommand [DarcsFlag] apply = DarcsCommand { commandProgramName = "darcs" @@ -241,7 +143,7 @@ , commandExtraArgHelp = [""] , commandCommand = applyCmd StandardPatchApplier , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = fileArgs , commandArgdefaults = const stdindefault , commandAdvancedOptions = odesc applyAdvancedOpts , commandBasicOptions = odesc applyBasicOpts @@ -249,25 +151,55 @@ , commandCheckOptions = ocheck applyOpts , commandParseOptions = onormalise applyOpts } + where + applyBasicOpts + = O.verify + ^ O.reorder + ^ O.interactive + ^ O.dryRunXml + ^ O.matchSeveral + ^ O.conflictsNo + ^ O.externalMerge + ^ O.runTest + ^ O.leaveTestDir + ^ O.repoDir + ^ O.diffAlgorithm + applyAdvancedOpts + = O.reply + ^ O.ccApply + ^ O.happyForwarding + ^ O.sendmail + ^ O.useIndex + ^ O.compress + ^ O.setScriptsExecutable + ^ O.umask + ^ O.restrictPaths + ^ O.changesReverse + ^ O.pauseForGui + applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts applyCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () applyCmd _ _ _ [""] = fail "Empty filename argument given to apply!" -applyCmd patchApplier _ opts ["-"] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy repository -> do +applyCmd patchApplier _ opts ["-"] = + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + repoJob patchApplier opts $ \patchProxy repository -> do -- for darcs users who try out 'darcs apply' without any arguments - putVerbose opts $ text "reading patch bundle from stdin..." - bundle <- gzReadStdin - applyCmdCommon patchApplier patchProxy opts bundle repository + putVerbose opts $ text "reading patch bundle from stdin..." + bundle <- gzReadStdin + applyCmdCommon patchApplier patchProxy opts bundle repository -applyCmd patchApplier (_,o) opts [unfixed_patchesfile] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy repository -> do - patchesfile <- fixUrl o unfixed_patchesfile - bundle <- gzFetchFilePS (toFilePath patchesfile) Uncachable - applyCmdCommon patchApplier patchProxy opts bundle repository +applyCmd patchApplier (_,o) opts [unfixed_patchesfile] = + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + repoJob patchApplier opts $ \patchProxy repository -> do + patchesfile <- fixUrl o unfixed_patchesfile + bundle <- gzFetchFilePS (toFilePath patchesfile) Uncachable + applyCmdCommon patchApplier patchProxy opts bundle repository applyCmd _ _ _ _ = impossible applyCmdCommon :: forall rt pa p wR wU - . ( PatchApplier pa, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree + . ( PatchApplier pa, RepoPatch p, ApplyState p ~ Tree , ApplierRepoTypeConstraint pa rt, IsRepoType rt ) => pa @@ -290,22 +222,22 @@ common :> _ <- return $ findCommonWithThem us them -- all patches that are in "them" and not in "common" need to be available; check that - let common_i = mapRL info $ newset2RL common - them_i = mapRL info $ newset2RL them + let common_i = mapRL info $ patchSet2RL common + them_i = mapRL info $ patchSet2RL them required = them_i \\ common_i -- FIXME quadratic? check :: RL (PatchInfoAnd rt p) wX wY -> [PatchInfo] -> IO () check (ps' :<: p) bad = case hopefullyM p of Nothing | info p `elem` required -> check ps' (info p : bad) _ -> check ps' bad check NilRL [] = return () - check NilRL bad = fail . renderString Encode $ vcat $ map showPatchInfoUI bad ++ + check NilRL bad = fail . renderString $ vcat $ map displayPatchInfo bad ++ [ text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ] - check (newset2RL them) [] + check (patchSet2RL them) [] (us':\/:them') <- return $ findUncommon us them (hadConflicts, Sealed their_ps) - <- if parseFlags conflictsOpt opts == Nothing -- skip conflicts + <- if O.conflictsNo ? opts == Nothing -- skip conflicts then filterOutConflicts (reverseFL us') repository them' else return (False, Sealed them') when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts." @@ -314,9 +246,9 @@ then putStrLn ("All new patches of the bundle cause conflicts. " ++ "Nothing to do.") >> exitSuccess else putStrLn ("All these patches have already been applied. " ++ - "Nothing to do.") >> when (reorder opts /= O.Reorder) exitSuccess + "Nothing to do.") >> when (reorder ? opts /= O.Reorder) exitSuccess - let direction = if doReverse opts then FirstReversed else First + let direction = if changesReverse ? opts then FirstReversed else First context = selectionContext direction "apply" (patchSelOpts opts) Nothing Nothing (to_be_applied :> _) <- runSelection their_ps context applyPatches patchApplier patchProxy "apply" opts from_whom repository us' to_be_applied @@ -394,7 +326,7 @@ "key, or there was a GPG failure.\n" considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool -considerForwarding opts bundle = case getReply opts of +considerForwarding opts bundle = case reply ? opts of Nothing -> return False Just from -> case break is_from (linesPS bundle) of (m1, f:m2) -> @@ -405,7 +337,7 @@ then return False -- Refuse possible email loop. else do scmd <- getSendmailCmd opts - if doHappyForwarding opts + if happyForwarding ? opts then resendEmail from scmd bundle else sendEmailDoc f' from "A forwarded darcs patch" cc scmd (Just (empty,empty)) @@ -421,12 +353,12 @@ patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveral flags , S.interactive = maybeIsInteractive flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default - , S.withContext = isUnified flags + , S.withContext = withContext ? flags } maybeIsInteractive :: [DarcsFlag] -> Bool diff --git a/src/Darcs/UI/Commands/Clone.hs b/src/Darcs/UI/Commands/Clone.hs --- a/src/Darcs/UI/Commands/Clone.hs +++ b/src/Darcs/UI/Commands/Clone.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Clone ( get , put @@ -28,8 +26,6 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import System.Directory ( doesDirectoryExist, doesFileExist , setCurrentDirectory ) import System.Exit ( ExitCode(..) ) @@ -43,17 +39,20 @@ , commandAlias , putInfo ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags( DarcsFlag( NewRepo , UpToPattern , UpToPatch + , UpToHash , OnePattern , OnePatch + , OneHash ) - , toMatchFlags, useCache, umask, remoteRepos - , setDefault , DarcsFlag(Quiet), usePacks + , matchAny, useCache, umask, remoteRepos + , setDefault, quiet, usePacks , remoteDarcs, cloneKind, verbosity, setScriptsExecutable - , withWorkingDir, runPatchIndex ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) + , withWorkingDir, patchIndexNo ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands.Util ( getUniqueRepositoryName ) import Darcs.Repository ( cloneRepository ) @@ -70,7 +69,7 @@ import Darcs.Patch.Bundle ( scanContextFile ) import Darcs.Patch.Dummy ( DummyPatch ) import Darcs.Patch.Set ( PatchSet, Origin ) -import Darcs.Repository.Motd ( showMotd ) +import Darcs.Repository.Prefs ( showMotd ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Printer ( text, ($$) ) import Darcs.Util.Path ( toFilePath, toPath, ioAbsoluteOrRemote, AbsolutePath ) @@ -116,47 +115,6 @@ ] ++ cloneHelpTag ++ cloneHelpSSE -cloneBasicOpts :: DarcsOption a - (Maybe String - -> CloneKind - -> [O.MatchFlag] - -> Maybe Bool - -> O.SetScriptsExecutable - -> O.WithWorkingDir - -> a) -cloneBasicOpts = O.reponame - ^ O.partial - ^ O.matchOneContext - ^ O.setDefault - ^ O.setScriptsExecutable - ^ O.useWorkingDir - -cloneAdvancedOpts :: DarcsOption a (Bool -> O.WithPatchIndex -> O.NetworkOptions -> a) -cloneAdvancedOpts = O.usePacks ^ O.patchIndex ^ O.network - -cloneOpts :: DarcsOption a - (Maybe String - -> CloneKind - -> [O.MatchFlag] - -> Maybe Bool - -> O.SetScriptsExecutable - -> O.WithWorkingDir - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> Bool - -> O.WithPatchIndex - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts - clone :: DarcsCommand [DarcsFlag] clone = DarcsCommand { commandProgramName = "darcs" @@ -167,7 +125,7 @@ , commandExtraArgHelp = ["", "[]"] , commandCommand = cloneCmd , commandPrereq = validContextFile - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc cloneAdvancedOpts , commandBasicOptions = odesc cloneBasicOpts @@ -175,6 +133,16 @@ , commandCheckOptions = ocheck cloneOpts , commandParseOptions = onormalise cloneOpts } + where + cloneBasicOpts + = O.reponame + ^ O.cloneKind + ^ O.matchOneContext + ^ O.setDefault + ^ O.setScriptsExecutable + ^ O.withWorkingDir + cloneAdvancedOpts = O.usePacks ^ O.patchIndexNo ^ O.network + cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts get :: DarcsCommand [DarcsFlag] get = commandAlias "get" Nothing clone @@ -199,7 +167,7 @@ debugMessage "Starting work on clone..." typed_repodir <- ioAbsoluteOrRemote inrepodir let repodir = toPath typed_repodir - unless (Quiet `elem` opts) $ showMotd repodir + unless (quiet opts) $ showMotd repodir rfsource <- identifyRepoFormat repodir debugMessage $ "Found the format of "++repodir++"..." @@ -226,61 +194,63 @@ withTempDir "clone" $ \_ -> do putInfo opts $ text "Creating local clone..." currentDir <- getCurrentDirectory - cloneRepository repodir "local" (verbosity opts) (useCache opts) - CompleteClone (umask opts) (remoteDarcs opts) - (setScriptsExecutable opts) - (remoteRepos opts) (NoSetDefault True) - (toMatchFlags $ map convertUpToToOne opts) + mysimplename <- makeRepoName True [] repodir -- give correct name to local clone + cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts) + CompleteClone (umask ? opts) (remoteDarcs opts) + (setScriptsExecutable ? opts) + (remoteRepos ? opts) (NoSetDefault True) + (matchAny ? map convertUpToToOne opts) rfsource - (withWorkingDir opts) - (runPatchIndex opts) - (usePacks opts) + (withWorkingDir ? opts) + (patchIndexNo ? opts) + (usePacks ? opts) YesForgetParent setCurrentDirectory currentDir (scp, args) <- getSSH SCP - putInfo opts $ text "Transferring clone by SCP..." - r <- exec scp (args ++ ["-r", "local", repo]) (AsIs,AsIs,AsIs) - when (r /= ExitSuccess) $ fail $ "Problem during SCP transfer." + putInfo opts $ text $ "Transferring clone using " ++ scp ++ "..." + r <- exec scp (args ++ ["-r", mysimplename ++ "/", repo]) (AsIs,AsIs,AsIs) + when (r /= ExitSuccess) $ fail $ "Problem during " ++ scp ++ " transfer." putInfo opts $ text "Cloning and transferring successful." Nothing -> do mysimplename <- makeRepoName True opts repodir - cloneRepository repodir mysimplename (verbosity opts) (useCache opts) - (cloneKind opts) (umask opts) (remoteDarcs opts) - (setScriptsExecutable opts) - (remoteRepos opts) (setDefault True opts) - (toMatchFlags $ map convertUpToToOne opts) + cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts) + (cloneKind ? opts) (umask ? opts) (remoteDarcs opts) + (setScriptsExecutable ? opts) + (remoteRepos ? opts) (setDefault True opts) + (matchAny ? map convertUpToToOne opts) rfsource - (withWorkingDir opts) - (runPatchIndex opts) - (usePacks opts) + (withWorkingDir ? opts) + (patchIndexNo ? opts) + (usePacks ? opts) NoForgetParent putInfo opts $ text "Finished cloning." cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments." cloneToSSH :: [DarcsFlag] -> Maybe String -cloneToSSH fs = case parseFlags O.reponame fs of +cloneToSSH fs = case O.reponame ? fs of Nothing -> Nothing Just r -> if isSshUrl r then Just r else Nothing makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String -makeRepoName talkative dfs d = - case [ n | NewRepo n <- dfs] of - (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 - [] -> - case dropWhile (=='.') $ reverse $ - takeWhile (\c -> c /= '/' && c /= ':') $ - dropWhile (=='/') $ reverse d of - "" -> getUniqueRepositoryName talkative "anonymous_repo" - base@('/':_) -> getUniqueRepositoryName talkative base -- Absolute - base -> do -- Relative - cwd <- getCurrentDirectory - getUniqueRepositoryName talkative (cwd ++ "/" ++ base) +makeRepoName talkative fs d = + case O.reponame ? fs of + Just 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 + Nothing -> + case mkName d of + "" -> getUniqueRepositoryName talkative "anonymous_repo" + base@('/':_) -> getUniqueRepositoryName talkative base -- Absolute + base -- Relative + -> do + cwd <- getCurrentDirectory + getUniqueRepositoryName talkative (cwd ++ "/" ++ base) + where mkName = dropWhile (== '.') . reverse . + takeWhile (not . (`elem` "/:")) . dropWhile (== '/') . reverse cloneHelpTag :: String cloneHelpTag = @@ -330,11 +300,14 @@ else return . Left $ "Context file " ++ ctxFilePath ++ " does not exist" +-- TODO getContext choses arbitrarily the first --context flag +-- should instead report an error when more than one is given + -- | '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@ getContext :: [DarcsFlag] -> Maybe AbsolutePath -getContext fs = listToMaybe [ f | O.Context f <- toMatchFlags fs ] +getContext fs = listToMaybe [ f | O.Context f <- O.context ? fs ] -- The 'clone' command takes --to-patch and --to-match as arguments, -- but internally wants to handle them as if they were --patch and --match @@ -343,4 +316,5 @@ convertUpToToOne :: DarcsFlag -> DarcsFlag convertUpToToOne (UpToPattern p) = OnePattern p convertUpToToOne (UpToPatch p) = OnePatch p +convertUpToToOne (UpToHash p) = OneHash p convertUpToToOne f = f diff --git a/src/Darcs/UI/Commands/Convert.hs b/src/Darcs/UI/Commands/Convert.hs --- a/src/Darcs/UI/Commands/Convert.hs +++ b/src/Darcs/UI/Commands/Convert.hs @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, MagicHash, OverloadedStrings #-} +{-# LANGUAGE MagicHash, OverloadedStrings #-} module Darcs.UI.Commands.Convert ( convert ) where @@ -23,8 +23,11 @@ import Darcs.Prelude hiding ( readFile, lex ) import System.FilePath.Posix ( () ) -import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, - createDirectory, removeFile ) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , removeFile + ) import System.IO ( stdin ) import Data.IORef ( newIORef, modifyIORef, readIORef ) import Data.Char ( isSpace ) @@ -35,7 +38,6 @@ import Control.Exception ( finally ) import Control.Applicative ( (<|>) ) -import GHC.Base ( unsafeCoerce# ) import System.Time ( toClockTime ) import Data.Maybe ( catMaybes, fromMaybe ) import qualified Data.IntMap as M @@ -49,6 +51,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Attoparsec.ByteString.Char8( () ) +import Darcs.Util.ByteString ( decodeLocale ) import qualified Darcs.Util.Tree as T import qualified Darcs.Util.Tree.Monad as TM import Darcs.Util.Tree.Monad hiding ( createDirectory, exists, rename ) @@ -57,14 +60,14 @@ , emptyTree, listImmediate, findTree ) import Darcs.Util.Path( anchorPath, appendPath, floatPath , parent, anchoredRoot - , AnchoredPath(..), Name(..) + , AnchoredPath(..), makeName , ioAbsoluteOrRemote, toPath, AbsolutePath ) import Darcs.Util.Hash( encodeBase16, sha256, Hash(..) ) import Darcs.Util.DateTime ( formatDateTime, fromClockTime, parseDateTime, startOfTime ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Exception ( clarifyErrors ) +import Darcs.Util.Lock ( withNewDirectory ) import Darcs.Util.Prompt ( askUser ) import Darcs.Util.Printer ( text, ($$) ) import Darcs.Util.Printer.Color ( traceDoc ) @@ -72,10 +75,9 @@ import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully ) -import Darcs.Patch ( IsRepoType, showPatch, fromPrim, fromPrims, - effect, - RepoPatch, apply, listTouchedFiles - , move ) +import Darcs.Patch + ( showPatch, ShowPatchFor(..), fromPrim, fromPrims + , effect, RepoPatch, apply, listTouchedFiles, move ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.Named @@ -86,63 +88,74 @@ import qualified Darcs.Patch.Named.Wrapped as Wrapped ( getdeps ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) ) import Darcs.Patch.Witnesses.Ordered - ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL, + ( FL(..), RL(..), bunchFL, mapFL_FL, concatFL, mapRL, nullFL, (+>+), (+<+) - , reverseRL, reverseFL ) + , reverseRL, reverseFL, foldFL_M ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(..), unFreeLeft - , flipSeal, unsafeUnsealFlipped ) + , mapSeal, flipSeal, unsafeUnsealFlipped ) + import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo, patchinfo, piName, piLog, piDate, piAuthor, makePatchname ) -import Darcs.Patch.V1 ( RepoPatchV1 ) -import Darcs.Patch.V2 ( RepoPatchV2 ) +import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) +import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) +import qualified Darcs.Patch.V2 as V2 ( RepoPatchV2 ) +import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import Darcs.Patch.V1.Commute ( publicUnravel ) -import Darcs.Patch.V1.Core ( RepoPatchV1(PP), isMerger ) +import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(PP), isMerger ) import Darcs.Patch.V2.RepoPatch ( mergeUnravelled ) import Darcs.Patch.Prim ( sortCoalesceFL ) import Darcs.Patch.Prim.Class ( PrimOf ) -import Darcs.Patch.Prim.V1 ( Prim ) -import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) -import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL, newset2FL ) +import Darcs.Patch.RepoType ( RepoType(..), IsRepoType(..), RebaseType(..) ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), patchSet2RL, patchSet2FL ) import Darcs.Patch.Progress ( progressFL ) -import Darcs.Repository.Flags ( UpdateWorking(..), Reorder (..), UseIndex(..), ScanKnown(..) - , AllowConflicts(..), ExternalMerge(..), WantGuiPause(..), PatchFormat(..) - , Compression(..), DryRun(NoDryRun), DiffAlgorithm(MyersDiff, PatienceDiff) ) -import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory, - createRepository, invalidateIndex, - tentativelyMergePatches, - createPristineDirectoryTree, - revertRepositoryChanges, finalizeRepositoryChanges, - applyToWorking - , readRepo, readTentativeRepo, cleanRepository ) +import Darcs.Repository.Flags + ( UpdateWorking(..) + , Compression(..) + , DiffAlgorithm(PatienceDiff) ) +import Darcs.Repository + ( Repository, RepoJob(..), withRepositoryLocation + , createRepository, invalidateIndex, repoLocation + , createPristineDirectoryTree, repoCache + , revertRepositoryChanges, finalizeRepositoryChanges + , applyToWorking, repoLocation, repoCache + , readRepo, readTentativeRepo, cleanRepository + , createRepositoryV2, EmptyRepository(..) + , withUMaskFlag + ) import qualified Darcs.Repository as R( setScriptsExecutable ) +import Darcs.Repository.InternalTypes ( coerceR ) import Darcs.Repository.State( readRecorded ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) -import Darcs.Repository.InternalTypes ( extractCache ) -import Darcs.Repository.HashedRepo ( readHashedPristineRoot, addToTentativeInventory ) +import Darcs.Repository.Hashed + ( tentativelyAddPatch_ + , UpdatePristine(..) + , readHashedPristineRoot + , addToTentativeInventory ) import Darcs.Repository.HashedIO ( cleanHashdir ) -import Darcs.Repository.Prefs( FileType(..) ) +import Darcs.Repository.Prefs( FileType(..), showMotd ) import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2)) -import Darcs.Repository.Motd ( showMotd ) -import Darcs.Util.Lock ( writeBinFile ) import Darcs.Util.External ( fetchFilePS, Cachable(Uncachable) ) import Darcs.Repository.Diff( treeDiff ) import Darcs.UI.External ( catchall ) import Darcs.UI.Flags - ( verbosity, useCache, umask, withWorkingDir, runPatchIndex + ( verbosity, useCache, umask, withWorkingDir, patchIndexNo , DarcsFlag ( NewRepo ) - , getRepourl, patchFormat + , getRepourl, patchFormat, quiet ) import Darcs.UI.Commands ( DarcsCommand(..), amInRepository, nodefaults, putInfo , normalCommand, withStdOpts ) import Darcs.UI.Commands.Util.Tree ( treeHasDir, treeHasFile ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O -#include "impossible.h" +type RepoPatchV1 = V1.RepoPatchV1 V1.Prim +type RepoPatchV2 = V2.RepoPatchV2 V2.Prim + convertDescription :: String convertDescription = "Convert repositories between various formats." @@ -212,46 +225,19 @@ ] convert :: DarcsCommand [DarcsFlag] -convert = SuperCommand { - commandProgramName = "darcs" +convert = SuperCommand + { commandProgramName = "darcs" , commandName = "convert" , commandHelp = "" , commandDescription = convertDescription , commandPrereq = amInRepository - , commandSubCommands = [ normalCommand convertDarcs2, - normalCommand convertExport, - normalCommand convertImport - ] + , commandSubCommands = + [ normalCommand convertDarcs2 + , normalCommand convertExport + , normalCommand convertImport + ] } -convertDarcs2BasicOpts :: DarcsOption a (Maybe String -> O.SetScriptsExecutable -> O.WithWorkingDir -> a) -convertDarcs2BasicOpts = O.reponame ^ O.setScriptsExecutable ^ O.useWorkingDir - -convertDarcs2AdvancedOpts :: DarcsOption a (O.NetworkOptions -> O.WithPatchIndex -> a) -convertDarcs2AdvancedOpts = O.network ^ O.patchIndex - -convertDarcs2Opts :: DarcsOption a - (Maybe String - -> O.SetScriptsExecutable - -> O.WithWorkingDir - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.NetworkOptions - -> O.WithPatchIndex - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts - -convertDarcs2SilentOpts :: DarcsOption a (O.PatchFormat -> a) -convertDarcs2SilentOpts = O.patchFormat - convertDarcs2 :: DarcsCommand [DarcsFlag] convertDarcs2 = DarcsCommand { commandProgramName = "darcs" @@ -262,7 +248,7 @@ , commandExtraArgHelp = ["", "[]"] , commandCommand = toDarcs2 , commandPrereq = \_ -> return $ Right () - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc convertDarcs2AdvancedOpts , commandBasicOptions = odesc convertDarcs2BasicOpts @@ -270,31 +256,11 @@ , commandCheckOptions = ocheck convertDarcs2Opts , commandParseOptions = onormalise convertDarcs2Opts } - -convertExportBasicOpts :: DarcsOption a - (Maybe String -> Maybe String -> Maybe String -> a) -convertExportBasicOpts = O.reponame ^ O.marks - -convertExportAdvancedOpts :: DarcsOption a (O.NetworkOptions -> a) -convertExportAdvancedOpts = O.network - -convertExportOpts :: DarcsOption a - (Maybe String - -> Maybe String - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts + where + convertDarcs2BasicOpts = O.reponame ^ O.setScriptsExecutable ^ O.withWorkingDir + convertDarcs2AdvancedOpts = O.network ^ O.patchIndexNo + convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts + convertDarcs2SilentOpts = O.patchFormat convertExport :: DarcsCommand [DarcsFlag] convertExport = DarcsCommand @@ -306,7 +272,7 @@ , commandExtraArgHelp = [] , commandCommand = fastExport , commandPrereq = amInRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc convertExportAdvancedOpts , commandBasicOptions = odesc convertExportBasicOpts @@ -314,40 +280,10 @@ , commandCheckOptions = ocheck convertExportOpts , commandParseOptions = onormalise convertExportOpts } - -convertImportBasicOpts :: DarcsOption a - (Maybe String - -> O.SetScriptsExecutable - -> O.PatchFormat - -> O.WithWorkingDir - -> a) -convertImportBasicOpts - = O.reponame - ^ O.setScriptsExecutable - ^ O.patchFormat - ^ O.useWorkingDir - -convertImportAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a) -convertImportAdvancedOpts = O.patchIndex - -convertImportOpts :: DarcsOption a - (Maybe String - -> O.SetScriptsExecutable - -> O.PatchFormat - -> O.WithWorkingDir - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.WithPatchIndex - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts + where + convertExportBasicOpts = O.reponame ^ O.marks + convertExportAdvancedOpts = O.network + convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts convertImport :: DarcsCommand [DarcsFlag] convertImport = DarcsCommand @@ -359,7 +295,7 @@ , commandExtraArgHelp = ["[]"] , commandCommand = fastImport , commandPrereq = \_ -> return $ Right () - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc convertImportAdvancedOpts , commandBasicOptions = odesc convertImportBasicOpts @@ -367,15 +303,25 @@ , commandCheckOptions = ocheck convertImportOpts , commandParseOptions = onormalise convertImportOpts } + where + convertImportBasicOpts + = O.reponame + ^ O.setScriptsExecutable + ^ O.patchFormat + ^ O.withWorkingDir + convertImportAdvancedOpts = O.patchIndexNo + convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -toDarcs2 fps opts [inrepodir, outname] = toDarcs2 fps (NewRepo outname:opts) [inrepodir] -toDarcs2 _ opts [inrepodir] = do - +toDarcs2 _ opts' args = do + (inrepodir, opts) <- + case args of + [arg1, arg2] -> return (arg1, NewRepo arg2:opts') + [arg1] -> return (arg1, opts') + _ -> fail "You must provide either one or two arguments." typed_repodir <- ioAbsoluteOrRemote inrepodir let repodir = toPath typed_repodir - --test for converting darcs-2 repository format <- identifyRepoFormat repodir when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format." @@ -385,42 +331,46 @@ vow' <- askUser ("by typing `" ++ vow ++ "': ") when (vow' /= vow) $ fail "User didn't understand the consequences." - unless (parseFlags O.verbosity opts == O.Quiet) $ showMotd repodir + unless (quiet opts) $ showMotd repodir + mysimplename <- makeRepoName opts repodir - createDirectory mysimplename - setCurrentDirectory mysimplename - createRepository PatchFormat2 (withWorkingDir opts) (runPatchIndex opts) - writeBinFile (darcsdir++"/hashed_inventory") "" - withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ V2Job $ \repository -> - withRepositoryDirectory (useCache opts) repodir $ V1Job $ \themrepo -> do - theirstuff <- readRepo themrepo - let patches = mapFL_FL (convertNamed . hopefully) $ newset2FL theirstuff - outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff + withUMaskFlag (umask ? opts) $ withNewDirectory mysimplename $ do + repo <- createRepositoryV2 + (withWorkingDir ? opts) (patchIndexNo ? opts) (O.useCache ? opts) + revertRepositoryChanges repo NoUpdateWorking + + withRepositoryLocation (useCache ? opts) repodir $ V1Job $ \other -> do + theirstuff <- readRepo other + let patches = mapFL_FL (convertNamed . hopefully) $ patchSet2FL theirstuff + outOfOrderTags = catMaybes $ mapRL oot $ patchSet2RL theirstuff where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff then Just (info t, Wrapped.getdeps $ hopefully t) else Nothing fixDep p = case lookup p outOfOrderTags of Just d -> p : concatMap fixDep d Nothing -> [p] - convertOne :: RepoPatchV1 Prim wX wY -> FL (RepoPatchV2 Prim) wX wY - convertOne x | isMerger x = case mergeUnravelled $ publicUnravel x of - Just (FlippedSeal y) -> - case effect y =/\= effect x of - IsEq -> y :>: NilFL - NotEq -> - traceDoc (text "lossy conversion:" $$ - showPatch x) - fromPrims (effect x) - Nothing -> traceDoc (text - "lossy conversion of complicated conflict:" $$ - showPatch x) - fromPrims (effect x) - convertOne (PP x) = fromPrim x :>: NilFL + primV1toV2 = V2.Prim . V1.unPrim + convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY + convertOne x | V1.isMerger x = + let ex = mapFL_FL primV1toV2 (effect x) in + case mergeUnravelled $ map (mapSeal (mapFL_FL primV1toV2)) $ publicUnravel x of + Just (FlippedSeal y) -> + case effect y =/\= ex of + IsEq -> y :>: NilFL + NotEq -> + traceDoc (text "lossy conversion:" $$ + showPatch ForDisplay x) + fromPrims ex + Nothing -> traceDoc (text + "lossy conversion of complicated conflict:" $$ + showPatch ForDisplay x) + fromPrims ex + convertOne (V1.PP x) = fromPrim (primV1toV2 x) :>: NilFL convertOne _ = impossible - convertFL :: FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY + convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY convertFL = concatFL . mapFL_FL convertOne - convertNamed :: WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wX wY - -> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY + convertNamed :: WrappedNamed ('RepoType 'NoRebase) RepoPatchV1 wX wY + -> PatchInfoAnd ('RepoType 'NoRebase) RepoPatchV2 wX wY convertNamed (NormalP n) = n2pia $ NormalP $ adddeps (infopatch (convertInfo $ patch2patchinfo n) $ @@ -428,24 +378,9 @@ (map convertInfo $ concatMap fixDep $ getdeps n) convertInfo n | n `elem` inOrderTags theirstuff = n | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n - applySome xs = do -- TODO this unsafeCoerce hack is because we don't keep track of the repository state properly - -- Really sequence_ $ mapFL applySome below should instead be a repeated add operation - - -- there doesn't seem to be any reason we need to do a merge here. - let repository2 = unsafeCoerce# repository :: Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wA wB wA - Sealed pw <- tentativelyMergePatches repository2 "convert" - YesAllowConflicts NoUpdateWorking - NoExternalMerge NoWantGuiPause - GzipCompression (verbosity opts) - NoReorder - (UseIndex, ScanKnown, MyersDiff) - NilFL xs - finalizeRepositoryChanges repository2 NoUpdateWorking GzipCompression -- this is to clean out pristine.hashed - revertRepositoryChanges repository2 NoUpdateWorking - _ <- revertable $ applyToWorking repository2 (verbosity opts) pw - invalidateIndex repository2 - sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches - invalidateIndex repository - revertable $ createPristineDirectoryTree repository "." (withWorkingDir opts) + + -- Note: we use bunchFL so we can commit every 100 patches + _ <- applyAll opts repo $ bunchFL 100 $ progressFL "Converting patch" patches when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable) R.setScriptsExecutable @@ -455,13 +390,71 @@ `catchall` return () 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."] + where + applyOne :: (RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] + -> W2 (Repository rt p wR) wX + -> PatchInfoAnd rt p wX wY + -> IO (W2 (Repository rt p wR) wY) + applyOne opts (W2 r) x = do + r' <- tentativelyAddPatch_ (updatePristine opts) r + GzipCompression (verbosity ? opts) (updateWorking opts) x + r'' <- withTryAgainMsg $ applyToWorking r' (verbosity ? opts) (effect x) + invalidateIndex r'' + return (W2 r'') -toDarcs2 _ _ _ = fail "You must provide either one or two arguments." + applySome opts (W3 r) xs = do + r' <- unW2 <$> foldFL_M (applyOne opts) (W2 r) xs + -- commit after applying a bunch of patches + finalizeRepositoryChanges r' (updateWorking opts) GzipCompression + revertRepositoryChanges r' (updateWorking opts) + -- finalizeRepositoryChanges and revertRepositoryChanges + -- do not (yet?) return a repo with properly coerced witnesses. + -- We should have + -- + -- > finalizeRepositoryChanges :: ... wR wU wT -> ... wT wU wT + -- + -- and + -- + -- > revertRepositoryChanges :: ... wR wU wT -> ... wR wU wR + -- + -- This is why we must coerce here: + return (W3 (coerceR r')) + applyAll :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] + -> Repository rt p wX wX wX + -> FL (FL (PatchInfoAnd rt p)) wX wY + -> IO (Repository rt p wY wY wY) + applyAll opts r xss = unW3 <$> foldFL_M (applySome opts) (W3 r) xss + + updatePristine :: [DarcsFlag] -> UpdatePristine + updatePristine opts = + case withWorkingDir ? opts of + O.WithWorkingDir -> UpdatePristine + -- this should not be necessary but currently is, because + -- some commands (e.g. send) cannot cope with a missing pristine + -- even if the repo is marked as having no working tree + O.NoWorkingDir -> {- DontUpdatePristineNorRevert -}UpdatePristine + + updateWorking :: [DarcsFlag] -> UpdateWorking + updateWorking opts = + case withWorkingDir ? opts of + O.WithWorkingDir -> YesUpdateWorking + O.NoWorkingDir -> NoUpdateWorking + + withTryAgainMsg :: IO a -> IO a + withTryAgainMsg x = x `clarifyErrors` unlines + [ "An error occurred while applying patches to the working tree." + , "You may have more luck if you supply --no-working-dir." ] + +-- | Need this to make 'foldFL_M' work with a function that changes +-- the last two (identical) witnesses at the same time. +newtype W2 r wX = W2 {unW2 :: r wX wX} + +-- | Similarly for when the function changes all three witnesses. +newtype W3 r wX = W3 {unW3 :: r wX wX wX} + makeRepoName :: [DarcsFlag] -> FilePath -> IO String makeRepoName (NewRepo n:_) _ = do exists <- doesDirectoryExist n @@ -503,7 +496,7 @@ marks <- case parseFlags O.readMarks opts of Nothing -> return emptyMarks Just f -> readMarks f - newMarks <- withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> fastExport' repo marks + newMarks <- withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> fastExport' repo marks case parseFlags O.writeMarks opts of Nothing -> return () Just f -> writeMarks f newMarks @@ -514,7 +507,7 @@ putStrLn "progress (reading repository)" patchset <- readRepo repo marksref <- newIORef marks - let patches = newset2FL patchset + let patches = patchSet2FL patchset tags = inOrderTags patchset mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO () mark p n = liftIO $ do putStrLn $ "mark :" ++ show n @@ -543,7 +536,7 @@ `finally` do putStrLn "progress (cleaning up)" current <- readHashedPristineRoot repo - cleanHashdir (extractCache repo) HashedPristineDir $ catMaybes [current] + cleanHashdir (repoCache repo) HashedPristineDir $ catMaybes [current] putStrLn "progress done" dumpPatches :: (RepoPatch p, ApplyState p ~ Tree) @@ -623,7 +616,7 @@ -> (PatchInfoAnd rt p) x y -> Int -> TreeIO () dumpPatch mark p n = - do dumpBits [ BLC.pack $ "progress " ++ show n ++ ": " ++ piName (info p) + do dumpBits [ BLU.fromString $ "progress " ++ show n ++ ": " ++ piName (info p) , "commit refs/heads/master" ] mark p n dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p @@ -722,14 +715,16 @@ fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fastImport _ opts [outrepo] = - do createDirectory outrepo - withCurrentDirectory outrepo $ do - createRepository (patchFormat opts) (withWorkingDir opts) (runPatchIndex opts) - withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ RepoJob $ \repo -> do - -- TODO implement --dry-run, which would be read-only? - marks <- fastImport' repo emptyMarks - createPristineDirectoryTree repo "." (withWorkingDir opts) - return marks + withUMaskFlag (umask ? opts) $ withNewDirectory outrepo $ do + EmptyRepository repo <- createRepository + (patchFormat ? opts) + (withWorkingDir ? opts) + (patchIndexNo ? opts) + (useCache ? opts) + -- TODO implement --dry-run, which would be read-only? + marks <- fastImport' repo emptyMarks + createPristineDirectoryTree repo "." (withWorkingDir ? opts) + return marks fastImport _ _ _ = fail "I need exactly one output repository." fastImport' :: forall rt p r u . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => @@ -749,8 +744,8 @@ -- sort marks into buckets, since there can be a *lot* of them markpath :: Int -> AnchoredPath markpath n = floatPath (darcsdir "marks") - `appendPath` (Name $ BC.pack $ show (n `div` 1000)) - `appendPath` (Name $ BC.pack $ show (n `mod` 1000)) + `appendPath` (makeName $ show (n `div` 1000)) + `appendPath` (makeName $ show (n `mod` 1000)) makeinfo author message tag = do let (name, log) = case BC.unpack message of @@ -765,16 +760,18 @@ addtag author msg = do info_ <- makeinfo author msg True gotany <- liftIO $ doesFileExist $ darcsdir "tentative_hashed_pristine" - deps <- if gotany then liftIO $ getUncovered `fmap` readTentativeRepo repo + deps <- if gotany then liftIO $ + getUncovered `fmap` + readTentativeRepo repo (repoLocation repo) else return [] - let ident = NilFL :: FL (RepoPatchV2 Prim) cX cX + let ident = NilFL :: FL RepoPatchV2 cX cX patch = NormalP (adddeps (infopatch info_ ident) deps) - void $ liftIO $ addToTentativeInventory (extractCache repo) + void $ liftIO $ addToTentativeInventory (repoCache repo) GzipCompression (n2pia patch) -- processing items updateHashes = do - let nodarcs = \(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir + let nodarcs = \(AnchoredPath (x:_)) _ -> x /= makeName darcsdir hashblobs (File blob@(T.Blob con NoHash)) = do hash <- sha256 `fmap` readBlob blob return $ File (T.Blob con hash) @@ -809,7 +806,7 @@ process :: State p -> Object -> TreeIO (State p) process s (Progress p) = do - liftIO $ putStrLn ("progress " ++ BC.unpack p) + liftIO $ putStrLn ("progress " ++ decodeLocale p) return s process (Toplevel _ _) End = do @@ -826,7 +823,7 @@ if Just what == n then addtag author msg else liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " ++ - head (lines $ BC.unpack msg) + head (lines $ decodeLocale msg) return (Toplevel n b) process (Toplevel n _) (Reset branch from) = @@ -919,7 +916,7 @@ {- current <- updateHashes -} -- why not? (prims :: FL p cX cY) <- return $ fromPrims $ sortCoalesceFL $ reverseRL ps let patch = NormalP (infopatch info_ ((NilFL :: FL p cX cX) +>+ prims)) - void $ liftIO $ addToTentativeInventory (extractCache repo) + void $ liftIO $ addToTentativeInventory (repoCache repo) GzipCompression (n2pia patch) case mark of Nothing -> return () diff --git a/src/Darcs/UI/Commands/Diff.hs b/src/Darcs/UI/Commands/Diff.hs --- a/src/Darcs/UI/Commands/Diff.hs +++ b/src/Darcs/UI/Commands/Diff.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Diff ( diffCommand, getDiffDoc ) where import Prelude () @@ -39,10 +37,9 @@ , execPipeIgnoreError ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags - ( DarcsFlag ( AfterPatch, DiffCmd, LastN ) - , wantGuiPause, useCache, fixSubPaths ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) +import Darcs.UI.Completion ( knownFileArgs ) +import Darcs.UI.Flags ( DarcsFlag, wantGuiPause, useCache, fixSubPaths ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( WantGuiPause (..), DiffAlgorithm(MyersDiff) ) import Darcs.Patch.PatchInfoAnd ( info, n2pia ) @@ -55,22 +52,21 @@ , matchSecondPatchset ) import Darcs.Repository ( withRepository, RepoJob(..), readRepo ) -import Darcs.Repository.State ( readUnrecorded, restrictSubpaths - , readRecorded, unrecordedChanges - , UseIndex(..), ScanKnown(..), applyTreeFilter ) +import Darcs.Repository.State + ( readUnrecorded, restrictSubpaths + , readRecorded, unrecordedChanges + , UseIndex(..), ScanKnown(..), applyTreeFilter + ) import Darcs.Patch.Witnesses.Ordered ( mapRL, (:>)(..), (+>+), RL(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed(..), seal ) import Darcs.Patch ( RepoPatch, IsRepoType, apply, listTouchedFiles, invert, fromPrims ) import Darcs.Patch.Depends ( findCommonWithThem ) import Darcs.Patch.Named.Wrapped ( anonymous ) -import Darcs.Patch.Set ( PatchSet(..), newset2RL ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI ) +import Darcs.Patch.Set ( PatchSet(..), patchSet2RL ) +import Darcs.Patch.Info ( PatchInfo, displayPatchInfo ) import Darcs.Util.Lock ( withTempDir ) -import Darcs.Util.Printer ( Doc, putDoc, vcat, empty, RenderMode(..), ($$) ) - -#include "impossible.h" - +import Darcs.Util.Printer ( Doc, putDoc, vcat, empty, ($$) ) diffDescription :: String diffDescription = "Create a diff between two versions of the repository." @@ -110,43 +106,6 @@ "\n" ++ "If this option is used, `--diff-opts` is ignored.\n" -diffBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> O.ExternalDiff - -> Bool - -> Maybe String - -> Bool - -> a) -diffBasicOpts - = O.matchRange - ^ O.extDiff - ^ O.unidiff - ^ O.workingRepoDir - ^ O.storeInMemory - -diffAdvancedOpts :: DarcsOption a (WantGuiPause -> a) -diffAdvancedOpts = O.pauseForGui - -diffOpts :: DarcsOption a - ([O.MatchFlag] - -> O.ExternalDiff - -> Bool - -> Maybe String - -> Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> WantGuiPause - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts - diffCommand :: DarcsCommand [DarcsFlag] diffCommand = DarcsCommand { commandProgramName = "darcs" @@ -157,7 +116,7 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = diffCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc diffAdvancedOpts , commandBasicOptions = odesc diffBasicOpts @@ -165,11 +124,18 @@ , commandCheckOptions = ocheck diffOpts , commandParseOptions = onormalise diffOpts } + where + diffBasicOpts + = O.matchRange + ^ O.extDiff + ^ O.repoDir + ^ O.storeInMemory + diffAdvancedOpts = O.pauseForGui + diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts -getDiffOpts :: [DarcsFlag] -> [String] -getDiffOpts fs = addUnified $ otherDiffOpts fs where - addUnified = if parseFlags O.unidiff fs then ("-u":) else id - otherDiffOpts = O._diffOpts . parseFlags O.extDiff +getDiffOpts :: O.ExternalDiff -> [String] +getDiffOpts O.ExternalDiff {O.diffOpts=os,O.diffUnified=u} = addUnified os where + addUnified = if u then ("-u":) else id -- | 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 @@ -177,20 +143,21 @@ -- user's diff-command, hence the possibility for failure with an exception. getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String -> Either String (String, [String]) -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":getDiffOpts opts++[f1,f2]) - helper (_:t) = helper t +getDiffCmdAndArgs cmd opts f1 f2 = helper (O.extDiff ? opts) where + helper extDiff = + case O.diffCmd extDiff of + Just 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) + Nothing -> -- if no command specified, use 'diff' + Right (cmd, "-rN":getDiffOpts extDiff++[f1,f2]) diffCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () diffCmd fps opts args - | not (null [i | LastN i <- opts]) && - not (null [p | AfterPatch p <- opts]) = + | not (null (O.matchLast ? opts)) && + not (null (O.matchFrom ? opts)) = fail $ "using --patch and --last at the same time with the 'diff'" ++ " command doesn't make sense. Use --from-patch to create a diff" ++ " from this patch to the present, or use just '--patch' to view" ++ @@ -202,14 +169,16 @@ doDiff opts msubpaths = getDiffDoc opts msubpaths >>= putDoc getDiffDoc :: [DarcsFlag] -> Maybe [SubPath] -> IO Doc -getDiffDoc opts msubpaths = withRepository (useCache opts) $ RepoJob $ \repository -> do +getDiffDoc opts msubpaths = withRepository (useCache ? opts) $ RepoJob $ \repository -> do formerdir <- getCurrentDirectory let thename = takeFileName formerdir patchset <- readRepo repository - unrecorded <- fromPrims `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository msubpaths + unrecorded <- fromPrims `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) + O.NoLookForMoves O.NoLookForReplaces + repository msubpaths unrecorded' <- n2pia `fmap` anonymous unrecorded let matchFlags = parseFlags O.matchRange opts @@ -270,7 +239,7 @@ let pausingForGui = (wantGuiPause opts == YesWantGuiPause) in do when pausingForGui $ putStrLn $ "Running command '" ++ unwords (d_cmd:d_args) ++ "'" - output <- execPipeIgnoreError Encode d_cmd d_args empty + output <- execPipeIgnoreError d_cmd d_args empty when pausingForGui $ askEnter "Hit return to move on..." return output @@ -278,7 +247,7 @@ getDiffInfo :: (IsRepoType rt, RepoPatch p) => [DarcsFlag] -> PatchSet rt p wStart wX -> [PatchInfo] getDiffInfo opts ps = let matchFlags = parseFlags O.matchRange opts - infos = mapRL info . newset2RL + infos = mapRL info . patchSet2RL handle (match_cond, do_match) | match_cond matchFlags = unseal infos (do_match matchFlags ps) | otherwise = infos ps @@ -286,5 +255,5 @@ \\ handle (firstMatch, matchFirstPatchset) changelog :: [PatchInfo] -> Doc -changelog pis = vcat $ map showPatchInfoUI pis +changelog pis = vcat $ map displayPatchInfo pis diff --git a/src/Darcs/UI/Commands/Dist.hs b/src/Darcs/UI/Commands/Dist.hs --- a/src/Darcs/UI/Commands/Dist.hs +++ b/src/Darcs/UI/Commands/Dist.hs @@ -49,37 +49,40 @@ import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry ) import Darcs.Util.External ( fetchFilePS, Cachable( Uncachable ) ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Repository.HashedRepo ( inv2pris ) +import Darcs.Repository.Hashed ( peekPristineHash ) import Darcs.Repository.HashedIO ( pathsAndContents ) -import Darcs.Repository.InternalTypes ( Repository (..) ) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B -import Darcs.UI.Flags - ( DarcsFlag(Verbose, Quiet, DistName, DistZip, SetScriptsExecutable), useCache ) +import Darcs.UI.Flags as F ( DarcsFlag, useCache ) +import qualified Darcs.UI.Flags as F ( setScriptsExecutable ) import Darcs.UI.Options - ( DarcsOption, (^), oid, odesc, ocheck, onormalise - , defaultFlags, parseFlags + ( (^), oid, odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) +import Darcs.UI.Commands + ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository + , putVerbose, putInfo + ) +import Darcs.UI.Completion ( noArgs ) import Darcs.Util.Lock ( withTempDir ) import Darcs.Patch.Match ( haveNonrangeMatch ) import Darcs.Repository.Match ( getNonrangeMatch ) -import Darcs.Repository ( withRepository, withRepositoryDirectory, RepoJob(..), - setScriptsExecutable, repoPatchType, +import Darcs.Repository ( withRepository, withRepositoryLocation, RepoJob(..), + setScriptsExecutable, repoPatchType, repoCache, createPartialsPristineDirectoryTree ) import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Util.DateTime ( getCurrentTime, toSeconds ) import Darcs.Util.Path ( AbsolutePath, toFilePath ) import Darcs.Util.File ( withCurrentDirectory ) +import Darcs.Util.Printer ( text, vcat ) distDescription :: String distDescription = "Create a distribution archive." - distHelp :: String distHelp = unlines [ "`darcs dist` creates a compressed archive in the repository's root" @@ -99,42 +102,6 @@ , "If `--zip` is used, matchers and the predist command are ignored." ] -distBasicOpts :: DarcsOption a - (Maybe String - -> Bool - -> Maybe String - -> [O.MatchFlag] - -> O.SetScriptsExecutable - -> Bool - -> a) -distBasicOpts - = O.distname - ^ O.distzip - ^ O.workingRepoDir - ^ O.matchUpToOne - ^ O.setScriptsExecutable - ^ O.storeInMemory - -distOpts :: DarcsOption a - (Maybe String - -> Bool - -> Maybe String - -> [O.MatchFlag] - -> O.SetScriptsExecutable - -> Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -distOpts = distBasicOpts `withStdOpts` oid - dist :: DarcsCommand [DarcsFlag] dist = DarcsCommand { commandProgramName = "darcs" @@ -145,7 +112,7 @@ , commandExtraArgHelp = [] , commandCommand = distCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc distBasicOpts @@ -153,16 +120,22 @@ , commandCheckOptions = ocheck distOpts , commandParseOptions = onormalise distOpts } + where + distBasicOpts + = O.distname + ^ O.distzip + ^ O.repoDir + ^ O.matchUpToOne + ^ O.setScriptsExecutable + ^ O.storeInMemory + distOpts = distBasicOpts `withStdOpts` oid -distCmd :: (AbsolutePath, AbsolutePath) - -> [DarcsFlag] - -> [String] - -> IO () -distCmd _ opts _ | DistZip `elem` opts = doFastZip opts -distCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repository -> do +distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () +distCmd _ opts _ | O.distzip ? opts = doFastZip opts +distCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \repository -> do let matchFlags = parseFlags O.matchUpToOne opts formerdir <- getCurrentDirectory - let distname = getDistName formerdir [x | DistName x <- opts] + let distname = getDistName formerdir (O.distname ? opts) predist <- getPrefval "predist" let resultfile = formerdir distname ++ ".tar.gz" withTempDir "darcsdist" $ \tempdir -> do @@ -174,15 +147,15 @@ ec <- case predist of Nothing -> return ExitSuccess Just pd -> system pd if ec == ExitSuccess - then - do - withCurrentDirectory ddir $ - when (SetScriptsExecutable `elem` opts) setScriptsExecutable - doDist opts tempdir ddir resultfile - else - do - putStrLn "Dist aborted due to predist failure" - exitWith ec + then do + withCurrentDirectory ddir $ + when + (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) + setScriptsExecutable + doDist opts tempdir ddir resultfile + else do + putStrLn "Dist aborted due to predist failure" + exitWith ec -- | This function performs the actual distribution action itself. @@ -193,37 +166,36 @@ setCurrentDirectory (toFilePath tempdir) let safeddir = safename $ takeFileName $ toFilePath ddir entries <- pack "." [safeddir] - when (Verbose `elem` opts) $ putStr $ unlines $ map entryPath entries + putVerbose opts $ vcat $ map (text . entryPath) entries writeFile resultfile $ compress $ write entries - when (Quiet `notElem` opts) $ putStrLn $ "Created dist as " ++ resultfile + putInfo opts $ text $ "Created dist as " ++ resultfile where safename n@(c:_) | isAlphaNum c = n safename n = "./" ++ n -getDistName :: FilePath -> [String] -> FilePath -getDistName _ (dn:_) = dn +getDistName :: FilePath -> Maybe String -> FilePath +getDistName _ (Just dn) = dn getDistName currentDirectory _ = takeFileName currentDirectory -doFastZip :: [DarcsFlag] - -> IO () +doFastZip :: [DarcsFlag] -> IO () doFastZip opts = do currentdir <- getCurrentDirectory - let distname = getDistName currentdir [x | DistName x <- opts] + let distname = getDistName currentdir (O.distname ? opts) let resultfile = currentdir distname ++ ".zip" doFastZip' opts currentdir (writeFile resultfile) - when (Quiet `notElem` opts) $ putStrLn $ "Created " ++ resultfile + putInfo opts $ text $ "Created " ++ resultfile doFastZip' :: [DarcsFlag] -- ^ Flags/options -> FilePath -- ^ The path to the repository -> (BL.ByteString -> IO a) -- ^ An action to perform on the archive contents -> IO a -doFastZip' opts path act = withRepositoryDirectory (useCache opts) path $ RepoJob $ \(Repo _ _ _ c) -> do - when (SetScriptsExecutable `elem` opts) $ +doFastZip' opts path act = withRepositoryLocation (useCache ? opts) path $ RepoJob $ \repo -> do + when (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $ putStrLn "WARNING: Zip archives cannot store executable flag." - let distname = getDistName path [x | DistName x <- opts] + let distname = getDistName path (O.distname ? opts) i <- fetchFilePS (path darcsdir "hashed_inventory") Uncachable - pristine <- pathsAndContents (distname ++ "/") c (inv2pris i) + pristine <- pathsAndContents (distname ++ "/") (repoCache repo) (peekPristineHash i) epochtime <- toSeconds `fmap` getCurrentTime let entries = [ toEntry filepath epochtime (toLazy contents) | (filepath,contents) <- pristine ] let archive = foldr addEntryToArchive emptyArchive entries diff --git a/src/Darcs/UI/Commands/GZCRCs.hs b/src/Darcs/UI/Commands/GZCRCs.hs --- a/src/Darcs/UI/Commands/GZCRCs.hs +++ b/src/Darcs/UI/Commands/GZCRCs.hs @@ -20,8 +20,6 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.GZCRCs ( gzcrcs , doCRCWarnings @@ -30,7 +28,6 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) import Control.Monad ( when, unless, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Writer ( runWriterT, tell ) @@ -44,25 +41,25 @@ import Darcs.Util.File ( getRecursiveContentsFullPath ) import Darcs.Util.ByteString ( isGZFile, gzDecompress ) import Darcs.Util.Global ( getCRCWarnings, resetCRCWarnings ) -import Darcs.Repository ( Repository, withRepository, RepoJob(..) ) +import Darcs.Repository ( Repository, withRepository, RepoJob(..), repoCache ) -- This command needs access beyond the normal repository APIs (to -- get at the caches and inspect them directly) -- Could move the relevant code into Darcs.Repository modules -- but it doesn't really seem worth it. import Darcs.Repository.Cache ( Cache(..), writable, isThisRepo, hashedFilePath, allHashedDirs ) -import Darcs.Repository.InternalTypes ( extractCache ) import Darcs.Util.Lock ( gzWriteAtomicFilePSs ) -import Darcs.Patch ( RepoPatch ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) -import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Commands + ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository + , putInfo, putVerbose + ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) -import Darcs.UI.Flags - ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ) - , useCache ) +import Darcs.UI.Flags ( DarcsFlag, useCache ) import Darcs.Util.Text ( formatText ) -import Darcs.Util.Printer ( putDocLn, text ) +import Darcs.Util.Printer ( text ) gzcrcsHelp :: String gzcrcsHelp = formatText 80 @@ -112,26 +109,6 @@ gzcrcsDescription = "Check or repair the CRCs of compressed files in the " ++ "repository." -gzcrcsBasicOpts :: DarcsOption a (Maybe O.GzcrcsAction -> Bool -> Maybe String -> a) -gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.workingRepoDir - -gzcrcsOpts :: DarcsOption a - (Maybe O.GzcrcsAction - -> Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -gzcrcsOpts = gzcrcsBasicOpts `withStdOpts` oid - gzcrcs :: DarcsCommand [DarcsFlag] gzcrcs = DarcsCommand { commandProgramName = "darcs" @@ -142,7 +119,7 @@ , commandExtraArgHelp = [] , commandCommand = gzcrcsCmd , commandPrereq = amInRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc gzcrcsBasicOpts @@ -150,19 +127,23 @@ , commandCheckOptions = ocheck gzcrcsOpts , commandParseOptions = onormalise gzcrcsOpts } + where + gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.repoDir + gzcrcsOpts = gzcrcsBasicOpts `withStdOpts` oid gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -gzcrcsCmd _ opts _ | Check `elem` opts || Repair `elem` opts = - withRepository (useCache opts) (RepoJob (gzcrcs' opts)) -gzcrcsCmd _ _ _ = error "You must specify --check or --repair for gzcrcs" +gzcrcsCmd _ opts _ = + case O.gzcrcsActions ? opts of + Nothing -> fail "You must specify --check or --repair for gzcrcs" + Just action -> withRepository (useCache ? opts) (RepoJob (gzcrcs' action opts)) -gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository rt p wR wU wT -> IO () -gzcrcs' opts repo = do +gzcrcs' :: O.GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wT -> IO () +gzcrcs' action opts repo = do -- 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 $ not isJustThisRepo - let Ca locs = extractCache repo + let Ca locs = repoCache repo (_, Any checkFailed) <- runWriterT $ forM_ locs $ \loc -> unless (isJustThisRepo && not (isThisRepo loc)) $ do let isWritable = writable loc @@ -174,7 +155,7 @@ warn <- readIORef warnRelatedRepos when (warn && not (isThisRepo loc)) $ do writeIORef warnRelatedRepos False - putInfo $ + putInfo opts $ text $ "Also checking related repos and caches; use " ++ "--just-this-repo to disable.\n" ++ "Checking " ++ dir @@ -194,12 +175,12 @@ when isCorrupt $ do -- Count of files in current directory tell (Sum 1) - liftIO . putVerbose $ + liftIO . putVerbose opts $ text $ "Corrupt: " ++ file when (isWritable && shouldRepair) $ doRepair file uncompressed when (count > (0 :: Int)) $ do - liftIO . putInfo $ + liftIO . putInfo opts $ text $ "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++ (if shouldRepair @@ -209,12 +190,9 @@ else "") -- Something corrupt somewhere tell (Any True) - when (Check `elem` opts && checkFailed) $ + when (action == O.GzcrcsCheck && checkFailed) $ exitWith (ExitFailure 1) where - [shouldRepair, isQuiet, isVerbose, isJustThisRepo] = zipWith ($) - (elem `fmap` [Repair, Quiet, Verbose, JustThisRepo]) (repeat opts) - putInfo = unless isQuiet . putDocLn . text - putVerbose = when isVerbose . putDocLn . text + shouldRepair = action == O.GzcrcsRepair + isJustThisRepo = O.justThisRepo ? opts doRepair name contents = liftIO $ gzWriteAtomicFilePSs name contents - diff --git a/src/Darcs/UI/Commands/Help.hs b/src/Darcs/UI/Commands/Help.hs --- a/src/Darcs/UI/Commands/Help.hs +++ b/src/Darcs/UI/Commands/Help.hs @@ -34,27 +34,31 @@ ( CommandArgs(..) , CommandControl(..) , normalCommand - , DarcsCommand(..), withStdOpts + , DarcsCommand(..) , WrappedCommand(..) , wrappedCommandName , disambiguateCommands , extractCommands - , getCommandHelp + , getSubcommands , nodefaults - , usage ) import Darcs.UI.External ( viewDoc ) +import Darcs.UI.Usage + ( getCommandHelp + , usage + , subusage + ) import Darcs.Util.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir , environmentHelpLocks ) import Darcs.Patch.Match ( helpOnMatchers ) -import Darcs.Repository.Prefs ( boringFileHelp, binariesFileHelp, environmentHelpHome ) +import Darcs.Repository.Prefs ( environmentHelpHome, prefsFilesHelp ) import Darcs.Util.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Path ( AbsolutePath ) import Control.Arrow ( (***) ) import Data.Char ( isAlphaNum, toLower, toUpper ) import Data.Either ( partitionEithers ) -import Data.List ( groupBy, isPrefixOf, intercalate, nub ) +import Data.List ( groupBy, isPrefixOf, intercalate, nub, lookup ) import Darcs.Util.English ( andClauses ) import Darcs.Util.Printer (text, vcat, vsep, ($$), empty) import Darcs.Util.Printer.Color ( environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite ) @@ -62,8 +66,7 @@ import Version ( version ) import Darcs.Util.Download ( environmentHelpProxy, environmentHelpProxyPassword ) import Darcs.Util.Workaround ( getCurrentDirectory ) -import Darcs.UI.Options ( DarcsOption, defaultFlags, ocheck, onormalise, oid ) -import qualified Darcs.UI.Options.All as O ( StdCmdAction, Verbosity, UseCache ) +import Darcs.UI.Options ( defaultFlags, ocheck, onormalise, oid ) import qualified Darcs.UI.TheCommands as TheCommands helpDescription :: String @@ -75,22 +78,25 @@ "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" -argPossibilities :: [String] -argPossibilities = map wrappedCommandName $ extractCommands commandControlList +-- | Starting from a list of 'CommandControl's, unwrap one level +-- to get a list of command names together with their subcommands. +unwrapTree :: [CommandControl] -> [(String, [CommandControl])] +unwrapTree cs = [ (wrappedCommandName c, subcmds c) | CommandData c <- cs ] + where + subcmds (WrappedCommand sc) = getSubcommands sc -helpOpts :: DarcsOption a - (Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -helpOpts = withStdOpts oid oid +-- | Given a list of (normal) arguments to the help command, produce a list +-- of possible completions for the next (normal) argument. +completeArgs :: [String] -> [String] +completeArgs [] = map fst (unwrapTree commandControlList) ++ extraArgs where + extraArgs = [ "manpage", "markdown", "patterns", "environment" ] +completeArgs (arg:args) = exploreTree arg args commandControlList where + exploreTree cmd cmds cs = + case lookup cmd (unwrapTree cs) of + Nothing -> [] + Just cs' -> case cmds of + [] -> map fst (unwrapTree cs') + sub:cmds' -> exploreTree sub cmds' cs' help :: DarcsCommand [DarcsFlag] help = DarcsCommand @@ -102,13 +108,13 @@ , commandExtraArgHelp = ["[ [DARCS_SUBCOMMAND]] "] , commandCommand = \ x y z -> helpCmd x y z >> exitSuccess , commandPrereq = \_ -> return $ Right () - , commandGetArgPossibilities = return argPossibilities + , commandCompleteArgs = \_ _ -> return . completeArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = [] - , commandDefaults = defaultFlags helpOpts - , commandCheckOptions = ocheck helpOpts - , commandParseOptions = onormalise helpOpts + , commandDefaults = defaultFlags oid + , commandCheckOptions = ocheck oid + , commandParseOptions = onormalise oid } helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () @@ -143,18 +149,21 @@ [] -> Left v es -> Right es -helpCmd _ _ [] = viewDoc $ text $ usage commandControlList +helpCmd _ _ [] = viewDoc $ usage commandControlList helpCmd _ _ (cmd:args) = - let disambiguated = disambiguateCommands commandControlList cmd args - in case disambiguated of + case disambiguateCommands commandControlList cmd args of Left err -> fail err - Right (cmds,_) -> + Right (cmds,as) -> let msg = case cmds of CommandOnly c -> getCommandHelp Nothing c - SuperCommandOnly c -> getCommandHelp Nothing c + SuperCommandOnly c -> + if null as then + getCommandHelp Nothing c + else + text $ "Invalid subcommand!\n\n" ++ subusage c SuperCommandSub c s -> getCommandHelp (Just c) s - in viewDoc $ text msg + in viewDoc $ msg listAvailableCommands :: IO () listAvailableCommands = @@ -168,7 +177,6 @@ putStrLn "--help" putStrLn "--version" putStrLn "--exact-version" - putStrLn "--overview" where isRight (Right _) = True isRight _ = False @@ -263,10 +271,7 @@ unlines commands, unlines environment, ".SH FILES", - ".SS \"_darcs/prefs/binaries\"", - escape $ unlines binariesFileHelp, - ".SS \"_darcs/prefs/boring\"", - escape $ unlines boringFileHelp, + unlines prefFiles, ".SH BUGS", "At http://bugs.darcs.net/ you can find a list of known", "bugs in Darcs. Unknown bugs can be reported at that", @@ -357,15 +362,23 @@ then repl ++ replace find repl (drop (length find) s) else head s : replace find repl (tail s) + prefFiles = concatMap go prefsFilesHelp + where go (f,h) = [".SS \"_darcs/prefs/" ++ f ++ "\"", escape h] + markdownLines :: [String] markdownLines = [ "# Commands", "" , unlines commands - , "# Environment variables" - , "", unlines environment , "# Patterns" - , "", unlines helpOnMatchers ] + , "", unlines helpOnMatchers + , "# Configuration" + , "", unlines prefFiles + , "# Environment variables" + , "", unlines environment ] where + prefFiles = concatMap go prefsFilesHelp + where go (f,h) = ["## `_darcs/prefs/" ++ f ++ "`", "", h] + environment :: [String] environment = intercalate [""] [ renderEnv ks ds | (ks, ds) <- environmentHelp ] @@ -395,12 +408,12 @@ where opts2 = commandAdvancedOptions c environmentHelpEditor :: ([String], [String]) -environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[ +environmentHelpEditor = (["DARCS_EDITOR", "VISUAL", "EDITOR"],[ "To edit a patch description of email comment, Darcs will invoke an", "external editor. Your preferred editor can be set as any of the", - "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.", - "If none of these are set, vi(1) is used. If vi crashes or is not", - "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are", + "environment variables $DARCS_EDITOR, $VISUAL or $EDITOR.", + "If none of these are set, nano is used. If nano crashes or is not", + "found in your PATH, vi, emacs, emacs -nw and (on Windows) edit are", "each tried in turn."]) environmentHelpPager :: ([String], [String]) @@ -412,8 +425,8 @@ environmentHelpTimeout :: ([String], [String]) environmentHelpTimeout = (["DARCS_CONNECTION_TIMEOUT"],[ "Set the maximum time in seconds that darcs allows and connection to", - "take. If the variable is not specified the default are 30 seconds. This", - "option only works with curl."]) + "take. If the variable is not specified the default are 30 seconds.", + "This option only works with curl."]) -- | There are two environment variables that we do not document: -- - DARCS_USE_ISPRINT: deprecated, use DARCS_DONT_ESCAPE_ISPRINT. diff --git a/src/Darcs/UI/Commands/Init.hs b/src/Darcs/UI/Commands/Init.hs --- a/src/Darcs/UI/Commands/Init.hs +++ b/src/Darcs/UI/Commands/Init.hs @@ -23,18 +23,15 @@ import Prelude hiding ( (^) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amNotInRepository, putInfo ) -import Darcs.UI.Flags ( DarcsFlag( WorkRepoDir ), withWorkingDir, patchFormat, runPatchIndex ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Flags ( DarcsFlag( WorkRepoDir ) ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O - ( patchFormat, useWorkingDir, workingRepoDir, patchIndex, hashed - , PatchFormat, WithWorkingDir, WithPatchIndex - , StdCmdAction, Verbosity, UseCache, PatchFormat(..) - ) import Darcs.UI.Options.All ( ) import Darcs.Util.Printer ( text ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Text ( quote ) -import Darcs.Repository ( createRepository ) +import Darcs.Repository ( createRepository, withUMaskFlag ) initializeDescription :: String initializeDescription = "Create an empty repository." @@ -55,31 +52,6 @@ "\n" ++ "Initialize is commonly abbreviated to `init`.\n" -initBasicOpts :: DarcsOption a (O.PatchFormat -> O.WithWorkingDir -> Maybe String -> a) -initBasicOpts = O.patchFormat ^ O.useWorkingDir ^ O.workingRepoDir - -initAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> () -> a) -initAdvancedOpts = O.patchIndex ^ O.hashed - -initOpts :: DarcsOption a - (O.PatchFormat - -> O.WithWorkingDir - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.WithPatchIndex - -> () - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -initOpts = initBasicOpts `withStdOpts` initAdvancedOpts - initialize :: DarcsCommand [DarcsFlag] initialize = DarcsCommand { commandProgramName = "darcs" @@ -90,7 +62,7 @@ , commandExtraArgHelp = ["[]"] , commandPrereq = \_ -> return $ Right () , commandCommand = initializeCmd - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc initAdvancedOpts , commandBasicOptions = odesc initBasicOpts @@ -98,16 +70,25 @@ , commandCheckOptions = ocheck initOpts , commandParseOptions = onormalise initOpts } + where + initBasicOpts = O.patchFormat ^ O.withWorkingDir ^ O.repoDir + initAdvancedOpts = O.patchIndexNo ^ O.hashed + initOpts = initBasicOpts `withStdOpts` initAdvancedOpts initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () initializeCmd aps opts [outname] | null [ () | WorkRepoDir _ <- opts ] = initializeCmd aps (WorkRepoDir outname:opts) [] -initializeCmd _ opts [] = do - location <- amNotInRepository opts - case location of - Left msg -> fail $ "Unable to " ++ quote ("darcs " ++ commandName initialize) - ++ " here.\n\n" ++ msg - Right () -> do - createRepository (patchFormat opts) (withWorkingDir opts) (runPatchIndex opts) - putInfo opts $ text "Repository initialized." +initializeCmd _ opts [] = + withUMaskFlag (O.umask ? opts) $ do + location <- amNotInRepository opts + case location of + Left msg -> fail $ "Unable to " ++ quote ("darcs " ++ commandName initialize) + ++ " here.\n\n" ++ msg + Right () -> do + _ <- createRepository + (O.patchFormat ? opts) + (O.withWorkingDir ? opts) + (O.patchIndexNo ? opts) + (O.useCache ? opts) + putInfo opts $ text "Repository initialized." initializeCmd _ _ _ = fail "You must provide 'initialize' with either zero or one argument." diff --git a/src/Darcs/UI/Commands/Log.hs b/src/Darcs/UI/Commands/Log.hs --- a/src/Darcs/UI/Commands/Log.hs +++ b/src/Darcs/UI/Commands/Log.hs @@ -15,8 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, PatternGuards #-} - +{-# LANGUAGE PatternGuards #-} module Darcs.UI.Commands.Log ( changes, log @@ -26,7 +25,6 @@ import Prelude () import Darcs.Prelude -import Unsafe.Coerce (unsafeCoerce) import Data.List ( intersect, sort, nub, find ) import Data.Maybe ( fromMaybe, fromJust, isJust ) import Control.Arrow ( second ) @@ -36,58 +34,57 @@ import Darcs.UI.PrintPatch ( showFriendly ) import Darcs.Patch.PatchInfoAnd ( fmapFLPIAP, hopefullyM, info ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository ) +import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags - ( DarcsFlag(GenContext, - MachineReadable, Count, Interactive, - NumberPatches, XMLOutput, Summary, - Verbose, Debug, NoPatchIndexFlag) - , doReverse, showChangesOnlyToFiles - , useCache, maxCount, umask - , verbosity, isUnified, isInteractive, hasSummary + ( DarcsFlag + , changesReverse, onlyToFiles + , useCache, maxCount, hasXmlOutput + , verbosity, withContext, isInteractive, verbose , fixSubPaths, getRepourl ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( SubPath(), toFilePath, fp2fn, fn2fp, normPath, AbsolutePath, simpleSubPath ) import Darcs.Repository ( PatchSet, PatchInfoAnd, - withRepositoryDirectory, RepoJob(..), + withRepositoryLocation, RepoJob(..), readRepo, unrecordedChanges, withRepoLockCanFail ) -import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff), UpdateWorking(..) ) +import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff) ) import Darcs.Util.Lock ( withTempDir ) -import Darcs.Patch.Set ( PatchSet(..), newset2RL ) +import Darcs.Patch.Set ( PatchSet(..), patchSet2RL ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.FileHunk ( IsHunk ) -import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo ) +import Darcs.Patch.Info ( toXml, toXmlShort, showPatchInfo, displayPatchInfo, escapeXML, PatchInfo ) import Darcs.Patch.Depends ( findCommonWithThem ) import Darcs.Patch.Bundle( contextPatches ) import Darcs.Patch.Prim ( PrimPatchBase ) -import Darcs.Patch.Show ( ShowPatch ) +import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) ) import Darcs.Patch.TouchesFiles ( lookTouch ) import Darcs.Patch.Type ( PatchType(PatchType) ) import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch ( IsRepoType, invert, xmlSummary, description, effectOnFilePaths, listTouchedFiles, showPatch ) -import Darcs.Patch.Named.Wrapped ( (:~:)(..) ) +import Darcs.Patch.Named.Wrapped ( (:~:)(..), getdeps ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), RL(..), filterOutFLFL, filterRL, reverseFL, (:>)(..), mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Match ( MatchFlag , firstMatch , secondMatch - , matchAPatchread + , matchAPatch , haveNonrangeMatch , matchFirstPatchset , matchSecondPatchset ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Util.Printer ( Doc, simplePrinters, (<+>), prefix, text, vcat, - vsep, (<>), ($$), errorDoc, insertBeforeLastline, empty, RenderMode(..) ) + vsep, (<>), ($$), errorDoc, insertBeforeLastline, empty ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( setProgressMode, debugMessage ) import Darcs.Util.URL ( isValidLocalPath ) @@ -105,56 +102,6 @@ ++ logHelp' ++ logHelp'' -logBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Int - -> Bool - -> Maybe O.ChangesFormat - -> Maybe O.Summary - -> Bool - -> Maybe String - -> Maybe String - -> Maybe Bool - -> a) -logBasicOpts - = O.matchSeveralOrRange - ^ O.matchMaxcount - ^ O.onlyToFiles - ^ O.changesFormat - ^ O.summary - ^ O.changesReverse - ^ O.possiblyRemoteRepo - ^ O.workingRepoDir - ^ O.interactive -- False - -logAdvancedOpts :: DarcsOption a (O.NetworkOptions -> O.WithPatchIndex -> a) -logAdvancedOpts = O.network ^ O.patchIndexYes - -logOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Int - -> Bool - -> Maybe O.ChangesFormat - -> Maybe O.Summary - -> Bool - -> Maybe String - -> Maybe String - -> Maybe Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.NetworkOptions - -> O.WithPatchIndex - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -logOpts = logBasicOpts `withStdOpts` logAdvancedOpts - log :: DarcsCommand [DarcsFlag] log = DarcsCommand { commandProgramName = "darcs" @@ -163,7 +110,7 @@ , commandDescription = "List patches in the repository." , commandExtraArgs = -1 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] - , commandGetArgPossibilities = return [] + , commandCompleteArgs = knownFileArgs , commandCommand = logCmd , commandPrereq = findRepository , commandArgdefaults = nodefaults @@ -173,10 +120,23 @@ , commandCheckOptions = ocheck logOpts , commandParseOptions = onormalise logOpts } + where + logBasicOpts + = O.matchSeveralOrRange + ^ O.maxCount + ^ O.onlyToFiles + ^ O.changesFormat + ^ O.summary + ^ O.changesReverse + ^ O.possiblyRemoteRepo + ^ O.repoDir + ^ O.interactive + logAdvancedOpts = O.network ^ O.patchIndexYes + logOpts = logBasicOpts `withStdOpts` logAdvancedOpts logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd fps opts args - | GenContext `elem` opts = if not . null $ args + | O.changesFormat ? opts == Just O.GenContext = if not . null $ args then fail "log --context cannot accept other arguments" else logContext opts | hasRemoteRepo opts = do @@ -191,10 +151,10 @@ fs <- fixSubPaths fps args case fs of [] -> putStrLn "No valid arguments were given, nothing to do." - _ -> do unless (Interactive `elem` opts) - $ unless (NoPatchIndexFlag `elem` opts) - $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) - $ RepoJob attemptCreatePatchIndex + _ -> do unless (isInteractive False opts) + $ when (O.patchIndexNo ? opts == O.YesPatchIndex) + $ withRepoLockCanFail (useCache ? opts) + $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo) showLog opts $ Just $ nub $ sort fs maybeNotNull :: [a] -> Maybe [a] @@ -215,41 +175,43 @@ showLog :: [DarcsFlag] -> Maybe [SubPath] -> IO () showLog opts files = let repodir = fromMaybe "." (getRepourl opts) in - withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repository -> do - unless (Debug `elem` opts) $ setProgressMode False + withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do + unless (O.debug ? opts) $ setProgressMode False Sealed unrec <- case files of Nothing -> return $ Sealed NilFL - Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository files + Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) + O.NoLookForMoves O.NoLookForReplaces + repository files `catch` \(_ :: IOException) -> return (Sealed NilFL) -- this is triggered when repository is remote + debugMessage "About to read the repository..." + patches <- readRepo repository + debugMessage "Done reading the repository." let normfp = fn2fp . normPath . fp2fn undoUnrecordedOnFPs = effectOnFilePaths (invert unrec) recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files filtered_changes p = maybe_reverse <$> getLogInfo - (maxCount opts) + (maxCount ? opts) (parseFlags O.matchSeveralOrRange opts) - (showChangesOnlyToFiles opts) + (onlyToFiles ? opts) recFiles - (maybeFilterPatches repository) + (maybeFilterPatches repository patches) p - debugMessage "About to read the repository..." - patches <- readRepo repository - debugMessage "Done reading the repository." - if Interactive `elem` opts + if isInteractive False opts then do (fp_and_fs, _, _) <- filtered_changes patches let fp = map fst fp_and_fs viewChanges (logPatchSelOpts opts) fp - else do let header = if isJust files && XMLOutput `notElem` opts + else do let header = if isJust files && hasXmlOutput opts then text $ "Changes to "++unwords (fromJust recFiles)++":\n" else empty debugMessage "About to print the patches..." - let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters + let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters ps <- readRepo repository -- read repo again to prevent holding onto -- values forced by filtered_changes logOutput <- changelog opts ps `fmap` filtered_changes patches - viewDocWith printers Encode $ header $$ logOutput - where maybe_reverse (xs,b,c) = if doReverse opts + viewDocWith printers $ header $$ logOutput + where maybe_reverse (xs,b,c) = if changesReverse ? opts then (reverse xs, b, c) else (xs, b, c) @@ -302,7 +264,7 @@ then matchSecondPatchset matchFlags ps else Sealed ps pf = if haveNonrangeMatch (PatchType :: PatchType rt p) matchFlags - then matchAPatchread matchFlags + then matchAPatch matchFlags else \_ -> True filterOutUnrelatedChanges (pfs, renames, doc) @@ -315,7 +277,7 @@ unrelated fs p -- If the change does not affect the patches we are looking at, -- we ignore the difference between the two states. - | null $ fs `intersect` listTouchedFiles p = unsafeCoerce IsEq + | null $ fs `intersect` listTouchedFiles p = unsafeCoerceP IsEq | otherwise = NotEq -- | Take a list of filenames and patches and produce a list of patches that @@ -350,7 +312,7 @@ else case hopefullyM hp of Nothing -> do let err = text "Can't find patches prior to:" - $$ showPatchInfo (info hp) + $$ displayPatchInfo (info hp) return ([], renames, Just err) Just p -> case lookTouch (Just renames) fs (invert p) of @@ -382,39 +344,48 @@ -> ([(Sealed2 (PatchInfoAnd rt p), [FilePath])], [(FilePath, FilePath)], Maybe Doc) -> Doc changelog opts patchset (pis_and_fs, createdAsFs, mbErr) - | Count `elem` opts = text $ show $ length pis_and_fs - | XMLOutput `elem` opts = + | O.changesFormat ? opts == Just O.CountPatches = text $ show $ length pis_and_fs + | hasXmlOutput opts = text "" $$ vcat created_as_xml $$ vcat actual_xml_changes $$ text "" - | Summary `elem` opts || Verbose `elem` opts = + | O.yes (O.summary ? opts) || verbose opts = mbAppendErr $ vsep (map (number_patch change_with_summary) pis) | otherwise = mbAppendErr $ vsep (map (number_patch description') pis) where mbAppendErr = maybe id (\err -> ($$ err)) mbErr change_with_summary :: Sealed2 (PatchInfoAnd rt p) -> Doc change_with_summary (Sealed2 hp) - | Just p <- hopefullyM hp = if MachineReadable `elem` opts - then showPatch p - else showFriendly (verbosity opts) (hasSummary O.NoSummary opts) p - | otherwise = description hp - $$ indent (text "[this patch is unavailable]") + | Just p <- hopefullyM hp = + if O.changesFormat ? opts == Just O.MachineReadable + then showPatch ForStorage p + else showFriendly (verbosity ? opts) (O.summary ? opts) p + | otherwise = description hp $$ indent (text "[this patch is unavailable]") - xml_with_summary (Sealed2 hp) - | Just p <- hopefullyM hp = insertBeforeLastline - (toXml $ info hp) (indent $ xmlSummary p) + xml_with_summary (Sealed2 hp) | Just p <- hopefullyM hp = + let + deps = getdeps p + xmlDependencies = + text "" + $$ vcat (map (indent . toXmlShort) deps) + $$ text "" + summary | deps == [] = indent $ xmlSummary p + | otherwise = indent $ xmlDependencies $$ xmlSummary p + in + insertBeforeLastline (toXml $ info hp) summary xml_with_summary (Sealed2 hp) = toXml (info hp) indent = prefix " " - actual_xml_changes = if Summary `elem` opts - then map xml_with_summary pis - else map (toXml . unseal2 info) pis + actual_xml_changes = + case O.summary ? opts of + O.YesSummary -> map xml_with_summary pis + O.NoSummary -> map (toXml . unseal2 info) pis created_as_xml = map create createdAsFs where create rename@(_, as) = createdAsXml (first_change_of as) rename -- We need to reorder the patches when they haven't been reversed -- already, so that we find the *first* patch that modifies a given -- file, not the last (by default, the list is oldest->newest). - reorderer = if not (doReverse opts) then reverse else id + reorderer = if not (changesReverse ? opts) then reverse else id oldest_first_pis_and_fs = reorderer pis_and_fs couldnt_find fn = error $ "Couldn't find first patch affecting " ++ fn ++ " in pis_and_fs" @@ -422,13 +393,13 @@ find_first_change_of fn = fromMaybe (couldnt_find fn) (mb_first_change_of fn) first_change_of = unseal2 info . fst . find_first_change_of - number_patch f x = if NumberPatches `elem` opts + number_patch f x = if O.changesFormat ? opts == Just O.NumberPatches then case get_number x of Just n -> text (show n++":") <+> f x Nothing -> f x else f x get_number :: Sealed2 (PatchInfoAnd re p) -> Maybe Int - get_number (Sealed2 y) = gn 1 (newset2RL patchset) + get_number (Sealed2 y) = gn 1 (patchSet2RL patchset) where iy = info y gn :: Int -> RL (PatchInfoAnd rt p) wStart wY -> Maybe Int gn n (bs:<:b) | seq n (info b) == iy = Just n @@ -452,12 +423,12 @@ logContext :: [DarcsFlag] -> IO () logContext opts = do let repodir = fromMaybe "." $ getRepourl opts - withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repository -> do + withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do (_ :> ps') <- contextPatches `fmap` readRepo repository let pis = mapRL seal2 ps' let header = text "\nContext:\n" - let logOutput = maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc Nothing - viewDocWith simplePrinters Encode $ header $$ logOutput + let logOutput = maybe (vsep $ map (unseal2 (showPatchInfo ForStorage . info)) pis) errorDoc Nothing + viewDocWith simplePrinters $ header $$ logOutput -- | changes is an alias for log changes :: DarcsCommand [DarcsFlag] @@ -475,10 +446,10 @@ logPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions logPatchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveralOrRange flags , S.interactive = isInteractive False flags , S.selectDeps = O.PromptDeps -- option not supported, use default - , S.summary = hasSummary O.NoSummary flags - , S.withContext = isUnified flags + , S.summary = O.summary ? flags + , S.withContext = withContext ? flags } diff --git a/src/Darcs/UI/Commands/MarkConflicts.hs b/src/Darcs/UI/Commands/MarkConflicts.hs --- a/src/Darcs/UI/Commands/MarkConflicts.hs +++ b/src/Darcs/UI/Commands/MarkConflicts.hs @@ -15,41 +15,54 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import System.Exit ( exitSuccess ) -import Data.List.Ordered ( nubSort ) +import Data.List.Ordered ( nubSort, isect ) import Control.Monad ( when, unless ) import Control.Exception ( catch, IOException ) import Darcs.Util.Prompt ( promptYorn ) -import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) -import Darcs.Util.Printer( putDocLn, putDocLnWith, text, redText, ($$) ) -import Darcs.Util.Printer.Color (fancyPrinters) +import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, simpleSubPath ) +import Darcs.Util.Printer + ( Doc, putDocLnWith, text, redText, debugDocLn, vsep, (<>), (<+>), ($$) ) +import Darcs.Util.Printer.Color ( fancyPrinters ) +import Darcs.Util.Text ( pathlist ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag, diffingOpts, verbosity, dryRun, umask, useCache ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Commands + ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo ) +import Darcs.UI.Commands.Util ( filterExistingPaths ) +import Darcs.UI.Completion ( knownFileArgs ) +import Darcs.UI.Flags + ( DarcsFlag, diffingOpts, verbosity, dryRun, umask + , useCache, fixSubPaths ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O + import Darcs.Repository.Flags ( UpdateWorking (..) ) -import Darcs.Repository ( withRepoLock, RepoJob(..), addToPending, - applyToWorking, - readRepo, unrecordedChanges, Repository - ) -import Darcs.Patch ( invert, PrimOf, listTouchedFiles ) -import Darcs.Patch.Witnesses.Ordered ( FL(..) ) +import Darcs.Repository + ( withRepoLock + , RepoJob(..) + , addToPending + , applyToWorking + , readRepo + , unrecordedChanges ) + +import Darcs.Patch ( invert, listTouchedFiles, effectOnFilePaths ) +import Darcs.Patch.Show +import Darcs.Patch.TouchesFiles ( chooseTouching ) +import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Repository.Resolution ( patchsetConflictResolutions ) -#include "impossible.h" +-- * The mark-conflicts command + markconflictsDescription :: String markconflictsDescription = "Mark unresolved conflicts in working tree, for manual resolution." @@ -72,61 +85,25 @@ ,"However, you might revert or manually delete these markers without" ,"actually resolving the conflict. In this case, `darcs mark-conflicts`" ,"is useful to show where are the unresolved conflicts. It is also" - ,"useful if `darcs apply` is called with `--apply-conflicts`," - ,"where conflicts aren't marked initially." + ,"useful if `darcs apply` or `darcs pull` is called with" + ,"`--allow-conflicts`, where conflicts aren't marked initially." ,"" ,"Unless you use the `--dry-run` flag, any unrecorded changes to the" - ,"working tree WILL be lost forever when you run this command!" + ,"affected files WILL be lost forever when you run this command!" ,"You will be prompted for confirmation before this takes place." ] -markconflictsBasicOpts :: DarcsOption a - (O.UseIndex - -> Maybe String - -> O.DiffAlgorithm - -> O.DryRun - -> O.XmlOutput - -> a) -markconflictsBasicOpts - = O.useIndex - ^ O.workingRepoDir - ^ O.diffAlgorithm - ^ O.dryRunXml - -markconflictsAdvancedOpts :: DarcsOption a (O.UMask -> a) -markconflictsAdvancedOpts = O.umask - -markconflictsOpts :: DarcsOption a - (O.UseIndex - -> Maybe String - -> O.DiffAlgorithm - -> O.DryRun - -> O.XmlOutput - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -markconflictsOpts = markconflictsBasicOpts `withStdOpts` markconflictsAdvancedOpts - markconflicts :: DarcsCommand [DarcsFlag] markconflicts = DarcsCommand { commandProgramName = "darcs" , commandName = "mark-conflicts" , commandHelp = markconflictsHelp , commandDescription = markconflictsDescription - , commandExtraArgs = 0 - , commandExtraArgHelp = [] + , commandExtraArgs = -1 + , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = markconflictsCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc markconflictsAdvancedOpts , commandBasicOptions = odesc markconflictsBasicOpts @@ -134,33 +111,223 @@ , commandCheckOptions = ocheck markconflictsOpts , commandParseOptions = onormalise markconflictsOpts } + where + markconflictsBasicOpts + = O.useIndex + ^ O.repoDir + ^ O.diffAlgorithm + ^ O.dryRunXml + markconflictsAdvancedOpts = O.umask + markconflictsOpts = markconflictsBasicOpts `withStdOpts` markconflictsAdvancedOpts markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -markconflictsCmd _ opts [] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do - pend <- unrecordedChanges (diffingOpts opts) repository Nothing - r <- readRepo repository - Sealed res <- return $ patchsetConflictResolutions r - case nubSort $ listTouchedFiles res of - [] -> putStrLn "No conflicts to mark." >> exitSuccess - cfs -> putDocLnWith fancyPrinters $ - redText "Conflicts found in the following files:" $$ text (unlines cfs) - when (dryRun opts == O.YesDryRun) $ do - putDocLn $ text "Conflicts will not be marked: this is a dry run." +markconflictsCmd fps opts args = do + paths <- if null args then return Everything else sps2ps <$> fixSubPaths fps args -- Applicative IO + debugDocLn $ "::: paths =" <+> (text . show) paths + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do + +{- + What we do here: + * read the unrecorded changes (all of them) + * extract functions representing path rename effects from unrecorded + * convert argument paths to pre-pending + * read conflict resolutions that touch pre-pending argument paths + * affected paths = intersection of paths touched by resolutions + and pre-pending argument paths + * for these paths, revert pending changes + * apply the (filtered, see above) conflict resolutions + + Technical side-note: + Ghc can't handle pattern bindings for existentials. So 'let' is out, + one has to use 'case expr of var ->' or 'do var <- return expr'. + Case is clearer but do-notation does not increase indentation depth. + So we use case for small-scope bindings and <-/return when the scope + is a long do block. +-} + + let (useidx, scan, _) = diffingOpts opts + verb = verbosity ? opts + classified_paths <- + traverse (filterExistingPaths repository verb useidx scan O.NoLookForMoves) paths + + unrecorded <- unrecordedChanges (diffingOpts opts) + O.NoLookForMoves O.NoLookForReplaces + repository (fromOnly Everything) + + let forward_renames = liftToPathSet (effectOnFilePaths unrecorded) + backward_renames = liftToPathSet (effectOnFilePaths (invert unrecorded)) + existing_paths = fmap snd classified_paths + pre_pending_paths = backward_renames existing_paths + debugDocLn $ "::: pre_pending_paths =" <+> (text . show) pre_pending_paths + + r <- readRepo repository + Sealed res <- case patchsetConflictResolutions r of + Sealed raw_res -> do + let raw_res_paths = fps2ps (listTouchedFiles raw_res) + debugDocLn $ "::: raw_res_paths =" <+> (text . show) raw_res_paths + return $ chooseTouching (ps2fps pre_pending_paths) raw_res + let res_paths = fps2ps (listTouchedFiles res) + debugDocLn $ "::: res_paths =" <+> (text . show) res_paths + + let affected_paths = isectPathSet res_paths pre_pending_paths + debugDocLn $ "::: affected_paths =" <+> (text . show) affected_paths + + when (affected_paths == Only []) $ do + putInfo opts "No conflicts to mark." exitSuccess - let undoUnrec :: FL (PrimOf p) wR wU -> IO (Repository rt p wR wR wR) - undoUnrec NilFL = return repository - undoUnrec pend' = - do putStrLn ("This will trash any unrecorded changes"++ - " in the working directory.") - confirmed <- promptYorn "Are you sure? " - unless confirmed exitSuccess - applyToWorking repository (verbosity opts) (invert pend') `catch` \(e :: IOException) -> - bug ("Can't undo pending changes!" ++ show e) - repository' <- undoUnrec pend - withSignalsBlocked $ - do addToPending repository' YesUpdateWorking res - _ <- applyToWorking repository' (verbosity opts) res `catch` \(e :: IOException) -> - bug ("Problem marking conflicts in mark-conflicts!" ++ show e) - return () - putStrLn "Finished marking conflicts." -markconflictsCmd _ _ _ = impossible + + to_revert <- unrecordedChanges (diffingOpts opts) + O.NoLookForMoves O.NoLookForReplaces + repository (fromOnly affected_paths) + + let post_pending_affected_paths = forward_renames affected_paths + putInfo opts $ "Marking conflicts in:" <+> showPathSet post_pending_affected_paths <> "." + + debugDocLn $ "::: to_revert =" $$ vsep (mapFL displayPatch to_revert) + debugDocLn $ "::: res = " $$ vsep (mapFL displayPatch res) + when (O.yes (dryRun ? opts)) $ do + putInfo opts $ "Conflicts will not be marked: this is a dry run." + exitSuccess + + repository' <- case to_revert of + NilFL -> return repository + _ -> do + -- TODO: + -- (1) create backups for all files where we revert changes + -- (2) try to add the reverted stuff to the unrevert bundle + -- after (1) and (2) is done we can soften the warning below + putDocLnWith fancyPrinters $ + "Warning: This will revert all unrecorded changes in:" + <+> showPathSet post_pending_affected_paths <> "." + $$ redText "These changes will be LOST." + confirmed <- promptYorn "Are you sure? " + unless confirmed exitSuccess + +{- -- copied from Revert.hs, see comment (2) above + debugMessage "About to write the unrevert file." + case commute (norevert:>p) of + Just (p':>_) -> writeUnrevert repository p' recorded NilFL + Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL + debugMessage "About to apply to the working directory." +-} + + let to_add = invert to_revert + addToPending repository YesUpdateWorking to_add + applyToWorking repository (verbosity ? opts) to_add `catch` \(e :: IOException) -> + bug ("Can't undo pending changes!" ++ show e) + withSignalsBlocked $ + do addToPending repository' YesUpdateWorking res + _ <- applyToWorking repository' (verbosity ? opts) res `catch` \(e :: IOException) -> + bug ("Problem marking conflicts in mark-conflicts!" ++ show e) + return () + putInfo opts "Finished marking conflicts." + +-- * Generic 'PathSet' support + +{- $SupportCode + +What follows is generic support code for working with argument path lists +that are used to restrict operations to a subset of the working or pristine +tree. The rest of Darcs uses two types for this: + + * @'Maybe' ['SubPath']@ + + * @'Maybe' ['FilePath']@ + +The problem with both is the contra-intuitive name 'Nothing', which here +stands for 'Everything'. To make the intended use clearer, we use the 'Only' +type instead (which is is isomorphic to 'Maybe') and the synonym 'PathSet' +defined below. + +These abstractions should get their own module (or become integrated into +Darcs.Util.Path) if and when someone decides to reuse it elsewhere. The +functionality provided is intentionally minimal and light-weight. +-} + +-- | 'Only' is isomorphic to 'Maybe' but with the opposite semantics. +-- +-- About the name: I like the data constructor names, they are pretty +-- suggestive. The data type name is up for grabs; a possible alternative +-- is @AtMost@. +data Only a = Everything | Only a deriving (Eq, Ord, Show) + +instance Functor Only where + fmap _ Everything = Everything + fmap f (Only x) = Only (f x) + +instance Foldable Only where + foldMap _ Everything = mempty + foldMap f (Only x) = f x + +instance Traversable Only where + traverse _ Everything = pure Everything + traverse f (Only x) = Only <$> f x + +-- | This is mostly for conversion to legacy APIs +fromOnly :: Only a -> Maybe a +fromOnly Everything = Nothing +fromOnly (Only x) = Just x + +{- | A set of repository paths. 'Everything' means every path in the repo, it +usually originates from an empty list of path arguments. The list of +'SubPath's is always kept in sorted order with no duplicates and normalised +(as in 'FilePath.normalise'). This has the nice effect of getting rid of the +idiotic "./" that Darcs insists on prepending to repo paths (which can make +things like comparing paths returned from different parts of the code base a +nightmare). + +It uses 'SubPath' for easier compatibility and lists because the number of +elements is expected to be small. +-} +type PathSet = Only [SubPath] + +-- | Intersection of two 'PathSet's +isectPathSet :: PathSet -> PathSet -> PathSet +isectPathSet Everything ys = ys +isectPathSet xs Everything = xs +isectPathSet (Only xs) (Only ys) = Only (isect xs ys) + +{- +-- | Union of two 'PathSet's +union :: PathSet -> PathSet -> PathSet +union Everything ys = Everything +union xs Everything = Everything +union (Only xs) (Only ys) = Only (union xs ys) +-} + +-- | Convert a list of 'SubPath's to a 'PathSet'. +sps2ps :: [SubPath] -> PathSet +sps2ps = Only . nubSort + +-- | Convert a list of repo paths to a 'PathSet'. +-- Partial function! Use only with repo paths. +fps2ps :: [FilePath] -> PathSet +fps2ps = sps2ps . map fp2sp + +-- | Convert a 'PathSet' to something that e.g. 'chooseTouching' +-- takes as parameter. +ps2fps :: PathSet -> Maybe [FilePath] +ps2fps = fmap (map sp2fp) . fromOnly + +-- | Convert a 'PathSet' to a 'Doc'. Uses the English module +-- to generate a nicely readable list of file names. +showPathSet :: Only [SubPath] -> Doc +showPathSet Everything = text "all paths" +showPathSet (Only xs) = pathlist (map sp2fp xs) + +-- | Lift a function transforming a list of 'FilePath' to one that +-- transforms a 'PathSet'. +liftToPathSet :: ([FilePath] -> [FilePath]) -> PathSet -> PathSet +liftToPathSet f = fmap (nubSort . map fp2sp . f . map sp2fp) + +-- | Convert a 'FilePath' to a 'SubPath'. +-- +-- Note: Should call this only with paths we get from the repository. +-- This guarantees that they are relative (to the repo dir). +fp2sp :: FilePath -> SubPath +fp2sp = fromJust . simpleSubPath + +-- | Convert a 'SubPath' to a 'FilePath'. Same as 'toFilePath' and +-- only here for symmetry. +sp2fp :: SubPath -> FilePath +sp2fp = toFilePath diff --git a/src/Darcs/UI/Commands/Move.hs b/src/Darcs/UI/Commands/Move.hs --- a/src/Darcs/UI/Commands/Move.hs +++ b/src/Darcs/UI/Commands/Move.hs @@ -16,8 +16,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Move ( move, mv ) where import Prelude () @@ -28,11 +26,17 @@ import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.UI.Commands - ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag(Quiet) - , doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask - , maybeFixSubPaths, fixSubPaths ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) + ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository + , putInfo + ) +import Darcs.UI.Completion ( knownFileArgs ) +import Darcs.UI.Flags + ( DarcsFlag + , allowCaseDifferingFilenames, allowWindowsReservedFilenames + , useCache, dryRun, umask + , maybeFixSubPaths, fixSubPaths + ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Diff ( treeDiff ) import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) ) @@ -45,13 +49,12 @@ , withRepoLock , RepoJob(..) , addPendingDiffToPending - , listFiles ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) ) import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft ) import Darcs.Util.Global ( debugMessage ) import qualified Darcs.Patch -import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf ) +import Darcs.Patch ( RepoPatch, PrimPatch ) import Darcs.Patch.Apply( ApplyState ) import Data.List ( nub, sort ) import qualified System.FilePath.Windows as WindowsFilePath @@ -68,6 +71,7 @@ , toFilePath , AbsolutePath ) +import Darcs.Util.Printer ( text, hsep ) import Darcs.Util.Workaround ( renameFile ) moveDescription :: String @@ -89,30 +93,6 @@ "`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" ++ "unusable on those systems!\n" -moveBasicOpts :: DarcsOption a (Bool -> Bool -> Maybe String -> a) -moveBasicOpts = O.allowProblematicFilenames ^ O.workingRepoDir - -moveAdvancedOpts :: DarcsOption a (O.UMask -> a) -moveAdvancedOpts = O.umask - -moveOpts :: DarcsOption a - (Bool - -> Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts - move :: DarcsCommand [DarcsFlag] move = DarcsCommand { commandProgramName = "darcs" @@ -123,7 +103,7 @@ , commandExtraArgHelp = [" ... "] , commandCommand = moveCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listFiles False + , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc moveAdvancedOpts , commandBasicOptions = odesc moveBasicOpts @@ -131,6 +111,10 @@ , commandCheckOptions = ocheck moveOpts , commandParseOptions = onormalise moveOpts } + where + moveBasicOpts = O.allowProblematicFilenames ^ O.repoDir + moveAdvancedOpts = O.umask + moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () moveCmd fps opts args @@ -235,31 +219,27 @@ withRepoAndState :: [DarcsFlag] -> (forall rt p wR wU . - (ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, RepoPatch p) => + (ApplyState p ~ Tree, RepoPatch p) => (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()) -> IO () withRepoAndState opts f = - withRepoLock dr uc YesUpdateWorking um $ RepoJob $ \repo -> do + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repo -> do work <- readPlainTree "." cur <- readRecordedAndPending repo recorded <- readRecorded repo f (repo, work, cur, recorded) - where - dr = dryRun opts - uc = useCache opts - um = umask opts -simpleMove :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath -> IO () simpleMove repository opts cur work old_fp new_fp = do doMoves repository opts cur work [(old_fp, new_fp)] - unless (Quiet `elem` opts) $ - putStrLn $ unwords ["Moved:", old_fp, "to:", new_fp] + putInfo opts $ hsep $ map text ["Moved:", old_fp, "to:", new_fp] -moveToDir :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +moveToDir :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath -> IO () @@ -267,10 +247,9 @@ let movetargets = map ((finaldir ) . takeFileName) moved moves = zip moved movetargets doMoves repository opts cur work moves - unless (Quiet `elem` opts) $ - putStrLn $ unwords $ ["Moved:"] ++ moved ++ ["to:", finaldir] + putInfo opts $ hsep $ map text $ ["Moved:"] ++ moved ++ ["to:", finaldir] -doMoves :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +doMoves :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> [(FilePath, FilePath)] -> IO () @@ -317,8 +296,7 @@ then Just <$> deleteNewFromRepoPatches else return Nothing else do - unless (Quiet `elem` opts) $ - putStrLn "Detected post-hoc move." + putInfo opts $ text "Detected post-hoc move." -- Post-hoc move - user has moved/deleted the file in working, so -- we can hopefully make a move patch to make the repository -- consistent. @@ -331,7 +309,7 @@ else return $ emptyGap NilFL where newIsOkWindowsPath = - doAllowWindowsReserved opts || WindowsFilePath.isValid new + allowWindowsReservedFilenames ? opts || WindowsFilePath.isValid new newNotOkWindowsPathMsg = "The filename " ++ new ++ " is not valid under Windows.\n" @@ -340,9 +318,8 @@ -- If we're moving to a file/dir that was recorded, but has been deleted, -- we need to add patches to pending that remove the original. deleteNewFromRepoPatches = do - unless (Quiet `elem` opts) $ - putStrLn $ "Existing recorded contents of " ++ new - ++ " will be overwritten." + putInfo opts $ text $ + "Existing recorded contents of " ++ new ++ " will be overwritten." ftf <- filetypeFunction let curNoNew = modifyTree cur (floatPath new) Nothing -- Return patches to remove new, so that the move patch @@ -352,10 +329,10 @@ -- Check if the passed tree has the new filepath. The old path is removed -- from the tree before checking if the new path is present. hasNew s = treeHas_case (modifyTree s (floatPath old) Nothing) new - treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase + treeHas_case = if allowCaseDifferingFilenames ? opts then treeHas else treeHasAnycase alreadyExists inWhat = - if doAllowCaseOnly opts + if allowCaseDifferingFilenames ? opts then "A file or dir named "++new++" already exists in " ++ inWhat ++ "." else "A file or dir named "++new++" (or perhaps differing " diff --git a/src/Darcs/UI/Commands/Optimize.hs b/src/Darcs/UI/Commands/Optimize.hs --- a/src/Darcs/UI/Commands/Optimize.hs +++ b/src/Darcs/UI/Commands/Optimize.hs @@ -15,56 +15,49 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -module Darcs.UI.Commands.Optimize ( optimize, doOptimizeHTTP ) where +module Darcs.UI.Commands.Optimize ( optimize ) where import Prelude () import Darcs.Prelude -import Control.Exception ( finally ) -import Control.Monad ( when, unless, forM, forM_ ) +import Control.Monad ( when, unless, forM_ ) +import Data.List ( nub ) import Data.Maybe ( isJust, fromJust ) -import Data.List ( sort ) -import Data.Set ( difference ) import System.Directory ( getDirectoryContents , doesDirectoryExist - , doesFileExist , renameFile - , getModificationTime , createDirectoryIfMissing , removeFile , getHomeDirectory ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL - - -import Darcs.Patch.PatchInfoAnd ( extractHash ) +import qualified Data.ByteString.Char8 as BC import Darcs.UI.Commands ( DarcsCommand(..), nodefaults , amInHashedRepository, amInRepository, putInfo , normalCommand, withStdOpts ) -import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir, oldGlobalCacheDir ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir ) import Darcs.Repository ( Repository + , repoLocation , withRepoLock , RepoJob(..) , readRepo , reorderInventory , cleanRepository , replacePristine - , maybeIdentifyRepository ) -import Darcs.Repository.Internal ( IdentifyRepo(..) ) -import Darcs.Repository.HashedRepo ( inventoriesDir, patchesDir, pristineDir, - hashedInventory, filterDirContents, - readHashedPristineRoot, listInventoriesRepoDir, - listPatchesLocalBucketed, set, unset, inv2pris ) +import Darcs.Repository.Job ( withOldRepoLock ) +import Darcs.Repository.Identify ( findAllReposInDir ) +import Darcs.Repository.Hashed ( inventoriesDir, patchesDir, pristineDir, + hashedInventory, + listInventoriesRepoDir, + listPatchesLocalBucketed, diffHashLists, peekPristineHash ) +import Darcs.Repository.Packs ( createPacks ) +import Darcs.Repository.Pending ( pendingName ) import Darcs.Repository.HashedIO ( getHashedFiles ) -import Darcs.Repository.Old ( oldRepoFailMsg ) -import Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) ) import Darcs.Patch.Witnesses.Ordered ( mapFL , bunchFL @@ -72,8 +65,8 @@ ) import Darcs.Patch ( IsRepoType, RepoPatch ) import Darcs.Patch.Set - ( newset2RL - , newset2FL + ( patchSet2RL + , patchSet2FL , progressPatchSet ) import Darcs.Patch.Apply( ApplyState ) @@ -85,8 +78,13 @@ , writeAtomicFilePS , rmRecursive , removeFileMayNotExist + , writeBinFile ) -import Darcs.Util.File ( withCurrentDirectory, getRecursiveContents ) +import Darcs.Util.File + ( withCurrentDirectory + , getRecursiveContents + , doesDirectoryReallyExist + ) import Darcs.UI.External ( catchall ) import Darcs.Util.Progress ( beginTedious @@ -99,17 +97,13 @@ import System.FilePath.Posix ( takeExtension , () - , (<.>) - , takeFileName , joinPath ) import Text.Printf ( printf ) -import System.Posix.Files ( getFileStatus, isDirectory ) import Darcs.UI.Flags - ( DarcsFlag(Compress) - , compression, verbosity, useCache, umask ) + ( DarcsFlag, verbosity, useCache, umask ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise - , defaultFlags, parseFlags ) + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..), DryRun ( NoDryRun ), UseCache (..), UMask (..) @@ -125,7 +119,7 @@ , RepoProperty ( HashedInventory ) ) import Darcs.Repository.PatchIndex -import qualified Darcs.Repository.HashedRepo as HashedRepo +import qualified Darcs.Repository.Hashed as HashedRepo import Darcs.Repository.State ( readRecorded ) import Darcs.Util.Tree @@ -141,11 +135,7 @@ ( writeDarcsHashed , decodeDarcsSize ) -import Codec.Archive.Tar ( write ) -import Codec.Archive.Tar.Entry ( fileEntry, toTarPath ) -import Codec.Compression.GZip ( compress ) - optimizeDescription :: String optimizeDescription = "Optimize the repository." @@ -176,24 +166,10 @@ } commonBasicOpts :: DarcsOption a (Maybe String -> UMask -> a) -commonBasicOpts = O.workingRepoDir ^ O.umask +commonBasicOpts = O.repoDir ^ O.umask + commonAdvancedOpts :: DarcsOption a a commonAdvancedOpts = oid -commonOpts :: DarcsOption a - (Maybe String - -> UMask - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts common :: DarcsCommand [DarcsFlag] common = DarcsCommand @@ -206,13 +182,15 @@ , commandHelp = undefined , commandDescription = undefined , commandCommand = undefined - , commandGetArgPossibilities = undefined + , commandCompleteArgs = noArgs , commandAdvancedOptions = odesc commonAdvancedOpts , commandBasicOptions = odesc commonBasicOpts , commandDefaults = defaultFlags commonOpts , commandCheckOptions = ocheck commonOpts , commandParseOptions = onormalise commonOpts } + where + commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts optimizeClean :: DarcsCommand [DarcsFlag] @@ -225,7 +203,8 @@ optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCleanCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories putInfo opts "Done cleaning repository!" @@ -248,9 +227,10 @@ optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeHttpCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories - doOptimizeHTTP repository + createPacks repository putInfo opts "Done creating packs!" optimizePristine :: DarcsCommand [DarcsFlag] @@ -264,7 +244,8 @@ optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizePristineCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doOptimizePristine opts repository putInfo opts "Done optimizing pristine!" @@ -287,34 +268,39 @@ optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCompressCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories - optimizeCompression [Compress] + optimizeCompression O.GzipCompression opts putInfo opts "Done optimizing by compression!" optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUncompressCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories - optimizeCompression [] + optimizeCompression O.NoCompression opts putInfo opts "Done optimizing by uncompression!" -optimizeCompression :: [DarcsFlag] -> IO () -optimizeCompression opts = do +optimizeCompression :: O.Compression -> [DarcsFlag] -> IO () +optimizeCompression compression opts = do putInfo opts "Optimizing (un)compression of patches..." - do_compress (darcsdir++"/patches") + do_compress (darcsdir ++ "/patches") putInfo opts "Optimizing (un)compression of inventories..." - do_compress (darcsdir++"/inventories") - where do_compress f = - do isd <- doesDirectoryExist f - if isd then withCurrentDirectory f $ - do fs <- filter notdot `fmap` getDirectoryContents "." - mapM_ do_compress fs - else if Compress `elem` opts - then gzReadFilePS f >>= gzWriteAtomicFilePS f - else gzReadFilePS f >>= writeAtomicFilePS f - notdot ('.':_) = False - notdot _ = True + do_compress (darcsdir ++ "/inventories") + where + do_compress f = do + isd <- doesDirectoryExist f + if isd + then withCurrentDirectory f $ do + fs <- filter notdot `fmap` getDirectoryContents "." + mapM_ do_compress fs + else gzReadFilePS f >>= + case compression of + O.GzipCompression -> gzWriteAtomicFilePS f + O.NoCompression -> writeAtomicFilePS f + notdot ('.':_) = False + notdot _ = True optimizeEnablePatchIndex :: DarcsCommand [DarcsFlag] optimizeEnablePatchIndex = common @@ -336,14 +322,17 @@ optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeEnablePatchIndexCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do - createOrUpdatePatchIndexDisk repository + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do + ps <- readRepo repository + createOrUpdatePatchIndexDisk repository ps putInfo opts "Done enabling patch index!" optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeDisablePatchIndexCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(Repo repodir _ _ _) -> do - deletePatchIndex repodir + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repo -> do + deletePatchIndex (repoLocation repo) putInfo opts "Done disabling patch index!" optimizeReorder :: DarcsCommand [DarcsFlag] @@ -359,30 +348,11 @@ optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeReorderCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do - reorderInventory repository (compression opts) YesUpdateWorking (verbosity opts) + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do + reorderInventory repository (O.compress ? opts) YesUpdateWorking (verbosity ? opts) putInfo opts "Done reordering!" -optimizeRelinkBasicOpts :: DarcsOption a - (Maybe String -> UMask -> [AbsolutePath] -> a) -optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings -optimizeRelinkOpts :: DarcsOption a - (Maybe String - -> UMask - -> [AbsolutePath] - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -optimizeRelinkOpts = optimizeRelinkBasicOpts `withStdOpts` commonAdvancedOpts - optimizeRelink :: DarcsCommand [DarcsFlag] optimizeRelink = common { commandName = "relink" @@ -395,10 +365,14 @@ , commandCheckOptions = ocheck optimizeRelinkOpts , commandParseOptions = onormalise optimizeRelinkOpts } + where + optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings + optimizeRelinkOpts = optimizeRelinkBasicOpts `withStdOpts` commonAdvancedOpts optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeRelinkCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doRelink opts putInfo opts "Done relinking!" @@ -434,14 +408,14 @@ "repository, or if you pulled the same patch from a remote repository\n" ++ "into multiple local repositories." -doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository rt p wR wU wT -> IO () +doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO () doOptimizePristine opts repo = do - inv <- BS.readFile (darcsdir "hashed_inventory") - let linesInv = BS.split '\n' inv + inv <- BC.readFile (darcsdir "hashed_inventory") + let linesInv = BC.split '\n' inv case linesInv of [] -> return () (pris_line:_) -> - let size = decodeDarcsSize $ BS.drop 9 pris_line + let size = decodeDarcsSize $ BC.drop 9 pris_line in when (isJust size) $ do putInfo opts "Optimizing hashed pristine..." readRecorded repo >>= replacePristine repo cleanRepository repo @@ -473,14 +447,12 @@ -- Only 'optimize' commands that works on old-fashionned repositories optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUpgradeCmd _ opts _ = do - debugMessage "Upgrading to hashed..." rf <- identifyRepoFormat "." debugMessage "Found our format" if formatHas HashedInventory rf then putInfo opts "No action taken because this repository already is hashed." - else do putInfo opts "Checking repository in case of corruption..." - withRepoLock NoDryRun YesUseCache YesUpdateWorking NoUMask $ RepoJob $ \repository -> - actuallyUpgradeFormat repository + else do putInfo opts "Upgrading to hashed..." + withOldRepoLock $ RepoJob actuallyUpgradeFormat actuallyUpgradeFormat :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) @@ -490,98 +462,48 @@ patches <- readRepo repository let k = "Hashing patch" beginTedious k - tediousSize k (lengthRL $ newset2RL patches) + tediousSize k (lengthRL $ patchSet2RL patches) let patches' = progressPatchSet k patches cache <- getCaches YesUseCache "." - let compr = compression [] -- default compression - HashedRepo.writeTentativeInventory cache compr patches' + -- TODO Why use the default and not what the user provided? + -- Is it because the author couldn't be bothered to add the option? + -- Or is there a more profound reason? + -- Such things justify a few lines of comment! + let compressDefault = O.compress ? [] + HashedRepo.writeTentativeInventory cache compressDefault 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" $ newset2FL patches' + let patchesToApply = progressFL "Applying patch" $ patchSet2FL patches' createDirectoryIfMissing False $ darcsdir hashedDir HashedPristineDir -- We ignore the returned root hash, we don't use it. - _ <- writeDarcsHashed emptyTree $ darcsdir "pristine.hashed" - sequence_ $ mapFL HashedRepo.applyToTentativePristine $ bunchFL 100 patchesToApply + _ <- writeDarcsHashed emptyTree $ darcsdir hashedDir HashedPristineDir + writeBinFile (darcsdir++"/tentative_pristine") "" + sequence_ $ mapFL HashedRepo.applyToTentativePristineCwd $ bunchFL 100 patchesToApply -- now make it official - HashedRepo.finalizeTentativeChanges repository compr + HashedRepo.finalizeTentativeChanges repository compressDefault writeRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) (darcsdir "format") -- clean out old-fashioned junk debugMessage "Cleaning out old-fashioned repository files..." - removeFile $ darcsdir "inventory" - removeFile $ darcsdir "tentative_inventory" + removeFileMayNotExist $ darcsdir "inventory" + removeFileMayNotExist $ darcsdir "tentative_inventory" rmRecursive (darcsdir "pristine") `catchall` rmRecursive (darcsdir "current") rmGzsIn (darcsdir "patches") rmGzsIn (darcsdir "inventories") let checkpointDir = darcsdir "checkpoints" hasCheckPoints <- doesDirectoryExist checkpointDir when hasCheckPoints $ rmRecursive checkpointDir + removeFileMayNotExist (pendingName ++ ".tentative") + removeFileMayNotExist pendingName where rmGzsIn dir = withCurrentDirectory dir $ do gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "." mapM_ removeFile gzs -doOptimizeHTTP - :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT -> IO () -doOptimizeHTTP repo = flip finally (mapM_ removeFileIfExists - [ darcsdir "meta-filelist-inventories" - , darcsdir "meta-filelist-pristine" - , basicTar <.> "part" - , patchesTar <.> "part" - ]) $ do - rf <- identifyRepoFormat "." - -- function is exposed in API so could be called on non-hashed repo - unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg - createDirectoryIfMissing False packsDir - -- pristine hash - Just hash <- readHashedPristineRoot repo - writeFile ( packsDir "pristine" ) hash - -- pack patchesTar - ps <- mapFL hashedPatchFileName . newset2FL <$> readRepo repo - is <- map ((darcsdir "inventories") ) <$> HashedRepo.listInventories - writeFile (darcsdir "meta-filelist-inventories") . unlines $ - map takeFileName is - -- tinkering with zlib's compression parameters does not make - -- any noticeable difference in generated archive size. - -- switching to bzip2 does OTOH (~25% size gain). - BL.writeFile (patchesTar <.> "part") . compress . write =<< - mapM fileEntry' ((darcsdir "meta-filelist-inventories") : ps ++ - reverse is) - renameFile (patchesTar <.> "part") patchesTar - -- pack basicTar - pr <- sortByMTime =<< dirContents "pristine.hashed" - writeFile (darcsdir "meta-filelist-pristine") . unlines $ - map takeFileName pr - BL.writeFile (basicTar <.> "part") . compress . write =<< mapM fileEntry' ( - [ darcsdir "meta-filelist-pristine" - , darcsdir "hashed_inventory" - ] ++ reverse pr) - renameFile (basicTar <.> "part") basicTar - where - packsDir = darcsdir "packs" - basicTar = packsDir "basic.tar.gz" - patchesTar = packsDir "patches.tar.gz" - fileEntry' x = unsafeInterleaveIO $ do - content <- BL.fromChunks . return <$> gzReadFilePS x - tp <- either fail return $ toTarPath False x - return $ fileEntry tp content - dirContents d = map ((darcsdir d) ) <$> - filterDirContents d (const True) - hashedPatchFileName x = case extractHash x of - Left _ -> fail "unexpected unhashed patch" - Right h -> darcsdir "patches" h - sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$> - getModificationTime x) xs - removeFileIfExists x = do - ex <- doesFileExist x - when ex $ removeFile x - optimizeBucketed :: [DarcsFlag] -> IO () optimizeBucketed opts = do putInfo opts "Migrating global cache to bucketed format." - gOldCacheDir <- oldGlobalCacheDir gCacheDir <- globalCacheDir case gCacheDir of @@ -594,13 +516,6 @@ toBucketed gCachePristineDir gCachePristineDir toBucketed gCacheInventoriesDir gCacheInventoriesDir toBucketed gCachePatchesDir gCachePatchesDir - case gOldCacheDir of - Nothing -> debugMessage "Old global cache doesn't exist." - Just gOldCacheDir' -> do - debugMessage "Making bucketed cache from old cache." - toBucketed (joinPath [gOldCacheDir', pristineDir]) gCachePristineDir - toBucketed (joinPath [gOldCacheDir', inventoriesDir]) gCacheInventoriesDir - toBucketed (joinPath [gOldCacheDir', patchesDir]) gCachePatchesDir putInfo opts "Done making bucketed cache!" where toBucketed :: FilePath -> FilePath -> IO () @@ -613,8 +528,8 @@ createDirectoryIfMissing True (dest subDir) fileNames <- getDirectoryContents src forM_ fileNames $ \file -> do - fileStatus <- getFileStatus (src file) - if not $ isDirectory fileStatus + exists <- doesDirectoryReallyExist (src file) + if not $ exists then renameFile' src dest file else return () else do @@ -668,11 +583,11 @@ putInfo opts "\nLooking for repositories in the following directories:" putInfo opts $ text $ unlines dirs gCacheDir' <- globalCacheDir - repoPaths' <- mapM getRecursiveDarcsRepos dirs + repoPaths' <- mapM findAllReposInDir dirs putInfo opts "Finished listing repositories." - let repoPaths = unset . set $ concat repoPaths' + let repoPaths = nub $ concat repoPaths' gCache = fromJust gCacheDir' gCacheInvDir = gCache inventoriesDir gCachePatchesDir = gCache patchesDir @@ -696,33 +611,11 @@ remove' dir s1 s2 = mapM_ (removeFileMayNotExist . (\hashedFile -> dir bucketFolder hashedFile hashedFile)) - (unset $ set s1 `difference` set s2) + (diffHashLists s1 s2) getPristine :: String -> IO [String] getPristine darcsDir = do i <- gzReadFilePS (darcsDir darcsdir hashedInventory) - getHashedFiles (darcsDir darcsdir pristineDir) [inv2pris i] + getHashedFiles (darcsDir darcsdir pristineDir) [peekPristineHash i] --- |getRecursiveDarcsRepos returns all paths to repositories under topdir. -getRecursiveDarcsRepos :: FilePath -> IO [FilePath] -getRecursiveDarcsRepos topdir = do - isDir <- doesDirectoryExist topdir - if isDir - then do - status <- maybeIdentifyRepository NoUseCache topdir - case status of - GoodRepository (Repo _ _ pris _) -> - case pris of - HashedPristine -> return [topdir] - _ -> return [] -- old fashioned or broken repo - _ -> getRecursiveDarcsRepos' topdir - else return [] - where - getRecursiveDarcsRepos' d = do - names <- getDirectoryContents d - let properNames = filter (\x -> head x /= '.') names - paths <- forM properNames $ \name -> do - let path = d name - getRecursiveDarcsRepos path - return (concat paths) diff --git a/src/Darcs/UI/Commands/Pull.hs b/src/Darcs/UI/Commands/Pull.hs --- a/src/Darcs/UI/Commands/Pull.hs +++ b/src/Darcs/UI/Commands/Pull.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Pull ( -- * Commands. pull, fetch, pullCmd, StandardPatchApplier, @@ -27,44 +25,29 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import System.Exit ( exitSuccess ) import Control.Monad ( when, unless, (>=>) ) import Data.List ( nub ) import Data.Maybe ( fromMaybe ) import Darcs.UI.Commands - ( DarcsCommand(..), withStdOpts + ( DarcsCommand(..) + , withStdOpts , putInfo + , putVerbose , setEnvDarcsPatches , defaultRepo , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag - ( AllowConflicts - , Complement - , DryRun - , Intersection - , MarkConflicts - , NoAllowConflicts - , SkipConflicts - , Verbose - , XMLOutput - , Quiet - , AllowUnrelatedRepos - ) , fixUrl, getOutput - , doReverse, verbosity, dryRun, umask, useCache, selectDeps + , changesReverse, verbosity, dryRun, umask, useCache, selectDeps , remoteRepos, reorder, setDefault - , isUnified, hasSummary - , isInteractive - ) -import Darcs.UI.Options - ( DarcsOption, (^), odesc, ocheck, onormalise - , defaultFlags, parseFlags + , withContext, hasXmlOutput + , isInteractive, quiet ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository @@ -73,7 +56,6 @@ , withRepoLock , RepoJob(..) , readRepo - , checkUnrelatedRepos , modifyCache , modifyCache , Cache(..) @@ -84,7 +66,7 @@ import qualified Darcs.Repository.Cache as DarcsCache import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc ) -import Darcs.Patch ( IsRepoType, RepoPatch, description, PrimOf ) +import Darcs.Patch ( IsRepoType, RepoPatch, description ) import Darcs.Patch.Bundle( makeBundleN, patchFilename ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet ) @@ -94,11 +76,12 @@ ( (:>)(..), (:\/:)(..), FL(..), RL(..) , mapFL, nullFL, reverseFL, mapFL_FL ) import Darcs.Patch.Permutations ( partitionFL ) -import Darcs.Repository.Prefs ( addToPreflist, addRepoSource, getPreflist ) -import Darcs.Repository.Motd (showMotd ) +import Darcs.Repository.Prefs ( addToPreflist, addRepoSource, getPreflist, showMotd ) import Darcs.Patch.Depends ( findUncommon, findCommonWithThem, - newsetIntersection, newsetUnion ) + patchSetIntersection, patchSetUnion ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) ) +import Darcs.UI.Completion ( prefArgs ) +import Darcs.UI.Commands.Util ( checkUnrelatedRepos ) import Darcs.UI.SelectChanges ( WhichChanges(..) , runSelection @@ -106,15 +89,13 @@ ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.Exception ( clarifyErrors ) -import Darcs.Util.Printer ( putDocLn, vcat, ($$), text, putDoc ) +import Darcs.Util.Printer ( vcat, ($$), text, putDoc ) import Darcs.Util.Lock ( writeDocBinFile ) import Darcs.Util.Path ( useAbsoluteOrStd, stdOut, AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.Text ( quote ) import Darcs.Util.Tree( Tree ) -#include "impossible.h" - pullDescription :: String pullDescription = "Copy and apply patches from another repository to this one." @@ -154,157 +135,6 @@ , "the help of `pull` to know more." ] -pullBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> O.Reorder - -> Maybe Bool - -> Maybe O.AllowConflicts - -> O.ExternalMerge - -> O.RunTest - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Bool - -> O.DiffAlgorithm - -> a) -pullBasicOpts - = O.matchSeveral - ^ O.reorder - ^ O.interactive -- True - ^ O.conflicts O.YesAllowConflictsAndMark - ^ O.useExternalMerge - ^ O.test - ^ O.dryRunXml - ^ O.summary - ^ O.selectDeps - ^ O.setDefault - ^ O.workingRepoDir - ^ O.allowUnrelatedRepos - ^ O.diffAlgorithm - -pullAdvancedOpts :: DarcsOption a - (O.RepoCombinator - -> O.Compression - -> O.UseIndex - -> O.RemoteRepos - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.WantGuiPause - -> O.NetworkOptions - -> a) -pullAdvancedOpts - = O.repoCombinator - ^ O.compress - ^ O.useIndex - ^ O.remoteRepos - ^ O.setScriptsExecutable - ^ O.umask - ^ O.restrictPaths - ^ O.changesReverse - ^ O.pauseForGui - ^ O.network - -pullOpts :: DarcsOption a - ([O.MatchFlag] - -> O.Reorder - -> Maybe Bool - -> Maybe O.AllowConflicts - -> O.ExternalMerge - -> O.RunTest - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Bool - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.RepoCombinator - -> O.Compression - -> O.UseIndex - -> O.RemoteRepos - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.WantGuiPause - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts - -fetchBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Bool - -> O.DryRun - -> Maybe O.Summary - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Maybe O.Output - -> Bool - -> O.DiffAlgorithm - -> a) -fetchBasicOpts - = O.matchSeveral - ^ O.interactive -- True - ^ O.dryRun - ^ O.summary - ^ O.selectDeps - ^ O.setDefault - ^ O.workingRepoDir - ^ O.output - ^ O.allowUnrelatedRepos - ^ O.diffAlgorithm - -fetchAdvancedOpts :: DarcsOption a - (O.RepoCombinator -> O.RemoteRepos -> O.NetworkOptions -> a) -fetchAdvancedOpts - = O.repoCombinator - ^ O.remoteRepos - ^ O.network - -fetchOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Bool - -> O.DryRun - -> Maybe O.Summary - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Maybe O.Output - -> Bool - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.RepoCombinator - -> O.RemoteRepos - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -fetchOpts = fetchBasicOpts `withStdOpts` fetchAdvancedOpts - fetch :: DarcsCommand [DarcsFlag] fetch = DarcsCommand { commandProgramName = "darcs" @@ -315,14 +145,31 @@ , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = fetchCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = getPreflist "repos" + , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo - , commandAdvancedOptions = odesc fetchAdvancedOpts - , commandBasicOptions = odesc fetchBasicOpts - , commandDefaults = defaultFlags fetchOpts - , commandCheckOptions = ocheck fetchOpts - , commandParseOptions = onormalise fetchOpts + , commandAdvancedOptions = odesc advancedOpts + , commandBasicOptions = odesc basicOpts + , commandDefaults = defaultFlags allOpts + , commandCheckOptions = ocheck allOpts + , commandParseOptions = onormalise allOpts } + where + basicOpts + = O.matchSeveral + ^ O.interactive -- True + ^ O.dryRun + ^ O.summary + ^ O.selectDeps + ^ O.setDefault + ^ O.repoDir + ^ O.output + ^ O.allowUnrelatedRepos + ^ O.diffAlgorithm + advancedOpts + = O.repoCombinator + ^ O.remoteRepos + ^ O.network + allOpts = basicOpts `withStdOpts` advancedOpts pull :: DarcsCommand [DarcsFlag] pull = DarcsCommand @@ -334,44 +181,67 @@ , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = pullCmd StandardPatchApplier , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = getPreflist "repos" + , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo - , commandAdvancedOptions = odesc pullAdvancedOpts - , commandBasicOptions = odesc pullBasicOpts - , commandDefaults = defaultFlags pullOpts - , commandCheckOptions = ocheck pullOpts - , commandParseOptions = onormalise pullOpts + , commandAdvancedOptions = odesc advancedOpts + , commandBasicOptions = odesc basicOpts + , commandDefaults = defaultFlags allOpts + , commandCheckOptions = ocheck allOpts + , commandParseOptions = onormalise allOpts } - -mergeOpts :: [DarcsFlag] -> [DarcsFlag] -mergeOpts opts | NoAllowConflicts `elem` opts = opts - | AllowConflicts `elem` opts = opts - | otherwise = MarkConflicts : opts + where + basicOpts + = O.matchSeveral + ^ O.reorder + ^ O.interactive + ^ O.conflictsYes + ^ O.externalMerge + ^ O.runTest + ^ O.dryRunXml + ^ O.summary + ^ O.selectDeps + ^ O.setDefault + ^ O.repoDir + ^ O.allowUnrelatedRepos + ^ O.diffAlgorithm + advancedOpts + = O.repoCombinator + ^ O.compress + ^ O.useIndex + ^ O.remoteRepos + ^ O.setScriptsExecutable + ^ O.umask + ^ O.restrictPaths + ^ O.changesReverse + ^ O.pauseForGui + ^ O.network + allOpts = basicOpts `withStdOpts` advancedOpts -pullCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () +pullCmd + :: PatchApplier pa + => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () pullCmd patchApplier (_,o) opts repos = do pullingFrom <- mapM (fixUrl o) repos - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ repoJob patchApplier opts $ \patchProxy initRepo -> do let repository = modifyCache initRepo $ addReposToCache pullingFrom (_, Sealed (us' :\/: to_be_pulled)) - <- fetchPatches o opts' repos "pull" repository + <- fetchPatches o opts repos "pull" repository let from_whom = error "Internal error: pull shouldn't need a 'from' address" - applyPatches patchApplier patchProxy "pull" opts' from_whom repository us' to_be_pulled + applyPatches patchApplier patchProxy "pull" opts from_whom repository us' to_be_pulled where - opts' = mergeOpts opts addReposToCache repos' (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos' ] ++ cache toReadOnlyCache = Cache DarcsCache.Repo NotWritable fetchCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fetchCmd (_,o) opts repos = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ fetchPatches o opts repos "fetch" >=> makeBundle opts -fetchPatches :: forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +fetchPatches :: forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => AbsolutePath -> [DarcsFlag] -> [String] -> String -> Repository rt p wR wU wR -> IO (SealedPatchSet rt p Origin, @@ -383,15 +253,17 @@ when (null repodirs) $ fail "Can't pull from current repository!" old_default <- getPreflist "defaultrepo" - when (old_default == repodirs && XMLOutput `notElem` opts) $ - let pulling = if DryRun `elem` opts then "Would pull" else "Pulling" + when (old_default == repodirs && not (hasXmlOutput opts)) $ + let pulling = case dryRun ? opts of + O.YesDryRun -> "Would pull" + O.NoDryRun -> "Pulling" in putInfo opts $ text $ pulling++" from "++concatMap quote repodirs++"..." (Sealed them, Sealed compl) <- readRepos repository opts repodirs - addRepoSource (head repodirs) (dryRun opts) (remoteRepos opts) (setDefault False opts) + addRepoSource (head repodirs) (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts) mapM_ (addToPreflist "repos") repodirs - unless (Quiet `elem` opts || XMLOutput `elem` opts) $ mapM_ showMotd repodirs + unless (quiet opts || hasXmlOutput opts) $ mapM_ showMotd repodirs us <- readRepo repository - checkUnrelatedRepos (AllowUnrelatedRepos `elem` opts) us them + checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them common :> _ <- return $ findCommonWithThem us them us' :\/: them' <- return $ findUncommon us them @@ -399,22 +271,24 @@ let avoided = mapFL info compl' ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them' - when (Verbose `elem` opts) $ - do case us' of - (x@(_:>:_)) -> putDocLn $ text "We have the following new (to them) patches:" - $$ vcat (mapFL description x) - _ -> return () - unless (nullFL ps) $ putDocLn $ text "They have the following patches to pull:" - $$ vcat (mapFL description ps) + putVerbose opts $ + case us' of + (x@(_ :>: _)) -> + text "We have the following new (to them) patches:" $$ + vcat (mapFL description x) + _ -> mempty + unless (nullFL ps) $ putVerbose opts $ + text "They have the following patches to pull:" $$ + vcat (mapFL description ps) (hadConflicts, Sealed psFiltered) - <- if SkipConflicts `elem` opts + <- if O.conflictsYes ? opts == Nothing then filterOutConflicts (reverseFL us') repository ps else return (False, Sealed ps) - when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts." - when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!" - setEnvDarcsPatches psFiltered - when (reorder opts /= O.Reorder) exitSuccess - let direction = if doReverse opts then FirstReversed else First + when hadConflicts $ putInfo opts $ text "Skipping some patches which would cause conflicts." + when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!" + setEnvDarcsPatches psFiltered + when (reorder ? opts /= O.Reorder) exitSuccess + let direction = if changesReverse ? opts then FirstReversed else First context = selectionContext direction jobname (pullPatchSelOpts opts) Nothing Nothing (to_be_pulled :> _) <- runSelection psFiltered context return (seal common, seal $ us' :\/: to_be_pulled) @@ -464,26 +338,25 @@ the second patchset(s) to be complemented against Rc. -} -readRepos :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +readRepos :: (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT -> [DarcsFlag] -> [String] -> IO (SealedPatchSet rt p Origin,SealedPatchSet rt p Origin) readRepos _ _ [] = impossible readRepos to_repo opts us = - do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo (useCache opts) u + do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo (useCache ? opts) u ps <- readRepo r return $ seal ps) us - return $ if Intersection `elem` opts - then (newsetIntersection rs, seal (PatchSet NilRL NilRL)) - else if Complement `elem` opts - then (head rs, newsetUnion $ tail rs) - else (newsetUnion rs, seal (PatchSet NilRL NilRL)) + return $ case parseFlags O.repoCombinator opts of + O.Intersection -> (patchSetIntersection rs, seal (PatchSet NilRL NilRL)) + O.Complement -> (head rs, patchSetUnion $ tail rs) + O.Union -> (patchSetUnion rs, seal (PatchSet NilRL NilRL)) pullPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions pullPatchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveral flags , S.interactive = isInteractive True flags - , S.selectDeps = selectDeps flags - , S.summary = hasSummary O.NoSummary flags - , S.withContext = isUnified flags + , S.selectDeps = selectDeps ? flags + , S.summary = O.summary ? flags + , S.withContext = withContext ? flags } diff --git a/src/Darcs/UI/Commands/Push.hs b/src/Darcs/UI/Commands/Push.hs --- a/src/Darcs/UI/Commands/Push.hs +++ b/src/Darcs/UI/Commands/Push.hs @@ -15,15 +15,13 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Darcs.UI.Commands.Push ( push ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess ) import Control.Monad ( when, unless ) import Data.Maybe ( isJust ) @@ -32,25 +30,26 @@ , putVerbose , putInfo , abortRun - , printDryRunMessageAndExit , setEnvDarcsPatches , defaultRepo , amInHashedRepository ) +import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) +import Darcs.UI.Completion ( prefArgs ) import Darcs.UI.Flags ( DarcsFlag - , isInteractive, verbosity, isUnified, hasSummary - , hasXmlOutput, selectDeps, applyAs, remoteDarcs - , doReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl ) + , isInteractive, verbosity, withContext + , xmlOutput, selectDeps, applyAs, remoteDarcs + , changesReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl ) import Darcs.UI.Options - ( DarcsOption, (^), odesc, ocheck, onormalise - , defaultFlags, parseFlags ) + ( (^), odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( DryRun (..) ) import qualified Darcs.Repository.Flags as R ( remoteDarcs ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), identifyRepositoryFor, - readRepo, checkUnrelatedRepos ) + readRepo ) import Darcs.Patch ( IsRepoType, RepoPatch, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered @@ -59,6 +58,7 @@ import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) import Darcs.UI.External ( signString, darcsProgram , pipeDoc, pipeDocSSH ) +import Darcs.Util.Exception ( die ) import Darcs.Util.URL ( isHttpUrl, isValidLocalPath , isSshUrl, splitSshUrl, SshFilePath(..) ) import Darcs.Util.Path ( AbsolutePath ) @@ -70,15 +70,14 @@ import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Patch.Depends ( findCommonWithThem, countUsThem ) import Darcs.Patch.Bundle ( makeBundleN ) -import Darcs.Patch.Patchy( ShowPatch ) +import Darcs.Patch.Show( ShowPatch ) import Darcs.Patch.Set ( PatchSet, Origin ) -import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$), RenderMode(..) ) +import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$) ) import Darcs.UI.Email ( makeEmail ) import Darcs.Util.English (englishNum, Noun(..)) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.Text ( quote ) import Darcs.Util.Tree( Tree ) -#include "impossible.h" pushDescription :: String @@ -103,78 +102,17 @@ , "you should try again with the `--no-compress` option." ] -pushBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> O.Sign - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> Maybe String - -> Maybe Bool - -> Bool - -> a) -pushBasicOpts - = O.matchSeveral - ^ O.selectDeps - ^ O.interactive - ^ O.sign - ^ O.dryRunXml - ^ O.summary - ^ O.workingRepoDir - ^ O.setDefault - ^ O.allowUnrelatedRepos - -pushAdvancedOpts :: DarcsOption a - (Maybe String -> O.RemoteRepos -> Bool -> O.Compression -> O.NetworkOptions -> a) -pushAdvancedOpts - = O.applyAs - ^ O.remoteRepos - ^ O.changesReverse - ^ O.compress - ^ O.network - -pushOpts :: DarcsOption a - ([O.MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> O.Sign - -> DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> Maybe String - -> Maybe Bool - -> Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> Maybe String - -> O.RemoteRepos - -> Bool - -> O.Compression - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts - push :: DarcsCommand [DarcsFlag] push = DarcsCommand { commandProgramName = "darcs" , commandName = "push" , commandHelp = pushHelp , commandDescription = pushDescription - , commandExtraArgs = 1 + , commandExtraArgs = -1 , commandExtraArgHelp = ["[REPOSITORY]"] , commandCommand = pushCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = getPreflist "repos" + , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc pushAdvancedOpts , commandBasicOptions = odesc pushBasicOpts @@ -182,43 +120,61 @@ , commandCheckOptions = ocheck pushOpts , commandParseOptions = onormalise pushOpts } + where + pushBasicOpts + = O.matchSeveral + ^ O.selectDeps + ^ O.interactive + ^ O.sign + ^ O.dryRunXml + ^ O.summary + ^ O.repoDir + ^ O.setDefault + ^ O.allowUnrelatedRepos + pushAdvancedOpts + = O.applyAs + ^ O.remoteRepos + ^ O.changesReverse + ^ O.compress + ^ O.network + pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -pushCmd _ _ [""] = impossible -pushCmd (_,o) opts [unfixedrepodir] = - do - repodir <- fixUrl o 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 <- withRepository (useCache opts) $ RepoJob $ - prepareBundle opts repodir - sbundle <- signString (parseFlags O.sign opts) bundle - let body = if isValidLocalPath repodir - then sbundle - else makeEmail repodir [] Nothing Nothing sbundle Nothing - rval <- remoteApply opts repodir body - case rval of ExitFailure ec -> do putStrLn "Apply failed!" - exitWith (ExitFailure ec) - ExitSuccess -> putInfo opts $ text "Push successful." -pushCmd _ _ _ = impossible +pushCmd (_, o) opts [unfixedrepodir] = do + repodir <- fixUrl o unfixedrepodir + here <- getCurrentDirectory + checkOptionsSanity opts repodir + -- make sure we aren't trying to push to the current repo + when (repodir == here) $ die "Cannot push from repository to itself." + bundle <- + withRepository (useCache ? opts) $ RepoJob $ prepareBundle opts repodir + sbundle <- signString (parseFlags O.sign opts) bundle + let body = + if isValidLocalPath repodir + then sbundle + else makeEmail repodir [] Nothing Nothing sbundle Nothing + rval <- remoteApply opts repodir body + case rval of + ExitFailure ec -> do + putStrLn "Apply failed!" + exitWith (ExitFailure ec) + ExitSuccess -> putInfo opts $ text "Push successful." +pushCmd _ _ [] = die "No default repository to push to, please specify one." +pushCmd _ _ _ = die "Cannot push to more than one repo." prepareBundle :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> String -> Repository rt p wR wU wT -> IO Doc prepareBundle opts repodir repository = do old_default <- getPreflist "defaultrepo" when (old_default == [repodir]) $ - let pushing = if dryRun opts == YesDryRun then "Would push" else "Pushing" + let pushing = if dryRun ? opts == YesDryRun then "Would push" else "Pushing" in putInfo opts $ text $ pushing++" to "++quote repodir++"..." - them <- identifyRepositoryFor repository (useCache opts) repodir >>= readRepo - addRepoSource repodir (dryRun opts) (remoteRepos opts) (setDefault False opts) + them <- identifyRepositoryFor repository (useCache ? opts) repodir >>= readRepo + addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts) us <- readRepo repository common :> us' <- return $ findCommonWithThem us them prePushChatter opts us (reverseFL us') them - let direction = if doReverse opts then FirstReversed else First + let direction = if changesReverse ? opts then FirstReversed else First context = selectionContext direction "push" (pushPatchSelOpts opts) Nothing Nothing runSelection us' context >>= bundlePatches opts common @@ -246,10 +202,10 @@ do setEnvDarcsPatches to_be_pushed printDryRunMessageAndExit "push" - (verbosity opts) - (hasSummary O.NoSummary opts) - (dryRun opts) - (hasXmlOutput opts) + (verbosity ? opts) + (O.summary ? opts) + (dryRun ? opts) + (xmlOutput ? opts) (isInteractive True opts) to_be_pushed when (nullFL to_be_pushed) $ do @@ -261,7 +217,7 @@ checkOptionsSanity :: [DarcsFlag] -> String -> IO () checkOptionsSanity opts repodir = if isHttpUrl repodir then do - when (isJust $ applyAs opts) $ + when (isJust $ applyAs ? opts) $ abortRun opts $ text "Cannot --apply-as when pushing to URLs" let lprot = takeWhile (/= ':') repodir msg = text ("Pushing to "++lprot++" URLs is not supported.") @@ -272,17 +228,17 @@ pushPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions pushPatchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveral flags , S.interactive = isInteractive True flags - , S.selectDeps = selectDeps flags - , S.summary = hasSummary O.NoSummary flags - , S.withContext = isUnified flags + , S.selectDeps = selectDeps ? flags + , S.summary = O.summary ? flags + , S.withContext = withContext ? flags } remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode remoteApply opts repodir bundle - = case applyAs opts of + = case applyAs ? opts of Nothing | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle | otherwise -> applyViaLocal opts repodir bundle @@ -293,22 +249,22 @@ applyViaSudo :: String -> String -> Doc -> IO ExitCode applyViaSudo user repo bundle = darcsProgram >>= \darcs -> - pipeDoc Standard "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle + pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode applyViaLocal opts repo bundle = darcsProgram >>= \darcs -> - pipeDoc Standard darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle + pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode applyViaSsh opts repo = - pipeDocSSH (parseFlags O.compress opts) Standard repo + pipeDocSSH (parseFlags O.compress opts) repo [R.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++ " --repodir '"++sshRepo repo++"'"] applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode applyViaSshAndSudo opts repo username = - pipeDocSSH (parseFlags O.compress opts) Standard repo + pipeDocSSH (parseFlags O.compress opts) repo ["sudo -u "++username++" "++R.remoteDarcs (remoteDarcs opts)++ " apply --all --repodir '"++sshRepo repo++"'"] diff --git a/src/Darcs/UI/Commands/Rebase.hs b/src/Darcs/UI/Commands/Rebase.hs --- a/src/Darcs/UI/Commands/Rebase.hs +++ b/src/Darcs/UI/Commands/Rebase.hs @@ -2,7 +2,7 @@ -- -- BSD3 -{-# LANGUAGE CPP, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Darcs.UI.Commands.Rebase ( rebase ) where @@ -16,34 +16,29 @@ , defaultRepo, nodefaults , putInfo, putVerbose , setEnvDarcsPatches - , printDryRunMessageAndExit , amInHashedRepository ) +import Darcs.UI.Commands.Util ( printDryRunMessageAndExit ) import Darcs.UI.Commands.Apply ( applyCmd ) import Darcs.UI.Commands.Log ( changelog, getLogInfo ) import Darcs.UI.Commands.Pull ( pullCmd, revertable ) import Darcs.UI.Commands.Unrecord ( getLastPatches, matchingHead ) import Darcs.UI.CommandsAux ( checkPaths ) +import Darcs.UI.Completion ( fileArgs, prefArgs, noArgs ) import Darcs.UI.Flags ( DarcsFlag - ( AllowConflicts - , NoAllowConflicts - , MarkConflicts - , SkipConflicts - , SetScriptsExecutable) , externalMerge, allowConflicts - , compression, diffingOpts - , dryRun, reorder, verbosity + , compress, diffingOpts + , dryRun, reorder, verbosity, verbose , useCache, wantGuiPause - , umask, toMatchFlags, doReverse - , DarcsFlag(XMLOutput) - , showChangesOnlyToFiles - , diffAlgorithm, maxCount, hasSummary, isInteractive - , selectDeps, hasXmlOutput + , umask, matchAny, changesReverse + , onlyToFiles + , diffAlgorithm, maxCount, isInteractive + , selectDeps, xmlOutput, hasXmlOutput ) import Darcs.UI.Options - ( DarcsOption, (^), oid, odesc, ocheck, onormalise - , defaultFlags, parseFlags + ( (^), oid, odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( HijackT, HijackOptions(..), runHijackT @@ -58,18 +53,15 @@ , tentativelyAddToPending, unrecordedChanges, applyToWorking , revertRepositoryChanges , setScriptsExecutablePatches - , listFiles ) import Darcs.Repository.Flags ( UpdateWorking(..), ExternalMerge(..) ) -import Darcs.Repository.Internal ( announceMergeConflicts ) -import Darcs.Repository.Merge ( tentativelyMergePatches ) -import Darcs.Repository.Prefs ( getPreflist ) +import Darcs.Repository.Merge ( tentativelyMergePatches, announceMergeConflicts ) import Darcs.Repository.Resolution ( standardResolution ) import Darcs.Patch ( invert, effect, commute, RepoPatch, description ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL ) -import Darcs.Patch.Info ( showPatchInfo ) +import Darcs.Patch.Info ( displayPatchInfo ) import Darcs.Patch.Match ( firstMatch, secondMatch, splitSecondFL ) import Darcs.Patch.Named ( Named, fmapFL_Named, patchcontents, patch2patchinfo ) import Darcs.Patch.Named.Wrapped ( mkRebase, toRebasing, fromRebasing ) @@ -116,9 +108,9 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.English ( englishNum, Noun(Noun) ) import Darcs.Util.Printer - ( vcat, text, ($$) + ( vcat, text, ($$), redText , putDocLnWith, simplePrinters - , renderString, RenderMode(..) + , renderString ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( debugMessage ) @@ -131,8 +123,6 @@ import Control.Monad.Trans ( liftIO ) import System.Exit ( exitSuccess ) -#include "impossible.h" - rebaseDescription :: String rebaseDescription = "Edit several patches at once." @@ -160,46 +150,6 @@ ] } -suspendBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> Maybe O.Summary - -> O.DiffAlgorithm - -> a) -suspendBasicOpts - = O.matchSeveralOrLast - ^ O.selectDeps - ^ O.interactive - ^ O.summary - ^ O.diffAlgorithm - -suspendAdvancedOpts :: DarcsOption a (Bool -> O.UseIndex -> a) -suspendAdvancedOpts - = O.changesReverse - ^ O.useIndex - -suspendOpts :: DarcsOption a - ([O.MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> Maybe O.Summary - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> Bool - -> O.UseIndex - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts - suspend :: DarcsCommand [DarcsFlag] suspend = DarcsCommand { commandProgramName = "darcs" @@ -210,7 +160,7 @@ , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = suspendCmd - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc suspendAdvancedOpts , commandBasicOptions = odesc suspendBasicOpts @@ -218,11 +168,22 @@ , commandCheckOptions = ocheck suspendOpts , commandParseOptions = onormalise suspendOpts } + where + suspendBasicOpts + = O.matchSeveralOrLast + ^ O.selectDeps + ^ O.interactive + ^ O.summary + ^ O.diffAlgorithm + suspendAdvancedOpts + = O.changesReverse + ^ O.useIndex + suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () suspendCmd _ opts _args = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - StartRebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + StartRebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \repository -> do allpatches <- readRepo repository (rOld, suspended, allpatches_tail) <- return $ takeHeadRebase allpatches @@ -230,7 +191,7 @@ return $ if firstMatch (parseFlags O.matchSeveralOrLast opts) then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail else matchingHead (parseFlags O.matchSeveralOrLast opts) allpatches_tail - let direction = if doReverse opts then Last else LastReversed + let direction = if changesReverse ? opts then Last else LastReversed patches_context = selectionContext direction "suspend" (patchSelOpts True opts) Nothing Nothing (_ :> psToSuspend) <- runSelection @@ -244,12 +205,12 @@ $ mapM_ (getAuthor "suspend" False Nothing) $ mapFL info psToSuspend repository' <- doSuspend opts repository suspended rOld psToSuspend - finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) + finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts) return () doSuspend :: forall p wR wU wT wX - . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + . (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository ('RepoType 'IsRebase) p wR wU wT -> Suspended p wT wT @@ -257,7 +218,9 @@ -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT -> IO (Repository ('RepoType 'IsRebase) p wR wU wX) doSuspend opts repository (Items qs) rOld psToSuspend = do - pend <- unrecordedChanges (diffingOpts opts) repository Nothing + pend <- unrecordedChanges (diffingOpts opts) + O.NoLookForMoves O.NoLookForReplaces + repository Nothing FlippedSeal psAfterPending <- let effectPsToSuspend = effect psToSuspend in case commute (effectPsToSuspend :> pend) of @@ -270,67 +233,30 @@ case (doPartition invPsEffect pend, doPartition pend invPsEffect) of (_ :> invSuspendedConflicts, _ :> pendConflicts) -> let suspendedConflicts = invert invSuspendedConflicts in - text "these changes in the suspended patches:" $$ + redText "These changes in the suspended patches:" $$ showNicely suspendedConflicts $$ - text "conflict with these local changes:" $$ + redText "...conflict with these local changes:" $$ showNicely pendConflicts - fail $ "Can't suspend selected patches without reverting some unrecorded change. Use --verbose to see the details." + fail $ "Can't suspend selected patches without reverting some unrecorded change." + ++ if (verbose opts) then "" else " Use --verbose to see the details." rNew <- mkRebase (Items (mapFL_FL (ToEdit . fromRebasing . hopefully) psToSuspend +>+ qs)) invalidateIndex repository - repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL)) + -- remove the old rebase patch and the patches to suspend + repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL)) tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect psToSuspend - repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) - _ <- applyToWorking repository'' (verbosity opts) (invert psAfterPending) + -- add the new rebase patch + repository'' <- tentativelyAddPatch repository' (compress ? opts) (unVerbose (verbosity ? opts)) YesUpdateWorking (n2pia rNew) + _ <- applyToWorking repository'' (verbosity ? opts) (invert psAfterPending) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) return repository'' -unsuspendBasicOpts :: DarcsOption a - (Maybe O.AllowConflicts - -> [O.MatchFlag] - -> Maybe Bool - -> Maybe O.Summary - -> ExternalMerge - -> Bool - -> Maybe String - -> O.DiffAlgorithm - -> a) -unsuspendBasicOpts - = O.conflicts O.YesAllowConflictsAndMark - ^ O.matchSeveralOrFirst - ^ O.interactive - ^ O.summary - ^ O.useExternalMerge - ^ O.keepDate - ^ O.author - ^ O.diffAlgorithm - -unsuspendAdvancedOpts :: DarcsOption a (O.UseIndex -> a) -unsuspendAdvancedOpts = O.useIndex - -unsuspendOpts :: DarcsOption a - (Maybe O.AllowConflicts - -> [O.MatchFlag] - -> Maybe Bool - -> Maybe O.Summary - -> ExternalMerge - -> Bool - -> Maybe String - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseIndex - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts +-- Certain repository functions will display the rebase patch in verbose mode +-- so we use this function to suppress it when passing the verbosity. +unVerbose :: O.Verbosity -> O.Verbosity +unVerbose O.Verbose = O.NormalVerbosity +unVerbose x = x unsuspend :: DarcsCommand [DarcsFlag] unsuspend = DarcsCommand @@ -342,7 +268,7 @@ , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unsuspendCmd False - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc unsuspendAdvancedOpts , commandBasicOptions = odesc unsuspendBasicOpts @@ -350,34 +276,18 @@ , commandCheckOptions = ocheck unsuspendOpts , commandParseOptions = onormalise unsuspendOpts } - -reifyBasicOpts :: DarcsOption a - ([O.MatchFlag] -> Maybe Bool -> Bool -> Maybe String -> O.DiffAlgorithm -> a) -reifyBasicOpts - = O.matchSeveralOrFirst - ^ O.interactive - ^ O.keepDate - ^ O.author - ^ O.diffAlgorithm - -reifyOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Bool - -> Bool - -> Maybe String - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -reifyOpts = reifyBasicOpts `withStdOpts` oid + where + unsuspendBasicOpts + = O.conflictsYes + ^ O.matchSeveralOrFirst + ^ O.interactive + ^ O.summary + ^ O.externalMerge + ^ O.keepDate + ^ O.author + ^ O.diffAlgorithm + unsuspendAdvancedOpts = O.useIndex + unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts reify :: DarcsCommand [DarcsFlag] reify = DarcsCommand @@ -389,7 +299,7 @@ , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unsuspendCmd True - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc reifyBasicOpts @@ -397,14 +307,24 @@ , commandCheckOptions = ocheck reifyOpts , commandParseOptions = onormalise reifyOpts } + where + reifyBasicOpts + = O.matchSeveralOrFirst + ^ O.interactive + ^ O.keepDate + ^ O.author + ^ O.diffAlgorithm + reifyOpts = reifyBasicOpts `withStdOpts` oid unsuspendCmd :: Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unsuspendCmd reifyFixups _ opts _args = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do patches <- readRepo repository - pend <- unrecordedChanges (diffingOpts opts) repository Nothing + pend <- unrecordedChanges (diffingOpts opts) + O.NoLookForMoves O.NoLookForReplaces + repository Nothing let checkChanges :: FL (PrimOf p) wA wB -> IO (EqCheck wA wB) checkChanges NilFL = return IsEq checkChanges _ = error "can't unsuspend when there are unrecorded changes" @@ -413,7 +333,7 @@ let selects = toRebaseSelect ps - let matchFlags = toMatchFlags opts + let matchFlags = matchAny ? opts inRange :> outOfRange <- return $ if secondMatch matchFlags then @@ -422,9 +342,9 @@ offer :> dontoffer <- return $ - if SkipConflicts `elem` opts - then partitionUnconflicted inRange - else inRange :> NilRL + case O.conflictsYes ? opts of + Nothing -> partitionUnconflicted inRange -- skip conflicts + Just _ -> inRange :> NilRL let warnSkip :: RL q wX wY -> IO () warnSkip NilRL = return () @@ -440,7 +360,7 @@ (ps_to_unsuspend :: FL (WDDNamed p) wR wZ) :> chosen_fixups <- (if reifyFixups then reifyRebaseSelect else return . extractRebaseSelect) chosen - let da = diffAlgorithm opts + let da = diffAlgorithm ? opts ps_to_keep = simplifyPushes da chosen_fixups . fromRebaseSelect $ keep +>+ reverseRL dontoffer +>+ outOfRange @@ -450,30 +370,29 @@ $ mapFL_FL (patchcontents . wddPatch) ps_to_unsuspend :: IO (Sealed (FL (PrimOf p) wZ)) - let merge_opts | NoAllowConflicts `elem` opts = opts - | AllowConflicts `elem` opts = opts - | otherwise = MarkConflicts : opts - - have_conflicts <- announceMergeConflicts "unsuspend" (allowConflicts merge_opts) (externalMerge merge_opts) standard_resolved_p + have_conflicts <- announceMergeConflicts "unsuspend" + (allowConflicts opts) (externalMerge ? opts) standard_resolved_p Sealed (resolved_p :: FL (PrimOf p) wA wB) <- - case (externalMerge opts, have_conflicts) of - (NoExternalMerge,_) -> return $ if AllowConflicts `elem` opts -- i.e. don't mark them - then seal NilFL - else seal standard_resolved_p - (_,False) -> return $ seal standard_resolved_p - (YesExternalMerge _, True) -> error "external resolution for unsuspend not implemented yet" + case (externalMerge ? opts, have_conflicts) of + (NoExternalMerge, _) -> + case O.conflictsYes ? opts of + Just O.YesAllowConflicts -> return $ seal NilFL -- i.e. don't mark them + _ -> return $ seal standard_resolved_p + (_, False) -> return $ seal standard_resolved_p + (YesExternalMerge _, True) -> + error "external resolution for unsuspend not implemented yet" let effect_to_apply = concatFL (mapFL_FL effect ps_to_unsuspend) +>+ resolved_p invalidateIndex repository - repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) + repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL) -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord tentativelyAddToPending repository' YesUpdateWorking effect_to_apply -- we can just let hijack attempts through here because we already asked about them on suspend time (repository'', renames) <- runHijackT IgnoreHijack $ doAdd repository' ps_to_unsuspend rNew <- unseal (mkRebase . Items) . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep - repository''' <- tentativelyAddPatch repository'' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) - finalizeRepositoryChanges repository''' YesUpdateWorking (compression opts) - _ <- applyToWorking repository''' (verbosity opts) effect_to_apply `catch` \(e :: IOException) -> + repository''' <- tentativelyAddPatch repository'' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew) + finalizeRepositoryChanges repository''' YesUpdateWorking (compress ? opts) + _ <- applyToWorking repository''' (verbosity ? opts) effect_to_apply `catch` \(e :: IOException) -> fail ("couldn't apply patch in working dir.\n" ++ show e) return () ) :: IO () @@ -493,8 +412,8 @@ ++ englishNum (length deps) (Noun "dependency") ":\n\n" let printIndented n = mapM_ (putStrLn . (replicate n ' '++)) . lines . - renderString Encode . showPatchInfo - putStrLn . renderString Encode . showPatchInfo . + renderString . displayPatchInfo + putStrLn . renderString . displayPatchInfo . patch2patchinfo $ wddPatch p putStr " depended on:\n" mapM_ (printIndented 2) deps @@ -504,14 +423,14 @@ p' <- snd <$> updatePatchHeader "unsuspend" NoAskAboutDeps (patchSelOpts True opts) - (diffAlgorithm opts) + (diffAlgorithm ? opts) (parseFlags O.keepDate opts) (parseFlags O.selectAuthor opts) (parseFlags O.author opts) (parseFlags O.patchname opts) (parseFlags O.askLongComment opts) (n2pia (toRebasing (wddPatch p))) NilFL - repo' <- liftIO $ tentativelyAddPatch repo (compression opts) (verbosity opts) YesUpdateWorking p' + repo' <- liftIO $ tentativelyAddPatch repo (compress ? opts) (verbosity ? opts) YesUpdateWorking p' -- create a rename that undoes the change we just made, so the contexts match up let rename :: RebaseName p wU wU rename = Rename (info p') (patch2patchinfo (wddPatch p)) @@ -524,26 +443,6 @@ return (repo'', rename2 :>: renames) -injectBasicOpts :: DarcsOption a (Bool -> Maybe String -> O.DiffAlgorithm -> a) -injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm - -injectOpts :: DarcsOption a - (Bool - -> Maybe String - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -injectOpts = injectBasicOpts `withStdOpts` oid - inject :: DarcsCommand [DarcsFlag] inject = DarcsCommand { commandProgramName = "darcs" @@ -554,7 +453,7 @@ , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = injectCmd - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc injectBasicOpts @@ -562,11 +461,14 @@ , commandCheckOptions = ocheck injectOpts , commandParseOptions = onormalise injectOpts } + where + injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm + injectOpts = injectBasicOpts `withStdOpts` oid injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () injectCmd _ opts _args = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do patches <- readRepo repository @@ -588,7 +490,7 @@ name_fixups :> prim_fixups <- return $ flToNamesPrims fixups - let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm opts))) Nothing Nothing + let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm ? opts))) Nothing Nothing (rest_fixups :> injects) <- runSelection prim_fixups changes_context when (nullFL injects) $ do @@ -596,36 +498,18 @@ exitSuccess -- Don't bother to update patch header since unsuspend will do that later - let da = diffAlgorithm opts + let da = diffAlgorithm ? opts toeditNew = fmapFL_Named (mapFL_FL fromPrim . canonizeFL da . (injects +>+) . effect) toedit rNew <- unseal (mkRebase . Items) $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $ ToEdit toeditNew :>: fromRebaseSelect rest_selects - repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) - repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) - finalizeRepositoryChanges repository'' YesUpdateWorking (compression opts) + repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL) + repository'' <- tentativelyAddPatch repository' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew) + finalizeRepositoryChanges repository'' YesUpdateWorking (compress ? opts) return () -obliterateBasicOpts :: DarcsOption a (O.DiffAlgorithm -> a) -obliterateBasicOpts = O.diffAlgorithm - -obliterateOpts :: DarcsOption a - (O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -obliterateOpts = obliterateBasicOpts `withStdOpts` oid - obliterate :: DarcsCommand [DarcsFlag] obliterate = DarcsCommand { commandProgramName = "darcs" @@ -636,7 +520,7 @@ , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = obliterateCmd - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc obliterateBasicOpts @@ -644,11 +528,14 @@ , commandCheckOptions = ocheck obliterateOpts , commandParseOptions = onormalise obliterateOpts } + where + obliterateBasicOpts = O.diffAlgorithm + obliterateOpts = obliterateBasicOpts `withStdOpts` oid obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd _ opts _args = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do patches <- readRepo repository @@ -662,7 +549,7 @@ when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess - let da = diffAlgorithm opts + let da = diffAlgorithm ? opts do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) do_obliterate NilFL = Sealed do_obliterate (Fixup f :>: qs) = unseal (simplifyPush da f) . do_obliterate qs @@ -675,9 +562,9 @@ let ps_to_keep = do_obliterate (fromRebaseSelect chosen) (fromRebaseSelect keep) rNew <- unseal (mkRebase . Items) ps_to_keep - repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) - repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) - finalizeRepositoryChanges repository'' YesUpdateWorking (compression opts) + repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL) + repository'' <- tentativelyAddPatch repository' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew) + finalizeRepositoryChanges repository'' YesUpdateWorking (compress ? opts) return () ) :: IO () @@ -690,96 +577,6 @@ pullHelp = "Copy and apply patches from another repository, suspending any local patches that conflict." -pullBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> O.Reorder - -> Maybe Bool - -> Maybe O.AllowConflicts - -> ExternalMerge - -> O.RunTest - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Bool - -> O.DiffAlgorithm - -> a) -pullBasicOpts - = O.matchSeveral - ^ O.reorder - ^ O.interactive - ^ O.conflicts O.YesAllowConflictsAndMark - ^ O.useExternalMerge - ^ O.test - ^ O.dryRunXml - ^ O.summary - ^ O.selectDeps - ^ O.setDefault - ^ O.workingRepoDir - ^ O.allowUnrelatedRepos - ^ O.diffAlgorithm - -pullAdvancedOpts :: DarcsOption a - (O.RepoCombinator - -> O.Compression - -> O.UseIndex - -> O.RemoteRepos - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.NetworkOptions - -> a) -pullAdvancedOpts - = O.repoCombinator - ^ O.compress - ^ O.useIndex - ^ O.remoteRepos - ^ O.setScriptsExecutable - ^ O.umask - ^ O.restrictPaths - ^ O.changesReverse - ^ O.network - -pullOpts :: DarcsOption a - ([O.MatchFlag] - -> O.Reorder - -> Maybe Bool - -> Maybe O.AllowConflicts - -> ExternalMerge - -> O.RunTest - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Bool - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.RepoCombinator - -> O.Compression - -> O.UseIndex - -> O.RemoteRepos - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts - pull :: DarcsCommand [DarcsFlag] pull = DarcsCommand { commandProgramName = "darcs" @@ -790,7 +587,7 @@ , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = pullCmd RebasePatchApplier , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = getPreflist "repos" + , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc pullAdvancedOpts , commandBasicOptions = odesc pullBasicOpts @@ -798,6 +595,32 @@ , commandCheckOptions = ocheck pullOpts , commandParseOptions = onormalise pullOpts } + where + pullBasicOpts + = O.matchSeveral + ^ O.reorder + ^ O.interactive + ^ O.conflictsYes + ^ O.externalMerge + ^ O.runTest + ^ O.dryRunXml + ^ O.summary + ^ O.selectDeps + ^ O.setDefault + ^ O.repoDir + ^ O.allowUnrelatedRepos + ^ O.diffAlgorithm + pullAdvancedOpts + = O.repoCombinator + ^ O.compress + ^ O.useIndex + ^ O.remoteRepos + ^ O.setScriptsExecutable + ^ O.umask + ^ O.restrictPaths + ^ O.changesReverse + ^ O.network + pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts applyDescription :: String applyDescription = "Apply a patch bundle, suspending any local patches that conflict." @@ -819,7 +642,7 @@ , commandExtraArgHelp = [""] , commandCommand = applyCmd RebasePatchApplier , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listFiles False + , commandCompleteArgs = fileArgs , commandArgdefaults = const stdindefault , commandAdvancedOptions = odesc applyAdvancedOpts , commandBasicOptions = odesc applyBasicOpts @@ -827,85 +650,28 @@ , commandCheckOptions = ocheck applyOpts , commandParseOptions = onormalise applyOpts } - -applyBasicOpts :: DarcsOption a - (O.Verify - -> O.Reorder - -> Maybe Bool - -> O.DryRun - -> O.XmlOutput - -> [O.MatchFlag] - -> Maybe String - -> O.DiffAlgorithm - -> a) -applyBasicOpts - = O.verify - ^ O.reorder - ^ O.interactive - ^ O.dryRunXml - ^ O.matchSeveral - ^ O.workingRepoDir - ^ O.diffAlgorithm - -applyAdvancedOpts :: DarcsOption a - (Maybe String - -> Maybe String - -> Bool - -> (Bool, Maybe String) - -> O.UseIndex - -> O.Compression - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.WantGuiPause - -> a) -applyAdvancedOpts - = O.reply - ^ O.ccApply - ^ O.happyForwarding - ^ O.sendmail - ^ O.useIndex - ^ O.compress - ^ O.setScriptsExecutable - ^ O.umask - ^ O.restrictPaths - ^ O.changesReverse - ^ O.pauseForGui - -applyOpts :: DarcsOption a - (O.Verify - -> O.Reorder - -> Maybe Bool - -> O.DryRun - -> O.XmlOutput - -> [O.MatchFlag] - -> Maybe String - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> Maybe String - -> Maybe String - -> Bool - -> (Bool, Maybe String) - -> O.UseIndex - -> O.Compression - -> O.SetScriptsExecutable - -> O.UMask - -> Bool - -> Bool - -> O.WantGuiPause - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) - -applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts + where + applyBasicOpts + = O.verify + ^ O.reorder + ^ O.interactive + ^ O.dryRunXml + ^ O.matchSeveral + ^ O.repoDir + ^ O.diffAlgorithm + applyAdvancedOpts + = O.reply + ^ O.ccApply + ^ O.happyForwarding + ^ O.sendmail + ^ O.useIndex + ^ O.compress + ^ O.setScriptsExecutable + ^ O.umask + ^ O.restrictPaths + ^ O.changesReverse + ^ O.pauseForGui + applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts data RebasePatchApplier = RebasePatchApplier @@ -914,14 +680,13 @@ repoJob RebasePatchApplier opts f = StartRebaseJob - (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) + (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) (f PatchProxy) applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd applyPatchesForRebaseCmd :: forall p wR wU wX wT wZ - . ( RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree - ) + . ( RepoPatch p, ApplyState p ~ Tree ) => String -> [DarcsFlag] -> String @@ -931,10 +696,10 @@ -> IO () applyPatchesForRebaseCmd cmdName opts _from_whom repository us' to_be_applied = do printDryRunMessageAndExit cmdName - (verbosity opts) - (hasSummary O.NoSummary opts) - (dryRun opts) - (hasXmlOutput opts) + (verbosity ? opts) + (O.summary ? opts) + (dryRun ? opts) + (xmlOutput ? opts) (isInteractive True opts) to_be_applied setEnvDarcsPatches to_be_applied @@ -962,27 +727,30 @@ (rOld, suspended, _) <- return $ takeHeadRebaseFL us' repository' <- doSuspend opts repository suspended rOld usToSuspend + -- the new rebase patch containing the suspended patches is now in the repo + -- and the suspended patches have been removed -- TODO This is a nasty hack, caused by the fact that readUnrecorded -- claims to read the tentative state but actual reads the committed state -- as a result we have to commit here so that tentativelyMergePatches does -- the right thing. - finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) + finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts) >> revertRepositoryChanges repository' YesUpdateWorking Sealed pw <- tentativelyMergePatches repository' cmdName (allowConflicts opts) YesUpdateWorking - (externalMerge opts) - (wantGuiPause opts) (compression opts) (verbosity opts) - (reorder opts) (diffingOpts opts) + (externalMerge ? opts) + (wantGuiPause opts) (compress ? opts) (verbosity ? opts) + (reorder ? opts) (diffingOpts opts) (usOk +>+ usKeep) to_be_applied invalidateIndex repository - finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) - _ <- revertable $ applyToWorking repository' (verbosity opts) pw - when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches pw + finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts) + _ <- revertable $ applyToWorking repository' (verbosity ? opts) pw + when (O.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $ + setScriptsExecutablePatches pw putInfo opts $ text $ "Finished " ++ cmdName ++ "ing." -- TODO I doubt this is right, e.g. withContext should be inherited @@ -1003,11 +771,11 @@ patchSelOpts :: Bool -> [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts defInteractive flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.interactive = isInteractive defInteractive flags - , S.selectDeps = selectDeps flags - , S.summary = hasSummary O.NoSummary flags + , S.selectDeps = selectDeps ? flags + , S.summary = O.summary ? flags , S.withContext = O.NoContext } @@ -1021,7 +789,7 @@ , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = logCmd - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc logAdvancedOpts , commandBasicOptions = odesc logBasicOpts @@ -1029,39 +797,15 @@ , commandCheckOptions = ocheck logOpts , commandParseOptions = onormalise logOpts } - -logBasicOpts :: DarcsOption a - (Maybe O.Summary - -> Maybe Bool - -> a) -logBasicOpts - = O.summary - ^ O.interactive -- False - -logAdvancedOpts :: DarcsOption a a -logAdvancedOpts = oid - -logOpts :: DarcsOption a - (Maybe O.Summary - -> Maybe Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) - -logOpts = logBasicOpts `withStdOpts` logAdvancedOpts + where + logBasicOpts = O.summary ^ O.interactive -- False + logAdvancedOpts = oid + logOpts = logBasicOpts `withStdOpts` logAdvancedOpts logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd _ opts _files = - withRepository (useCache opts) $ - RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ \repository -> do + withRepository (useCache ? opts) $ + RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \repository -> do patches <- readRepo repository (_, Items ps, _) <- return $ takeHeadRebase patches let psToShow = toRebaseChanges ps @@ -1069,14 +813,14 @@ then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow) else do debugMessage "About to print the changes..." - let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters + let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters emptyPatchSet = PatchSet NilRL NilRL patchSet = appendPSFL emptyPatchSet psToShow logInfo <- getLogInfo - (maxCount opts) - (toMatchFlags opts) - (showChangesOnlyToFiles opts) + (maxCount ? opts) + (matchAny ? opts) + (onlyToFiles ? opts) Nothing (\_ qs -> return qs) patchSet diff --git a/src/Darcs/UI/Commands/Record.hs b/src/Darcs/UI/Commands/Record.hs --- a/src/Darcs/UI/Commands/Record.hs +++ b/src/Darcs/UI/Commands/Record.hs @@ -15,7 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Record @@ -43,16 +42,13 @@ , tentativelyAddPatch , finalizeRepositoryChanges , invalidateIndex - , unrecordedChangesWithPatches + , unrecordedChanges , readRecorded - , listRegisteredFiles ) import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, fromPrims ) import Darcs.Patch.Named.Wrapped ( namepatch, adddeps ) -import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Split ( primSplitter ) @@ -74,6 +70,7 @@ ) import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths, testTentativeAndMaybeExit ) +import Darcs.UI.Completion ( modifiedFileArgs ) import Darcs.UI.Flags ( DarcsFlag , fileHelpAuthor @@ -87,7 +84,6 @@ import Darcs.UI.PatchHeader ( getLog ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun), ScanKnown(..) ) -import Darcs.Repository.State ( getMovesPs, getReplaces ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Progress ( debugMessage ) @@ -127,10 +123,10 @@ ^ O.testChanges ^ O.interactive ^ O.pipe - ^ O.askdeps + ^ O.askDeps ^ O.askLongComment ^ O.lookfor - ^ O.workingRepoDir + ^ O.repoDir ^ O.withContext ^ O.diffAlgorithm @@ -138,37 +134,6 @@ (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.IncludeBoring -> a) recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable ^ O.includeBoring -recordOpts :: DarcsOption a - (Maybe String - -> Maybe String - -> O.TestChanges - -> Maybe Bool - -> Bool - -> Bool - -> Maybe O.AskLongComment - -> O.LookFor - -> Maybe String - -> O.WithContext - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.Logfile - -> O.Compression - -> O.UseIndex - -> O.UMask - -> O.SetScriptsExecutable - -> O.IncludeBoring - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts - data RecordConfig = RecordConfig { patchname :: Maybe String , author :: Maybe String @@ -204,14 +169,16 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = recordCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = modifiedFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc recordAdvancedOpts , commandBasicOptions = odesc recordBasicOpts , commandDefaults = defaultFlags recordOpts , commandCheckOptions = ocheck recordOpts , commandParseOptions = recordConfig -} + } + where + recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts -- | commit is an alias for record commit :: DarcsCommand RecordConfig @@ -232,7 +199,11 @@ files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." - files' <- traverse (filterExistingPaths repository (verbosity cfg) (useIndex cfg) scan) files + files' <- + traverse + (filterExistingPaths + repository (verbosity cfg) (useIndex cfg) scan (O.moves (lookfor cfg))) + files when (verbosity cfg /= O.Quiet) $ traverse_ (reportNonExisting scan) files' let files'' = fmap snd files' @@ -241,15 +212,9 @@ return files'' announceFiles (verbosity cfg) existing_files "Recording changes in" debugMessage "About to get the unrecorded changes." - Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces - then getReplaces (diffingOpts cfg) repository existing_files - else return (Sealed NilFL) - movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves - then getMovesPs repository existing_files - else return NilFL - changes <- unrecordedChangesWithPatches - movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) - (diffingOpts cfg) repository existing_files + changes <- unrecordedChanges (diffingOpts cfg) + (O.moves (lookfor cfg)) (O.replaces (lookfor cfg)) + repository existing_files debugMessage "I've got unrecorded changes." case changes of NilFL | not (askDeps cfg) -> do @@ -270,7 +235,7 @@ confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?" unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure -doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO () doRecord repository cfg files ps = do date <- getDate (pipe cfg) @@ -361,7 +326,7 @@ , "record failed and left a `_darcs/patch_description.txt` file." , "" , unlines fileHelpAuthor - , "If you want to manually define any extra dependencies for your patch," + , "If you want to manually define any explicit dependencies for your patch," , "you can use the `--ask-deps` flag. Some dependencies may be automatically" , "inferred from the patch's content and cannot be removed. A patch with" , "specific dependencies can be empty." diff --git a/src/Darcs/UI/Commands/Remove.hs b/src/Darcs/UI/Commands/Remove.hs --- a/src/Darcs/UI/Commands/Remove.hs +++ b/src/Darcs/UI/Commands/Remove.hs @@ -15,25 +15,24 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Remove ( remove, rm, unadd ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import Control.Monad ( when, foldM ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, - commandAlias, commandStub, - putWarning - , amInHashedRepository - ) -import Darcs.UI.Commands.Add( expandDirs ) +import Darcs.UI.Commands + ( DarcsCommand(..) + , withStdOpts, nodefaults + , commandAlias, commandStub + , putWarning, putInfo + , amInHashedRepository + ) +import Darcs.UI.Commands.Util ( expandDirs ) +import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags - ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, fixSubPaths, verbosity ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) + ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, fixSubPaths, quiet ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository @@ -43,7 +42,6 @@ , addToPending , readRecordedAndPending , readUnrecorded - , listRegisteredFiles ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile, @@ -55,8 +53,7 @@ import Darcs.Util.Tree( Tree, TreeItem(..), find, modifyTree, expand, list ) import Darcs.Util.Path( anchorPath, AnchoredPath, fn2fp, SubPath, sp2fn , AbsolutePath, floatPath ) -import Darcs.Util.Printer ( text ) - +import Darcs.Util.Printer ( text, vcat ) removeDescription :: String removeDescription = "Remove files from version control." @@ -72,29 +69,6 @@ "Note that applying a removal patch to a repository (e.g. by pulling\n" ++ "the patch) will ALWAYS affect the working tree of that repository.\n" -removeBasicOpts :: DarcsOption a (Maybe String -> Bool -> a) -removeBasicOpts = O.workingRepoDir ^ O.recursive - -removeAdvancedOpts :: DarcsOption a (O.UMask -> a) -removeAdvancedOpts = O.umask - -removeOpts :: DarcsOption a - (Maybe String - -> Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts - remove :: DarcsCommand [DarcsFlag] remove = DarcsCommand { commandProgramName = "darcs" @@ -105,7 +79,7 @@ , commandExtraArgHelp = [" ..."] , commandCommand = removeCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc removeAdvancedOpts , commandBasicOptions = odesc removeBasicOpts @@ -113,6 +87,10 @@ , commandCheckOptions = ocheck removeOpts , commandParseOptions = onormalise removeOpts } + where + removeBasicOpts = O.repoDir ^ O.recursive + removeAdvancedOpts = O.umask + removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () removeCmd fps opts relargs = do @@ -121,17 +99,17 @@ origfiles <- fixSubPaths fps relargs when (null origfiles) $ fail "No valid arguments were given." - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ + RepoJob $ \repository -> do args <- if parseFlags O.recursive opts then reverse `fmap` expandDirs False origfiles else return origfiles Sealed p <- makeRemovePatch opts repository args - let notQuiet = verbosity opts /= O.Quiet - when (nullFL p && not (null origfiles) && notQuiet) $ + -- TODO whether command fails depends on verbosity BAD BAD BAD + when (nullFL p && not (null origfiles) && not (quiet opts)) $ fail "No files were removed." addToPending repository YesUpdateWorking p - when notQuiet $ - putStr $ unlines $ ["Will stop tracking:"] ++ listTouchedFiles p + putInfo opts $ vcat $ map text $ ["Will stop tracking:"] ++ listTouchedFiles p -- | makeRemovePatch builds a list of patches to remove the given filepaths. -- This function does not recursively process directories. The 'Recursive' @@ -176,7 +154,7 @@ then skipAndWarn "it is not empty" else return $ Just $ freeGap (rmdir f_fp :>: NilFL) (Just (File _), Just (File _)) -> do - Just `fmap` treeDiff (diffAlgorithm opts) ftf unrecorded unrecorded' + Just `fmap` treeDiff (diffAlgorithm ? opts) ftf unrecorded unrecorded' (Just (File _), _) -> return $ Just $ freeGap (addfile f_fp :>: rmfile f_fp :>: NilFL) (Just (SubTree _), _) -> diff --git a/src/Darcs/UI/Commands/Repair.hs b/src/Darcs/UI/Commands/Repair.hs --- a/src/Darcs/UI/Commands/Repair.hs +++ b/src/Darcs/UI/Commands/Repair.hs @@ -15,11 +15,8 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.UI.Commands.Repair - ( - repair - , check - ) where +{-# LANGUAGE RecordWildCards #-} +module Darcs.UI.Commands.Repair ( repair, check ) where import Prelude () import Darcs.Prelude @@ -30,29 +27,39 @@ import System.Directory( renameFile ) import System.FilePath ( () ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putInfo, commandAlias, amInHashedRepository ) -import Darcs.UI.Flags as F - ( DarcsFlag(Quiet,DryRun) - , verbosity, dryRun, umask, useIndex - , useCache, compression, diffAlgorithm ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Commands + ( DarcsCommand(..), withStdOpts, nodefaults + , putInfo, amInHashedRepository + ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Flags + ( DarcsFlag, verbosity, dryRun, umask, useIndex + , useCache, compress, diffAlgorithm, quiet + ) +import Darcs.UI.Options + ( DarcsOption, (^), oid + , odesc, ocheck, onormalise, defaultFlags, (?) + ) import qualified Darcs.UI.Options.All as O + import Darcs.Repository.Flags ( UpdateWorking (..) ) -import Darcs.Repository.Repair( replayRepository, checkIndex, - replayRepositoryInTemp, - RepositoryConsistency(..) ) -import Darcs.Repository ( Repository, withRepository, - readRecorded, RepoJob(..), - withRepoLock, replacePristine, writePatchSet ) -import Darcs.Patch ( IsRepoType, RepoPatch, showPatch, PrimOf ) -import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch.Witnesses.Ordered ( FL(..) ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft ) +import Darcs.Repository.Repair + ( replayRepository, checkIndex, replayRepositoryInTemp + , RepositoryConsistency(..) + ) +import Darcs.Repository + ( Repository, withRepository, readRecorded, RepoJob(..) + , withRepoLock, replacePristine, writePatchSet + ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Repository.Diff( treeDiff ) + +import Darcs.Patch ( RepoPatch, showNicely, PrimOf ) +import Darcs.Patch.Witnesses.Ordered ( FL(..) ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft ) + import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Printer ( text, ($$), (<+>) ) -import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Tree( Tree ) @@ -71,31 +78,9 @@ "unsuccessfully (with a non-zero exit status) if the rebuilt pristine is\n" ++ "different from the current pristine.\n" -repairBasicOpts :: DarcsOption a - (Maybe String -> O.UseIndex -> O.DryRun -> O.DiffAlgorithm -> a) -repairBasicOpts = O.workingRepoDir ^ O.useIndex ^ O.dryRun ^ O.diffAlgorithm - -repairAdvancedOpts :: DarcsOption a (O.UMask -> a) -repairAdvancedOpts = O.umask - -repairOpts :: DarcsOption a - (Maybe String - -> O.UseIndex - -> O.DryRun - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -repairOpts = repairBasicOpts `withStdOpts` repairAdvancedOpts +commonBasicOpts :: DarcsOption a + (Maybe String -> O.UseIndex -> O.DiffAlgorithm -> a) +commonBasicOpts = O.repoDir ^ O.useIndex ^ O.diffAlgorithm repair :: DarcsCommand [DarcsFlag] repair = DarcsCommand @@ -105,82 +90,108 @@ , commandDescription = repairDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] - , commandCommand = repairCmd + , commandCommand = withFpsAndArgs repairCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults - , commandAdvancedOptions = odesc repairAdvancedOpts - , commandBasicOptions = odesc repairBasicOpts - , commandDefaults = defaultFlags repairOpts - , commandCheckOptions = ocheck repairOpts - , commandParseOptions = onormalise repairOpts + , .. } + where + basicOpts = commonBasicOpts ^ O.dryRun + advancedOpts = O.umask + allOpts = basicOpts `withStdOpts` advancedOpts + commandAdvancedOptions = odesc advancedOpts + commandBasicOptions = odesc basicOpts + commandDefaults = defaultFlags allOpts + commandCheckOptions = ocheck allOpts + commandParseOptions = onormalise allOpts -repairCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -repairCmd _ opts _ - | DryRun `elem` opts = withRepository (useCache opts) (RepoJob (check' opts)) - | otherwise = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do - replayRepository (F.diffAlgorithm opts) repository (compression opts) (verbosity opts) $ \state -> - case state of - RepositoryConsistent -> - putStrLn "The repository is already consistent, no changes made." - BrokenPristine tree -> do - putStrLn "Fixing pristine tree..." - replacePristine repository tree - BrokenPatches tree newps -> do - putStrLn "Writing out repaired patches..." - _ <- writePatchSet newps (useCache opts) - putStrLn "Fixing pristine tree..." - replacePristine repository tree - index_ok <- checkIndex repository (Quiet `elem` opts) - unless index_ok $ do renameFile (darcsdir "index") (darcsdir "index.bad") - putStrLn "Bad index discarded." +withFpsAndArgs :: (b -> d) -> a -> b -> c -> d +withFpsAndArgs cmd _ opts _ = cmd opts -check' - :: forall rt p wR wU wT . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> Repository rt p wR wU wT -> IO () -check' opts repository = do - state <- replayRepositoryInTemp (F.diffAlgorithm opts) repository (compression opts) (verbosity opts) +repairCmd :: [DarcsFlag] -> IO () +repairCmd opts = case dryRun ? opts of + O.YesDryRun -> checkCmd opts + O.NoDryRun -> + withRepoLock O.NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) + $ RepoJob $ \repository -> do + replayRepository (diffAlgorithm ? opts) repository (compress ? opts) (verbosity ? opts) $ \state -> + case state of + RepositoryConsistent -> + putStrLn "The repository is already consistent, no changes made." + BrokenPristine tree -> do + putStrLn "Fixing pristine tree..." + replacePristine repository tree + BrokenPatches tree newps -> do + putStrLn "Writing out repaired patches..." + _ <- writePatchSet newps (useCache ? opts) + putStrLn "Fixing pristine tree..." + replacePristine repository tree + index_ok <- checkIndex repository (quiet opts) + unless index_ok $ do renameFile (darcsdir "index") (darcsdir "index.bad") + putStrLn "Bad index discarded." + +-- |check is an alias for repair, with implicit DryRun flag. +check :: DarcsCommand [DarcsFlag] +check = DarcsCommand + { commandProgramName = "darcs" + , commandName = "check" + , commandHelp = "See `darcs repair` for details." + , commandExtraArgs = 0 + , commandExtraArgHelp = [] + , commandCommand = withFpsAndArgs checkCmd + , commandPrereq = amInHashedRepository + , commandCompleteArgs = noArgs + , commandArgdefaults = nodefaults + , .. + } + where + basicOpts = commonBasicOpts + advancedOpts = oid + allOpts = basicOpts `withStdOpts` advancedOpts + commandAdvancedOptions = odesc advancedOpts + commandBasicOptions = odesc basicOpts + commandDefaults = defaultFlags allOpts + commandCheckOptions = ocheck allOpts + commandParseOptions = onormalise allOpts + commandDescription = "Alias for `darcs " ++ commandName repair ++ " --dry-run'." + +checkCmd :: [DarcsFlag] -> IO () +checkCmd opts = withRepository (useCache ? opts) $ RepoJob $ \repository -> do + state <- replayRepositoryInTemp (diffAlgorithm ? opts) repository (compress ? opts) (verbosity ? opts) failed <- case state of RepositoryConsistent -> do putInfo opts $ text "The repository is consistent!" return False BrokenPristine newpris -> do - brokenPristine newpris + brokenPristine opts repository newpris return True BrokenPatches newpris _ -> do - brokenPristine newpris + brokenPristine opts repository newpris putInfo opts $ text "Found broken patches." return True - bad_index <- if useIndex opts == O.IgnoreIndex + bad_index <- if useIndex ? opts == O.IgnoreIndex then return False - else not <$> checkIndex repository (Quiet `elem` opts) + else not <$> checkIndex repository (quiet opts) when bad_index $ putInfo opts $ text "Bad index." exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess - where - brokenPristine newpris = do - putInfo opts $ text "Looks like we have a difference..." - mc' <- (Just `fmap` readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing) - case mc' of - Nothing -> do - putInfo opts $ text "cannot compute that difference, try repair" - putInfo opts $ text "" $$ text "Inconsistent repository" - Just mc -> do - ftf <- filetypeFunction - Sealed (diff :: FL (PrimOf p) wR wR2) - <- unFreeLeft `fmap` treeDiff (F.diffAlgorithm opts) ftf newpris mc :: IO (Sealed (FL (PrimOf p) wR)) - putInfo opts $ case diff of - NilFL -> text "Nothing" - patch -> text "Difference: " <+> showPatch patch - putInfo opts $ text "" $$ text "Inconsistent repository!" --- |check is an alias for repair, with implicit DryRun flag. -check :: DarcsCommand [DarcsFlag] -check = checkAlias { commandCommand = checkCmd - , commandDescription = checkDesc - } - where - checkAlias = commandAlias "check" Nothing repair - checkCmd fps fs = commandCommand repair fps (DryRun : fs) - checkDesc = "Alias for `darcs " ++ commandName repair ++ " --dry-run'." +brokenPristine + :: forall rt p wR wU wT . (RepoPatch p) + => [DarcsFlag] -> Repository rt p wR wU wT -> Tree IO -> IO () +brokenPristine opts repository newpris = do + putInfo opts $ text "Looks like we have a difference..." + mc' <- (Just `fmap` readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing) + case mc' of + Nothing -> do + putInfo opts $ text "cannot compute that difference, try repair" + putInfo opts $ text "" $$ text "Inconsistent repository" + Just mc -> do + ftf <- filetypeFunction + Sealed (diff :: FL (PrimOf p) wR wR2) + <- unFreeLeft `fmap` treeDiff (diffAlgorithm ? opts) ftf newpris mc :: IO (Sealed (FL (PrimOf p) wR)) + putInfo opts $ case diff of + NilFL -> text "Nothing" + patch -> text "Difference: " <+> showNicely patch + putInfo opts $ text "" $$ text "Inconsistent repository!" diff --git a/src/Darcs/UI/Commands/Replace.hs b/src/Darcs/UI/Commands/Replace.hs --- a/src/Darcs/UI/Commands/Replace.hs +++ b/src/Darcs/UI/Commands/Replace.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Replace ( replace , defaultToks @@ -27,7 +25,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as BS +import qualified Data.ByteString as B import Data.Char ( isSpace ) import Data.Maybe ( isJust ) import Control.Exception ( catch, IOException ) @@ -36,14 +34,15 @@ , makeBlobBS ) import Darcs.Util.Path( SubPath, toFilePath, AbsolutePath ) import Darcs.UI.Flags - ( DarcsFlag( ForceReplace, Toks ) + ( DarcsFlag , verbosity, useCache, dryRun, umask, diffAlgorithm, fixSubPaths ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) +import Darcs.UI.Completion ( knownFileArgs ) import Darcs.Repository.Diff( treeDiff ) -import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace +import Darcs.Patch ( PrimPatch, tokreplace, forceTokReplace , maybeApplyToTree ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.RegChars ( regChars ) @@ -53,8 +52,6 @@ , addToPending , applyToWorking , readUnrecorded - , readRecordedAndPending - , listRegisteredFiles ) import Darcs.Patch.TokenReplace ( defaultToks ) import Darcs.Repository.Prefs ( FileType(TextFile) ) @@ -62,8 +59,6 @@ import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal ) -#include "impossible.h" - replaceDescription :: String replaceDescription = "Substitute one word for another." @@ -123,31 +118,6 @@ "`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently\n" ++ "treated as a simple set of characters.\n" -replaceBasicOpts :: DarcsOption a (Maybe String -> Bool -> Maybe String -> a) -replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.workingRepoDir - -replaceAdvancedOpts :: DarcsOption a (O.UseIndex -> O.UMask -> a) -replaceAdvancedOpts = O.useIndex ^ O.umask - -replaceOpts :: DarcsOption a - (Maybe String - -> Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseIndex - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -replaceOpts = replaceBasicOpts `withStdOpts` replaceAdvancedOpts - replace :: DarcsCommand [DarcsFlag] replace = DarcsCommand { commandProgramName = "darcs" @@ -161,7 +131,7 @@ ] , commandCommand = replaceCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = replaceArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc replaceAdvancedOpts , commandBasicOptions = odesc replaceBasicOpts @@ -169,27 +139,35 @@ , commandCheckOptions = ocheck replaceOpts , commandParseOptions = onormalise replaceOpts } + where + replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.repoDir + replaceAdvancedOpts = O.useIndex ^ O.umask + replaceOpts = replaceBasicOpts `withStdOpts` replaceAdvancedOpts +replaceArgs :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String] +replaceArgs fps flags args = + if length args < 2 + then return [] + else knownFileArgs fps flags args + replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () replaceCmd fps opts (old : new : relfs@(_ : _)) = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do fs <- fixSubPaths fps relfs - toks <- chooseToks opts old new + toks <- chooseToks (O.tokens ? opts) old new let checkToken tok = unless (isTok toks tok) $ fail $ "'" ++ tok ++ "' is not a valid token!" mapM_ checkToken [ old, new ] working <- readUnrecorded repository Nothing - pending <- readRecordedAndPending repository files <- filterM (exists working) fs Sealed replacePs <- mapSeal concatFL . toFL <$> - mapM (doReplace toks pending working) files + mapM (doReplace toks working) files + -- Note: addToPending takes care of commuting the replace patch and + -- everything it depends on past the diff between pending and working addToPending repository YesUpdateWorking replacePs - void $ applyToWorking repository (verbosity opts) replacePs `catch` \(e :: IOException) -> - fail $ "Can't do replace on working!\n" - ++ "Perhaps one of the files already" ++ " contains '" - ++ new ++ "'?\n" - ++ show e + void $ applyToWorking repository (verbosity ? opts) replacePs `catch` \(e :: IOException) -> + bug $ "Can't do replace on working!\n" ++ show e where exists tree file = if isJust $ findFile tree (floatSubPath file) then return True @@ -199,20 +177,19 @@ skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository." - doReplace :: forall prim . (Patchy prim, PrimPatch prim, - ApplyState prim ~ Tree) => String -> Tree IO -> Tree IO + doReplace :: forall prim . (PrimPatch prim, + ApplyState prim ~ Tree) => String -> Tree IO -> SubPath -> IO (FreeLeft (FL prim)) - doReplace toks pend work f = do - let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p - workReplaced <- maybeReplace work - pendReplaced <- maybeReplace pend - if workReplaced && pendReplaced - then return $ joinGap (:>:) (freeGap replacePatch) gapNilFL - else if ForceReplace `elem` opts - then getForceReplace f toks work - else putStrLn existsMsg >> return gapNilFL + doReplace toks work f = do + workReplaced <- maybeApplyToTree replacePatch work + case workReplaced of + Just _ -> do + return $ joinGap (:>:) (freeGap replacePatch) gapNilFL + Nothing + | O.forceReplace ? opts -> getForceReplace f toks work + | otherwise -> putStrLn existsMsg >> return gapNilFL where - existsMsg = "Skipping file '" ++ fp ++ "'\nPerhaps the recorded" + existsMsg = "Skipping file '" ++ fp ++ "'\nPerhaps the working" ++ " version of this file already contains '" ++ new ++ "'?\nUse the --force option to override." gapNilFL = emptyGap NilFL @@ -231,9 +208,9 @@ let path = floatSubPath f content <- readBlob $ fromJust $ findFile tree path let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old) - (BS.concat $ BL.toChunks content) + (B.concat $ BL.toChunks content) tree' = modifyTree tree path . Just . File $ makeBlobBS newcontent - normaliseNewTokPatch <- treeDiff (diffAlgorithm opts) ftf tree tree' + normaliseNewTokPatch <- treeDiff (diffAlgorithm ? opts) ftf tree tree' unless (unseal nullFL (unFreeLeft normaliseNewTokPatch)) $ putStrLn $ "Don't be surprised!\n" ++ "I've changed all instances of '" ++ new ++ "' to '" @@ -243,7 +220,7 @@ return . joinGap (+>+) normaliseNewTokPatch $ freeGap $ tokreplace (toFilePath f) toks old new :>: NilFL replaceCmd _ _ [_, _] = fail "You need to supply a list of files to replace in!" -replaceCmd _ _ _ = fail "Usage: darcs replace OLD NEW [FILES]" +replaceCmd _ _ _ = fail "Usage: darcs replace ..." filenameToks :: String filenameToks = "A-Za-z_0-9\\-\\." @@ -262,8 +239,8 @@ -- -- Note: Limitations in the current replace patch file format prevents tokens -- and token-char specifiers from containing any whitespace. -chooseToks :: [DarcsFlag] -> String -> String -> IO String -chooseToks (Toks t : _) a b +chooseToks :: Maybe String -> String -> String -> IO String +chooseToks (Just t) a b | length t <= 2 = badTokenSpec $ "It must contain more than 2 characters, because it" ++ " should be enclosed in square brackets" @@ -284,7 +261,7 @@ spaceyToken x = x ++ " must not contain any space" notAToken x = x ++ " is not a token, according to your spec" -chooseToks (_ : fs) a b = chooseToks fs a b -chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b - then return defaultToks - else return filenameToks +chooseToks Nothing a b = + if isTok defaultToks a && isTok defaultToks b + then return defaultToks + else return filenameToks diff --git a/src/Darcs/UI/Commands/Revert.hs b/src/Darcs/UI/Commands/Revert.hs --- a/src/Darcs/UI/Commands/Revert.hs +++ b/src/Darcs/UI/Commands/Revert.hs @@ -25,14 +25,15 @@ import Data.List ( sort ) import Darcs.UI.Flags - ( DarcsFlag, diffingOpts, verbosity, diffAlgorithm, isInteractive, isUnified + ( DarcsFlag, diffingOpts, verbosity, diffAlgorithm, isInteractive, withContext , dryRun, umask, useCache, fixSubPaths ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Commands.Unrevert ( writeUnrevert ) +import Darcs.UI.Completion ( modifiedFileArgs ) import Darcs.Util.Global ( debugMessage ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Repository @@ -42,7 +43,6 @@ , applyToWorking , readRecorded , unrecordedChanges - , listRegisteredFiles ) import Darcs.Patch ( invert, effectOnFilePaths, commute ) import Darcs.Patch.Split ( reversePrimSplitter ) @@ -74,45 +74,14 @@ "guaranteed to work if the repository has not changed since `darcs\n" ++ "revert` ran.\n" -revertBasicOpts :: DarcsOption a - (Maybe Bool -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> a) -revertBasicOpts - = O.interactive -- True - ^ O.workingRepoDir - ^ O.withContext - ^ O.diffAlgorithm - -revertAdvancedOpts :: DarcsOption a (O.UseIndex -> O.UMask -> a) -revertAdvancedOpts = O.useIndex ^ O.umask - -revertOpts :: DarcsOption a - (Maybe Bool - -> Maybe String - -> O.WithContext - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseIndex - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -revertOpts = revertBasicOpts `withStdOpts` revertAdvancedOpts - patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = [] , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default - , S.withContext = isUnified flags + , S.withContext = withContext ? flags } revert :: DarcsCommand [DarcsFlag] @@ -125,7 +94,7 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = revertCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = modifiedFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc revertAdvancedOpts , commandBasicOptions = odesc revertBasicOpts @@ -133,14 +102,23 @@ , commandCheckOptions = ocheck revertOpts , commandParseOptions = onormalise revertOpts } + where + revertBasicOpts + = O.interactive -- True + ^ O.repoDir + ^ O.withContext + ^ O.diffAlgorithm + revertAdvancedOpts = O.useIndex ^ O.umask + revertOpts = revertBasicOpts `withStdOpts` revertAdvancedOpts revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () revertCmd fps opts args = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args - announceFiles (verbosity opts) files "Reverting changes in" - changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files + announceFiles (verbosity ? opts) files "Reverting changes in" + changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) + O.NoLookForMoves O.NoLookForReplaces repository files let pre_changed_files = effectOnFilePaths (invert changes) . map toFilePath <$> files recorded <- readRecorded repository Sealed touching_changes <- return (chooseTouching pre_changed_files changes) @@ -149,7 +127,7 @@ _ -> do let context = selectionContextPrim Last "revert" (patchSelOpts opts) - (Just (reversePrimSplitter (diffAlgorithm opts))) + (Just (reversePrimSplitter (diffAlgorithm ? opts))) pre_changed_files (Just recorded) (norevert:>p) <- runSelection changes context if nullFL p @@ -161,7 +139,7 @@ Just (p':>_) -> writeUnrevert repository p' recorded NilFL Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL debugMessage "About to apply to the working directory." - _ <- applyToWorking repository (verbosity opts) (invert p) `catch` \(e :: IOException) -> + _ <- applyToWorking repository (verbosity ? opts) (invert p) `catch` \(e :: IOException) -> fail ("Unable to apply inverse patch!" ++ show e) return () putInfo opts "Finished reverting." diff --git a/src/Darcs/UI/Commands/Rollback.hs b/src/Darcs/UI/Commands/Rollback.hs --- a/src/Darcs/UI/Commands/Rollback.hs +++ b/src/Darcs/UI/Commands/Rollback.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.Rollback ( rollback ) where import Prelude () @@ -34,7 +32,7 @@ import Darcs.Patch ( IsRepoType, RepoPatch, invert, effect, fromPrims, sortCoalesceFL, canonize, PrimOf ) import Darcs.Patch.Named.Wrapped ( anonymous ) -import Darcs.Patch.Set ( PatchSet(..), newset2FL ) +import Darcs.Patch.Set ( PatchSet(..), patchSet2FL ) import Darcs.Patch.Split ( reversePrimSplitter ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), concatFL, nullFL, mapFL_FL ) @@ -44,17 +42,18 @@ import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), applyToWorking, readRepo, finalizeRepositoryChanges, tentativelyAddToPending, - considerMergeToWorking, listRegisteredFiles ) + considerMergeToWorking ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches, - amInHashedRepository ) + amInHashedRepository, putInfo ) import Darcs.UI.Commands.Unrecord ( getLastPatches ) import Darcs.UI.Commands.Util ( announceFiles ) -import Darcs.UI.Flags as F ( DarcsFlag(Quiet), verbosity, umask, useCache, - compression, externalMerge, wantGuiPause, +import Darcs.UI.Completion ( knownFileArgs ) +import Darcs.UI.Flags ( DarcsFlag, verbosity, umask, useCache, + compress, externalMerge, wantGuiPause, diffAlgorithm, fixSubPaths, isInteractive ) import Darcs.UI.Options - ( DarcsOption, (^), odesc, ocheck, onormalise - , defaultFlags, parseFlags + ( (^), odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( WhichChanges(..), @@ -62,6 +61,7 @@ runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) +import Darcs.Util.Printer ( text ) import Darcs.Util.Progress ( debugMessage ) rollbackDescription :: String @@ -82,40 +82,9 @@ , "and run `unrevert` to restore the saved changes into your working tree." ] -rollbackBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Bool -> Maybe String -> O.DiffAlgorithm -> a) -rollbackBasicOpts - = O.matchSeveralOrLast - ^ O.interactive -- True - ^ O.workingRepoDir - ^ O.diffAlgorithm - -rollbackAdvancedOpts :: DarcsOption a (O.UMask -> a) -rollbackAdvancedOpts = O.umask - -rollbackOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe Bool - -> Maybe String - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -rollbackOpts = rollbackBasicOpts `withStdOpts` rollbackAdvancedOpts - patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps @@ -133,7 +102,7 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = rollbackCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc rollbackAdvancedOpts , commandBasicOptions = odesc rollbackBasicOpts @@ -141,26 +110,34 @@ , commandCheckOptions = ocheck rollbackOpts , commandParseOptions = onormalise rollbackOpts } + where + rollbackBasicOpts + = O.matchSeveralOrLast + ^ O.interactive -- True + ^ O.repoDir + ^ O.diffAlgorithm + rollbackAdvancedOpts = O.umask + rollbackOpts = rollbackBasicOpts `withStdOpts` rollbackAdvancedOpts exitIfNothingSelected :: FL p wX wY -> String -> IO () exitIfNothingSelected ps what = when (nullFL ps) $ putStrLn ("No " ++ what ++ " selected!") >> exitSuccess rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -rollbackCmd fps opts args = withRepoLock NoDryRun (useCache opts) - YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do +rollbackCmd fps opts args = withRepoLock NoDryRun (useCache ? opts) + YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." - announceFiles (verbosity opts) files "Rolling back changes in" + announceFiles (verbosity ? opts) files "Rolling back changes in" allpatches <- readRepo repository let matchFlags = parseFlags O.matchSeveralOrLast opts (_ :> patches) <- return $ if firstMatch matchFlags then getLastPatches matchFlags allpatches - else PatchSet NilRL NilRL :> newset2FL allpatches + else PatchSet NilRL NilRL :> patchSet2FL allpatches let filesFps = map toFilePath <$> files patchCtx = selectionContext LastReversed "rollback" (patchSelOpts opts) Nothing filesFps (_ :> ps) <- @@ -168,13 +145,13 @@ exitIfNothingSelected ps "patches" setEnvDarcsPatches ps let hunkContext = selectionContextPrim Last "rollback" (patchSelOpts opts) - (Just (reversePrimSplitter (diffAlgorithm opts))) + (Just (reversePrimSplitter (diffAlgorithm ? opts))) filesFps Nothing - hunks = concatFL . mapFL_FL (canonize $ F.diffAlgorithm opts) . sortCoalesceFL . effect $ ps + hunks = concatFL . mapFL_FL (canonize $ diffAlgorithm ? opts) . sortCoalesceFL . effect $ ps whatToUndo <- runSelection hunks hunkContext undoItNow opts repository whatToUndo -undoItNow :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) +undoItNow :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository rt p wR wU wT -> (q :> FL (PrimOf p)) wA wT -> IO () undoItNow opts repo (_ :> prims) = do @@ -182,19 +159,18 @@ rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims) Sealed pw <- considerMergeToWorking repo "rollback" YesAllowConflictsAndMark YesUpdateWorking - (externalMerge opts) (wantGuiPause opts) - (compression opts) (verbosity opts) NoReorder - (UseIndex, ScanKnown, F.diffAlgorithm opts) + (externalMerge ? opts) (wantGuiPause opts) + (compress ? opts) (verbosity ? opts) NoReorder + (UseIndex, ScanKnown, diffAlgorithm ? opts) NilFL (rbp :>: NilFL) tentativelyAddToPending repo YesUpdateWorking pw finalizeRepositoryChanges repo YesUpdateWorking - (compression opts) - _ <- applyToWorking repo (verbosity opts) pw + (compress ? opts) + _ <- applyToWorking repo (verbosity ? opts) pw `catch` \(e :: IOException) -> fail $ "error applying rolled back patch to working directory\n" ++ show e debugMessage "Finished applying unrecorded rollback patch" - when (F.Quiet `notElem` opts) $ - putStrLn "Changes rolled back in working directory" + putInfo opts $ text "Changes rolled back in working directory" diff --git a/src/Darcs/UI/Commands/Send.hs b/src/Darcs/UI/Commands/Send.hs --- a/src/Darcs/UI/Commands/Send.hs +++ b/src/Darcs/UI/Commands/Send.hs @@ -22,8 +22,6 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) - import System.Exit ( exitSuccess #ifndef HAVE_MAPI @@ -44,20 +42,14 @@ ( DarcsCommand(..), withStdOpts , putInfo , putVerbose - , printDryRunMessageAndExit , setEnvDarcsPatches , defaultRepo , amInHashedRepository ) +import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) import Darcs.UI.Flags - ( DarcsFlag( Target - , Context - , Mail - , DryRun - , Quiet - , AllowUnrelatedRepos - ) - , willRemoveLogFile, doReverse, dryRun, useCache, remoteRepos, setDefault + ( DarcsFlag + , willRemoveLogFile, changesReverse, dryRun, useCache, remoteRepos, setDefault , fixUrl , getCc , getAuthor @@ -65,26 +57,32 @@ , getInReplyTo , getSendmailCmd , getOutput - , getCharset + , charset , verbosity - , hasSummary , isInteractive - , hasAuthor + , author , hasLogfile , selectDeps , minimize , editDescription ) import Darcs.UI.Options - ( DarcsOption, (^), odesc, ocheck, onormalise - , defaultFlags, parseFlags + ( (^), odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc ) -import Darcs.Repository ( PatchSet, Repository, - identifyRepositoryFor, withRepository, RepoJob(..), - readRepo, readRecorded, prefsUrl, checkUnrelatedRepos ) +import Darcs.Repository + ( Repository + , repoLocation + , PatchSet + , identifyRepositoryFor + , withRepository + , RepoJob(..) + , readRepo + , readRecorded + , prefsUrl ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, invert ) @@ -95,6 +93,7 @@ mapFL, mapFL_FL, lengthFL, nullFL ) import Darcs.Patch.Bundle ( minContext, makeBundleN, scanContextFile, patchFilename ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) +import Darcs.Repository.Flags ( DryRun(..) ) import Darcs.Util.External ( fetchFilePS, Cachable(..) ) import Darcs.UI.External ( signString @@ -127,11 +126,13 @@ import Data.Text.Encoding ( decodeUtf8' ) import Darcs.Util.Progress ( debugMessage ) import Darcs.UI.Email ( makeEmail ) +import Darcs.UI.Completion ( prefArgs ) import Darcs.Util.Printer ( Doc, vsep, text, ($$), (<+>), (<>), putDoc, putDocLn - , renderPS, RenderMode(..) + , renderPS, vcat ) import Darcs.Util.English ( englishNum, Noun(..) ) +import Darcs.Util.Text ( sentence, quote ) import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd, getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd ) import Darcs.Util.Download.HTTP ( postUrl ) @@ -139,103 +140,13 @@ import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal ) import Darcs.Util.SignalHandler ( catchInterrupt ) -import qualified Darcs.UI.Message.Send as Msg -#include "impossible.h" - -sendBasicOpts :: DarcsOption a - ([O.MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> O.HeaderFields - -> Maybe String - -> Maybe String - -> (Bool, Maybe String) - -> Maybe O.Output - -> O.Sign - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> Bool - -> Maybe Bool - -> Maybe String - -> Bool - -> Bool - -> a) -sendBasicOpts - = O.matchSeveral - ^ O.selectDeps - ^ O.interactive -- True - ^ O.headerFields - ^ O.author - ^ O.charset - ^ O.sendmail - ^ O.output - ^ O.sign - ^ O.dryRunXml - ^ O.summary - ^ O.editDescription - ^ O.setDefault - ^ O.workingRepoDir - ^ O.minimize - ^ O.allowUnrelatedRepos - -sendAdvancedOpts :: DarcsOption a - (O.Logfile - -> O.RemoteRepos - -> Maybe AbsolutePath - -> Bool - -> O.NetworkOptions - -> a) -sendAdvancedOpts - = O.logfile - ^ O.remoteRepos - ^ O.sendToContext - ^ O.changesReverse - ^ O.network - -sendOpts :: DarcsOption a - ([O.MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> O.HeaderFields - -> Maybe String - -> Maybe String - -> (Bool, Maybe String) - -> Maybe O.Output - -> O.Sign - -> O.DryRun - -> O.XmlOutput - -> Maybe O.Summary - -> Bool - -> Maybe Bool - -> Maybe String - -> Bool - -> Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.Logfile - -> O.RemoteRepos - -> Maybe AbsolutePath - -> Bool - -> O.NetworkOptions - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts - patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveral flags , S.interactive = isInteractive True flags - , S.selectDeps = selectDeps flags - , S.summary = hasSummary O.NoSummary flags + , S.selectDeps = selectDeps ? flags + , S.summary = O.summary ? flags , S.withContext = O.NoContext } @@ -243,13 +154,13 @@ send = DarcsCommand { commandProgramName = "darcs" , commandName = "send" - , commandHelp = Msg.cmdHelp - , commandDescription = Msg.cmdDescription + , commandHelp = cmdHelp + , commandDescription = cmdDescription , commandExtraArgs = 1 , commandExtraArgHelp = ["[REPOSITORY]"] , commandCommand = sendCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = getPreflist "repos" + , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc sendAdvancedOpts , commandBasicOptions = odesc sendBasicOpts @@ -257,35 +168,59 @@ , commandCheckOptions = ocheck sendOpts , commandParseOptions = onormalise sendOpts } + where + sendBasicOpts + = O.matchSeveral + ^ O.selectDeps + ^ O.interactive -- True + ^ O.headerFields + ^ O.author + ^ O.charset + ^ O.sendmail + ^ O.output + ^ O.sign + ^ O.dryRunXml + ^ O.summary + ^ O.editDescription + ^ O.setDefault + ^ O.repoDir + ^ O.minimize + ^ O.allowUnrelatedRepos + sendAdvancedOpts + = O.logfile + ^ O.remoteRepos + ^ O.sendToContext + ^ O.changesReverse + ^ O.network + sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -sendCmd fps input_opts [""] = sendCmd fps input_opts [] -sendCmd (_,o) input_opts [unfixedrepodir] = - withRepository (useCache input_opts) $ RepoJob $ +sendCmd fps opts [""] = sendCmd fps opts [] +sendCmd (_,o) opts [unfixedrepodir] = + withRepository (useCache ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do - context_ps <- the_context input_opts + context_ps <- the_context (O.sendToContext ? opts) case context_ps of Just them -> do - wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository rt p wR wU wR)) - sendToThem repository input_opts wtds "CONTEXT" them + wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wR wU wR)) + sendToThem repository opts wtds "CONTEXT" them Nothing -> do repodir <- fixUrl o unfixedrepodir -- Test to make sure we aren't trying to push to the current repo here <- getCurrentDirectory when (repodir == toFilePath here) $ - fail Msg.cannotSendToSelf + fail cannotSendToSelf old_default <- getPreflist "defaultrepo" - when (old_default == [repodir] && Quiet `notElem` input_opts) $ - putDocLn (Msg.creatingPatch repodir) - repo <- identifyRepositoryFor repository (useCache input_opts) repodir + when (old_default == [repodir]) $ + putInfo opts (creatingPatch repodir) + repo <- identifyRepositoryFor repository (useCache ? opts) repodir them <- readRepo repo - addRepoSource repodir (dryRun input_opts) (remoteRepos input_opts) (setDefault False input_opts) - wtds <- decideOnBehavior input_opts (Just repo) - sendToThem repository input_opts wtds repodir them - where the_context [] = return Nothing - the_context (Context foo:_) - = Just `fmap` scanContextFile (toFilePath foo) - the_context (_:fs) = the_context fs + addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts) + wtds <- decideOnBehavior opts (Just repo) + sendToThem repository opts wtds repodir them + where + the_context Nothing = return Nothing + the_context (Just foo) = Just `fmap` scanContextFile (toFilePath foo) sendCmd _ _ _ = impossible sendToThem :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) @@ -293,40 +228,40 @@ -> PatchSet rt p Origin wX -> IO () sendToThem repo opts wtds their_name them = do #ifndef HAVE_MAPI - -- Check if the user has sendmail or provided a --sendmail-cmd - -- (unless -o/-O or --dry-run is used) - sendmail <- haveSendmail - sm_cmd <- getSendmailCmd opts - when (isNothing (getOutput opts "") && DryRun `notElem` opts && - not sendmail && sm_cmd == "") $ do - putInfo opts Msg.noWorkingSendmail - exitWith $ ExitFailure 1 + when (fst (O.sendmail ? opts) && dryRun ? opts == O.NoDryRun) $ do + -- If --mail is used, check if the user has sendmail or + -- provided a --sendmail-cmd + sendmail <- haveSendmail + sm_cmd <- getSendmailCmd opts + when (not sendmail && sm_cmd == "") $ do + putInfo opts noWorkingSendmail + exitWith $ ExitFailure 1 #endif us <- readRepo repo common :> us' <- return $ findCommonWithThem us them - checkUnrelatedRepos (AllowUnrelatedRepos `elem` opts) us them + checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them case us' of - NilFL -> do putInfo opts Msg.nothingSendable + NilFL -> do putInfo opts nothingSendable exitSuccess - _ -> putVerbose opts $ Msg.selectionIs (mapFL description us') + _ -> putVerbose opts $ selectionIs (mapFL description us') pristine <- readRecorded repo - let direction = if doReverse opts then FirstReversed else First + let direction = if changesReverse ? opts then FirstReversed else First context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing (to_be_sent :> _) <- runSelection us' context printDryRunMessageAndExit "send" - (verbosity opts) - (hasSummary O.NoSummary opts) - (dryRun opts) + (verbosity ? opts) + (O.summary ? opts) + (dryRun ? opts) O.NoXml (isInteractive True opts) to_be_sent when (nullFL to_be_sent) $ do - putInfo opts Msg.selectionIsNull + putInfo opts selectionIsNull exitSuccess setEnvDarcsPatches to_be_sent let genFullBundle = prepareBundle opts common (Right (pristine, us':\/:to_be_sent)) - bundle <- if not (minimize opts) + bundle <- if not (minimize ? opts) then genFullBundle else do putInfo opts "Minimizing context, to send with full context hit ctrl-C..." ( case minContext common to_be_sent of @@ -338,7 +273,7 @@ fname = make_fname to_be_sent outname = case getOutput opts fname of Just f -> Just f - Nothing | Mail `elem` opts -> Nothing + Nothing | fst (O.sendmail ? opts) -> Nothing | not $ null [ p | Post p <- wtds] -> Nothing | otherwise -> Just (makeAbsoluteOrStd here fname) case outname of @@ -378,35 +313,35 @@ else take (n-3) st ++ "..." in do thetargets <- getTargets wtds - from <- getAuthor (hasAuthor opts) False + from <- getAuthor (author ? opts) False let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent let warnMailBody = case mailfile of - Just mf -> putDocLn $ Msg.emailBackedUp mf + Just mf -> putDocLn $ emailBackedUp mf Nothing -> return () warnCharset msg = do - confirmed <- promptYorn $ Msg.promptCharSetWarning msg + confirmed <- promptYorn $ promptCharSetWarning msg unless confirmed $ do - putDocLn Msg.charsetAborted + putDocLn charsetAborted warnMailBody exitSuccess - thecharset <- case getCharset opts of + thecharset <- case charset ? opts of -- Always trust provided charset providedCset@(Just _) -> return providedCset Nothing -> case mailcharset of Nothing -> do - warnCharset Msg.charsetCouldNotGuess + warnCharset charsetCouldNotGuess return mailcharset Just "utf-8" -> do -- Check the locale encoding for consistency encoding <- getSystemEncoding - debugMessage $ Msg.currentEncodingIs encoding + debugMessage $ currentEncodingIs encoding unless (isUTF8Locale encoding) $ - warnCharset Msg.charsetUtf8MailDiffLocale + warnCharset charsetUtf8MailDiffLocale return mailcharset -- Trust other cases (us-ascii) Just _ -> return mailcharset @@ -424,7 +359,7 @@ let to = generateEmailToString thetargets sendEmailDoc from to thesubject (getCc opts) sm_cmd contentAndBundle body >> - putInfo opts (Msg.success to (getCc opts)) + putInfo opts (success to (getCc opts)) `catch` \e -> do warnMailBody fail $ ioeGetErrorString e @@ -436,7 +371,7 @@ mmapFilePS fn forM_ [ p | Post p <- thetargets] (\url -> do - putInfo opts $ Msg.postingPatch url + putInfo opts $ postingPatch url postUrl url (BC.unpack nbody) "message/rfc822") `catch` (\(_ :: IOException) -> sendmail) cleanup opts mailfile @@ -458,18 +393,18 @@ writeBundleToFile opts to_be_sent bundle fname wtds their_name = do (d,f,_) <- getDescription opts their_name to_be_sent let putabs a = do writeDocBinFile a (d $$ bundle) - putDocLn (Msg.wroteBundle a) + putDocLn (wroteBundle a) putstd = putDoc (d $$ bundle) useAbsoluteOrStd putabs putstd fname let to = generateEmailToString wtds - unless (null to) $ putInfo opts $ Msg.savedButNotSent to + unless (null to) $ putInfo opts $ savedButNotSent to cleanup opts f data WhatToDo = Post String -- ^ POST the patch via HTTP | SendMail String -- ^ send patch via email -decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository rt p wR wU wT) -> IO [WhatToDo] +decideOnBehavior :: [DarcsFlag] -> Maybe (Repository rt p wR wU wT) -> IO [WhatToDo] decideOnBehavior opts remote_repo = case the_targets of [] -> do wtds <- case remote_repo of @@ -480,20 +415,17 @@ ts -> do announce_recipients ts return ts where the_targets = collectTargets opts - -- the ifdef above is to so that darcs only checks the remote - -- _darcs/post if we have an implementation of postUrl. See - -- our HTTP module for more details check_post the_remote_repo = do p <- ((readPost . BC.unpack) `fmap` - fetchFilePS (prefsUrl the_remote_repo++"/post") + fetchFilePS (prefsUrl (repoLocation the_remote_repo) ++ "/post") (MaxAge 600)) `catchall` return [] emails <- who_to_email the_remote_repo return (p++emails) readPost = map parseLine . lines where parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t - who_to_email the_remote_repo = + who_to_email repo = do email <- (BC.unpack `fmap` - fetchFilePS (prefsUrl the_remote_repo++"/email") + fetchFilePS (prefsUrl (repoLocation repo) ++ "/email") (MaxAge 600)) `catchall` return "" if '@' `elem` email then return . map SendMail $ lines email @@ -501,18 +433,18 @@ announce_recipients emails = let pn (SendMail s) = s pn (Post p) = p - msg = Msg.willSendTo (dryRun opts) (map pn emails) - in if DryRun `elem` opts - then putInfo opts msg - else when (null the_targets && isNothing (getOutput opts "")) $ - putInfo opts msg + msg = willSendTo (dryRun ? opts) (map pn emails) + in case dryRun ? opts of + O.YesDryRun -> putInfo opts msg + O.NoDryRun -> when (null the_targets && isNothing (getOutput opts "")) $ + putInfo opts msg getTargets :: [WhatToDo] -> IO [WhatToDo] -getTargets [] = fmap ((:[]) . SendMail) $ askUser Msg.promptTarget +getTargets [] = fmap ((:[]) . SendMail) $ askUser promptTarget getTargets wtds = return wtds collectTargets :: [DarcsFlag] -> [WhatToDo] -collectTargets flags = [ f t | Target t <- flags ] where +collectTargets flags = [ f t | t <- O._to (O.headerFields ? flags) ] where f url | "http:" `isPrefixOf` url = Post url f em = SendMail em @@ -521,14 +453,14 @@ getDescription opts their_name patches = case get_filename of Just file -> do - when (editDescription opts) $ do + when (editDescription ? opts) $ do when (isNothing $ hasLogfile opts) $ writeDocBinFile file patchdesc - debugMessage $ Msg.aboutToEdit file + debugMessage $ aboutToEdit file (_, changed) <- editFile file unless changed $ do - confirmed <- promptYorn Msg.promptNoDescriptionChange - unless confirmed $ do putDocLn Msg.aborted + confirmed <- promptYorn promptNoDescriptionChange + unless confirmed $ do putDocLn aborted exitSuccess return () @@ -549,12 +481,168 @@ return darcsSendMessageFinal) (return . toFilePath) $ hasLogfile opts get_filename = case hasLogfile opts of Just f -> Just $ toFilePath f - Nothing -> if editDescription opts + Nothing -> if editDescription ? opts then Just darcsSendMessage else Nothing - tryGetCharset content = let body = renderPS Standard content in + tryGetCharset content = let body = renderPS content in if isAscii body then Just "us-ascii" else either (const Nothing) (const $ Just "utf-8") (decodeUtf8' body) + +cmdDescription :: String +cmdDescription = + "Prepare a bundle of patches to be applied to some target repository." + +cmdHelp :: String +cmdHelp = unlines + [ "Send is used to prepare a bundle of patches that can be applied to a target" + , "repository. Send accepts the URL of the repository as an argument. When" + , "called without an argument, send will use the most recent repository that" + , "was either pushed to, pulled from or sent to. By default, the patch bundle" + , "is saved to a file, although you may directly send it by mail." + , "" + , "The `--output`, `--output-auto-name`, and `--to` flags determine" + , "what darcs does with the patch bundle after creating it. If you provide an" + , "`--output` argument, the patch bundle is saved to that file. If you" + , "specify `--output-auto-name`, the patch bundle is saved to a file with an" + , "automatically generated name. If you give one or more `--to` arguments," + , "the bundle of patches is sent to those locations. The locations may either" + , "be email addresses or urls that the patch should be submitted to via HTTP." + , "" + , "If you provide the `--mail` flag, darcs will look at the contents" + , "of the `_darcs/prefs/email` file in the target repository (if it exists)," + , "and send the patch by email to that address. In this case, you may use" + , "the `--cc` option to specify additional recipients without overriding the" + , "default repository email address." + , "" + , "If `_darcs/prefs/post` exists in the target repository, darcs will" + , "upload to the URL contained in that file, which may either be a" + , "`mailto:` URL, or an `http://` URL. In the latter case, the" + , "patch is posted to that URL." + , "" + , "If there is no email address associated with the repository, darcs will" + , "prompt you for an email address." + , "" + , "Use the `--subject` flag to set the subject of the e-mail to be sent." + , "If you don't provide a subject on the command line, darcs will make one up" + , "based on names of the patches in the patch bundle." + , "" + , "Use the `--in-reply-to` flag to set the In-Reply-To and References headers" + , "of the e-mail to be sent. By default no additional headers are included so" + , "e-mail will not be treated as reply by mail readers." + , "" + , "If you want to include a description or explanation along with the bundle" + , "of patches, you need to specify the `--edit-description` flag, which" + , "will cause darcs to open up an editor with which you can compose a message" + , "to go along with your patches." + , "" + , "If you want to use a command different from the default one for sending" + , "email, you need to specify a command line with the `--sendmail-command`" + , "option. The command line can contain some format specifiers which are" + , "replaced by the actual values. Accepted format specifiers are `%s` for" + , "subject, `%t` for to, `%c` for cc, `%b` for the body of the mail, `%f` for" + , "from, `%a` for the patch bundle and the same specifiers in uppercase for the" + , "URL-encoded values." + , "Additionally you can add `%<` to the end of the command line if the command" + , "expects the complete email message on standard input. E.g. the command lines" + , "for evolution and msmtp look like this:" + , "" + , " evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\"" + , " msmtp -t %<" + , "" + , "Do not confuse the `--author` options with the return address" + , "that `darcs send` will set for your patch bundle." + , "" + , "For example, if you have two email addresses A and B:" + , "" + , "* If you use `--author A` but your machine is configured to send mail from" + , " address B by default, then the return address on your message will be B." + , "* If you use `--from A` and your mail client supports setting the" + , " From: address arbitrarily (some non-Unix-like mail clients, especially," + , " may not support this), then the return address will be A; if it does" + , " not support this, then the return address will be B." + , "* If you supply neither `--from` nor `--author` then the return" + , " address will be B." + , "" + , "In addition, unless you specify the sendmail command with" + , "`--sendmail-command`, darcs sends email using the default email" + , "command on your computer. This default command is determined by the" + , "`configure` script. Thus, on some non-Unix-like OSes," + , "`--from` is likely to not work at all." + ] + +cannotSendToSelf :: String +cannotSendToSelf = "Can't send to current repository! Did you mean send --context?" + +creatingPatch :: String -> Doc +creatingPatch repodir = "Creating patch to" <+> text (quote repodir) <> "..." + +noWorkingSendmail :: Doc +noWorkingSendmail = "No working sendmail instance on your machine!" + +nothingSendable :: Doc +nothingSendable = "No recorded local changes to send!" + +selectionIs :: [Doc] -> Doc +selectionIs descs = text "We have the following patches to send:" $$ vcat descs + +selectionIsNull :: Doc +selectionIsNull = text "You don't want to send any patches, and that's fine with me!" + +emailBackedUp :: String -> Doc +emailBackedUp mf = sentence $ "Email body left in" <+> text mf + +promptCharSetWarning :: String -> String +promptCharSetWarning msg = "Warning: " ++ msg ++ " Send anyway?" + +charsetAborted :: Doc +charsetAborted = "Aborted. You can specify charset with the --charset option." + +charsetCouldNotGuess :: String +charsetCouldNotGuess = "darcs could not guess the charset of your mail." + +currentEncodingIs :: String -> String +currentEncodingIs e = "Current locale encoding: " ++ e + +charsetUtf8MailDiffLocale :: String +charsetUtf8MailDiffLocale = "your mail is valid UTF-8 but your locale differs." + +aborted :: Doc +aborted = "Aborted." + +success :: String -> String -> Doc +success to cc = sentence $ + "Successfully sent patch bundle to:" <+> text to <+> copies cc + where + copies "" = "" + copies x = "and cc'ed" <+> text x + +postingPatch :: String -> Doc +postingPatch url = "Posting patch to" <+> text url + +wroteBundle :: FilePathLike a => a -> Doc +wroteBundle a = sentence $ "Wrote patch to" <+> text (toFilePath a) + +savedButNotSent :: String -> Doc +savedButNotSent to = + text ("The usual recipent for this bundle is: " ++ to) + $$ text "To send it automatically, make sure sendmail is working," + <+> text "and add 'send mail' to _darcs/prefs/defaults or" + <+> text " ~/.darcs/defaults" + +willSendTo :: DryRun -> [String] -> Doc +willSendTo dr addresses = + "Patch bundle" <+> will <+> " be sent to:" <+> text (unwords addresses) + where + will = case dr of { YesDryRun -> "would"; NoDryRun -> "will" } + +promptTarget :: String +promptTarget = "What is the target email address? " + +aboutToEdit :: FilePath -> String +aboutToEdit file = "About to edit file " ++ file + +promptNoDescriptionChange :: String +promptNoDescriptionChange = "File content did not change. Continue anyway?" diff --git a/src/Darcs/UI/Commands/SetPref.hs b/src/Darcs/UI/Commands/SetPref.hs --- a/src/Darcs/UI/Commands/SetPref.hs +++ b/src/Darcs/UI/Commands/SetPref.hs @@ -15,29 +15,27 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.Commands.SetPref ( setpref ) where import Prelude () import Darcs.Prelude import System.Exit ( exitWith, ExitCode(..) ) -import Control.Monad (when) -import Data.Maybe (fromMaybe) +import Control.Monad ( when ) +import Data.Maybe ( fromMaybe ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask) -import Darcs.UI.Options ( DarcsOption, PrimDarcsOption, odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Options + ( odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository ( addToPending, withRepoLock, RepoJob(..) ) import Darcs.Patch ( changepref ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) -import Darcs.Repository.Prefs ( getPrefval, changePrefval, ) +import Darcs.Repository.Prefs ( getPrefval, changePrefval ) import Darcs.Util.English ( orClauses ) import Darcs.Util.Path ( AbsolutePath ) -#include "impossible.h" -- | A list of all valid preferences for @_darcs/prefs/prefs@. validPrefData :: [(String, String)] -- ^ (name, one line description) @@ -77,28 +75,6 @@ "the repository will always take precedence. This is considered a\n" ++ "low-priority bug, because preferences are seldom set.\n" -setprefBasicOpts :: PrimDarcsOption (Maybe String) -setprefBasicOpts = O.workingRepoDir - -setprefAdvancedOpts :: PrimDarcsOption O.UMask -setprefAdvancedOpts = O.umask - -setprefOpts :: DarcsOption a - (Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -setprefOpts = setprefBasicOpts `withStdOpts` setprefAdvancedOpts - setpref :: DarcsCommand [DarcsFlag] setpref = DarcsCommand { commandProgramName = "darcs" @@ -109,7 +85,7 @@ , commandExtraArgHelp = ["", ""] , commandCommand = setprefCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return validPrefs + , commandCompleteArgs = completeArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc setprefAdvancedOpts , commandBasicOptions = odesc setprefBasicOpts @@ -117,13 +93,19 @@ , commandCheckOptions = ocheck setprefOpts , commandParseOptions = onormalise setprefOpts } + where + setprefBasicOpts = O.repoDir + setprefAdvancedOpts = O.umask + setprefOpts = setprefBasicOpts `withStdOpts` setprefAdvancedOpts + completeArgs _ _ [] = return validPrefs + completeArgs _ _ _args = return [] setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () setprefCmd _ opts [pref,val] = - withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do when (' ' `elem` pref) $ do putStrLn $ "'"++pref++ - "' is not a valid preference name: no spaces allowed!" + "' is not a valid preference name: no spaces allowed!" exitWith $ ExitFailure 1 when (pref `notElem` validPrefs) $ do putStrLn $ "'"++pref++"' is not a valid preference name!" diff --git a/src/Darcs/UI/Commands/Show.hs b/src/Darcs/UI/Commands/Show.hs --- a/src/Darcs/UI/Commands/Show.hs +++ b/src/Darcs/UI/Commands/Show.hs @@ -21,11 +21,10 @@ import Darcs.Prelude import Darcs.UI.Commands ( DarcsCommand(..) - , normalCommand, hiddenCommand + , normalCommand , commandAlias, amInRepository ) import Darcs.UI.Commands.ShowAuthors ( showAuthors ) -import Darcs.UI.Commands.ShowBug ( showBug ) import Darcs.UI.Commands.ShowContents ( showContents ) import Darcs.UI.Commands.ShowDependencies ( showDeps ) import Darcs.UI.Commands.ShowFiles ( showFiles ) @@ -51,8 +50,7 @@ , commandDescription = showDescription , commandPrereq = amInRepository , commandSubCommands = - [ hiddenCommand showBug - , normalCommand showContents + [ normalCommand showContents , normalCommand showDeps , normalCommand showFiles , normalCommand showIndex diff --git a/src/Darcs/UI/Commands/ShowAuthors.hs b/src/Darcs/UI/Commands/ShowAuthors.hs --- a/src/Darcs/UI/Commands/ShowAuthors.hs +++ b/src/Darcs/UI/Commands/ShowAuthors.hs @@ -22,32 +22,33 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( (^), catch ) +import Prelude hiding ( (^) ) import Control.Arrow ( (&&&), (***) ) -import Control.Exception ( catch, IOException ) import Data.Char ( toLower, isSpace ) import Data.Function ( on ) import Data.List ( isInfixOf, sortBy, groupBy, group, sort ) import Data.Maybe( isJust ) import Data.Ord ( comparing ) +import System.IO.Error ( catchIOError ) import Text.ParserCombinators.Parsec hiding ( lower, count, Line ) import Text.ParserCombinators.Parsec.Error import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) -import Darcs.UI.Flags ( DarcsFlag(Verbose), useCache ) -import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) -import qualified Darcs.UI.Options.All as O ( workingRepoDir, StdCmdAction, Verbosity, UseCache ) +import Darcs.UI.Flags ( DarcsFlag, useCache, verbose ) +import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) ) +import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.External ( viewDoc ) import Darcs.Patch.PatchInfoAnd ( info ) import Darcs.Patch.Info ( piAuthor ) -import Darcs.Patch.Set ( newset2RL ) +import Darcs.Patch.Set ( patchSet2RL ) import Darcs.Repository ( readRepo, withRepository, RepoJob(..) ) import Darcs.Patch.Witnesses.Ordered ( mapRL ) +import Darcs.Util.Lock ( readTextFile ) import Darcs.Util.Printer ( text ) import Darcs.Util.Path ( AbsolutePath ) -import qualified Darcs.Util.Ratified as Ratified ( readFile ) data Spelling = Spelling String String [Regex] -- name, email, regexps type ParsedLine = Maybe Spelling -- Nothing for blank lines @@ -95,24 +96,6 @@ " John Snagge , John, snagge@, js@(si|mit).edu\n" ++ " Chuck Jones\\, Jr. , cj\\+user@example.com\n" -showAuthorsBasicOpts :: DarcsOption a (Maybe String -> a) -showAuthorsBasicOpts = O.workingRepoDir - -showAuthorsOpts :: DarcsOption a - (Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showAuthorsOpts = showAuthorsBasicOpts `withStdOpts` oid - showAuthors :: DarcsCommand [DarcsFlag] showAuthors = DarcsCommand { commandProgramName = "darcs" @@ -123,7 +106,7 @@ , commandExtraArgHelp = [] , commandCommand = authorsCmd , commandPrereq = amInRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showAuthorsBasicOpts @@ -131,14 +114,17 @@ , commandCheckOptions = ocheck showAuthorsOpts , commandParseOptions = onormalise showAuthorsOpts } + where + showAuthorsBasicOpts = O.repoDir + showAuthorsOpts = showAuthorsBasicOpts `withStdOpts` oid authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -authorsCmd _ flags _ = withRepository (useCache flags) $ RepoJob $ \repository -> do +authorsCmd _ flags _ = withRepository (useCache ? flags) $ RepoJob $ \repository -> do patches <- readRepo repository spellings <- compiledAuthorSpellings flags - let authors = mapRL (piAuthor . info) $ newset2RL patches + let authors = mapRL (piAuthor . info) $ patchSet2RL patches viewDoc $ text $ unlines $ - if Verbose `elem` flags + if verbose flags then authors else rankAuthors spellings authors @@ -177,9 +163,8 @@ compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling] compiledAuthorSpellings flags = do let as_file = ".authorspellings" - contents <- Ratified.readFile -- never unlinked from within darcs - as_file `catch` (\(_ :: IOException) -> return "") - let parse_results = map (parse sentence as_file) $ lines contents + content_lines <- readTextFile as_file `catchIOError` (const (return [])) + let parse_results = map (parse sentence as_file) content_lines clean 1 parse_results where clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling] diff --git a/src/Darcs/UI/Commands/ShowBug.hs b/src/Darcs/UI/Commands/ShowBug.hs deleted file mode 100644 --- a/src/Darcs/UI/Commands/ShowBug.hs +++ /dev/null @@ -1,80 +0,0 @@ --- Copyright (C) 2007 Eric Kow --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# LANGUAGE CPP #-} - -module Darcs.UI.Commands.ShowBug ( showBug ) where - -import Prelude () -import Darcs.Prelude - -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) -import Darcs.UI.Flags ( DarcsFlag ) -import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) -import qualified Darcs.UI.Options.All as O ( workingRepoDir, StdCmdAction, Verbosity, UseCache ) -import Darcs.Util.Path ( AbsolutePath ) -#include "impossible.h" - -showBugDescription :: String -showBugDescription = "Simulate a run-time failure." - -showBugHelp :: String -showBugHelp = - "Show bug can be used to see what darcs would show you if you encountered.\n" - ++"a bug in darcs.\n" - -showBugBasicOpts :: DarcsOption a (Maybe String -> a) -showBugBasicOpts = O.workingRepoDir - -showBugOpts :: DarcsOption a - (Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) - -showBugOpts = showBugBasicOpts `withStdOpts` oid - -showBug :: DarcsCommand [DarcsFlag] -showBug = DarcsCommand - { commandProgramName = "darcs" - , commandName = "bug" - , commandHelp = showBugHelp - , commandDescription = showBugDescription - , commandExtraArgs = 0 - , commandExtraArgHelp = [] - , commandCommand = showBugCmd - , commandPrereq = findRepository - , commandGetArgPossibilities = return [] - , commandArgdefaults = nodefaults - , commandAdvancedOptions = [] - , commandBasicOptions = odesc showBugBasicOpts - , commandDefaults = defaultFlags showBugOpts - , commandCheckOptions = ocheck showBugOpts - , commandParseOptions = onormalise showBugOpts - } - -showBugCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -showBugCmd _ _ _ = bug "This is actually a fake bug in darcs." - diff --git a/src/Darcs/UI/Commands/ShowContents.hs b/src/Darcs/UI/Commands/ShowContents.hs --- a/src/Darcs/UI/Commands/ShowContents.hs +++ b/src/Darcs/UI/Commands/ShowContents.hs @@ -29,15 +29,10 @@ import qualified Data.ByteString.Lazy as BL import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths ) -import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags ) +import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O - ( MatchFlag - , matchUpToOne - , workingRepoDir - , StdCmdAction - , Verbosity - , UseCache ) import Darcs.Patch.Match ( haveNonrangeMatch ) import Darcs.Repository ( withRepository, RepoJob(..), readRecorded, repoPatchType ) import Darcs.Util.Lock ( withDelayedDir ) @@ -55,25 +50,6 @@ "If you give show contents no version arguments, it displays the recorded\n"++ "version of the file(s).\n" -showContentsBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe String -> a) -showContentsBasicOpts = O.matchUpToOne ^ O.workingRepoDir - -showContentsOpts :: DarcsOption a - ([O.MatchFlag] - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showContentsOpts = O.matchUpToOne ^ O.workingRepoDir `withStdOpts` oid - showContents :: DarcsCommand [DarcsFlag] showContents = DarcsCommand { commandProgramName = "darcs" @@ -84,7 +60,7 @@ , commandExtraArgHelp = ["[FILE]..."] , commandCommand = showContentsCmd , commandPrereq = findRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showContentsBasicOpts @@ -92,13 +68,16 @@ , commandCheckOptions = ocheck showContentsOpts , commandParseOptions = onormalise showContentsOpts } + where + showContentsBasicOpts = O.matchUpToOne ^ O.repoDir + showContentsOpts = O.matchUpToOne ^ O.repoDir `withStdOpts` oid showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showContentsCmd _ _ [] = fail "show contents needs at least one argument." showContentsCmd fps opts args = do floatedPaths <- map (floatPath . toFilePath . sp2fn) `fmap` fixSubPaths fps args let matchFlags = parseFlags O.matchUpToOne opts - withRepository (useCache opts) $ RepoJob $ \repository -> do + withRepository (useCache ? opts) $ RepoJob $ \repository -> do let readContents = do okpaths <- filterM TM.fileExists floatedPaths forM okpaths $ \f -> (B.concat . BL.toChunks) `fmap` TM.readFile f diff --git a/src/Darcs/UI/Commands/ShowDependencies.hs b/src/Darcs/UI/Commands/ShowDependencies.hs --- a/src/Darcs/UI/Commands/ShowDependencies.hs +++ b/src/Darcs/UI/Commands/ShowDependencies.hs @@ -12,35 +12,28 @@ import Data.Graph.Inductive.PatriciaTree ( Gr ) import qualified Data.Text.Lazy as T -import qualified Data.ByteString.Char8 as BC ( unpack ) -import Darcs.Util.Tree ( Tree ) - -import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) ) +import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) ) import Darcs.UI.Flags ( DarcsFlag(..), getRepourl - , useCache, toMatchFlags ) -import Darcs.UI.Options ( PrimDarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) + , useCache ) +import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts ) import Darcs.UI.Commands.Unrecord ( matchingHead ) +import Darcs.UI.Completion ( noArgs ) import Darcs.Util.Text ( formatText ) import Darcs.Util.Path ( AbsolutePath ) -import Darcs.Patch ( RepoPatch ) -import Darcs.Patch.Set ( PatchSet(..), newset2FL ) -import Darcs.Patch.Info ( _piName ) +import Darcs.Patch.Info ( piName ) import Darcs.Patch.PatchInfoAnd ( hopefully ) -import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Named ( Named (..), patch2patchinfo ) import Darcs.Patch.Named.Wrapped ( removeInternalFL ) import Darcs.Patch.Match ( firstMatch, matchFirstPatchset ) -import Darcs.Patch.Choices ( lpPatch, LabelledPatch, label, getLabelInt ) +import Darcs.Patch.Choices ( unLabel, LabelledPatch, label, getLabelInt ) import Darcs.Patch.Depends ( SPatchAndDeps, getDeps, findCommonWithThem ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), seal2, Sealed(..) ) -import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:>)(..), RL(..) - , reverseFL, foldlFL, mapFL_FL ) -import Darcs.Repository.Flags ( Verbosity(..), UseCache(..) ) +import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:>)(..), foldlFL, mapFL_FL ) showDepsDescription :: String showDepsDescription = "Generate the graph of dependencies." @@ -57,25 +50,6 @@ , "darcs show dependencies | dot -Tpdf -o FILE.pdf" ] -showDepsBasicOpts :: PrimDarcsOption [O.MatchFlag] -showDepsBasicOpts = O.matchSeveralOrLast - -showDepsOpts :: O.DarcsOption - a - ([O.MatchFlag] - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> Verbosity - -> Bool - -> UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showDepsOpts = showDepsBasicOpts `withStdOpts` oid - showDeps :: DarcsCommand [DarcsFlag] showDeps = DarcsCommand { commandProgramName = "darcs" @@ -86,7 +60,7 @@ , commandExtraArgHelp = [] , commandCommand = depsCmd , commandPrereq = findRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showDepsBasicOpts @@ -94,16 +68,18 @@ , commandCheckOptions = ocheck showDepsOpts , commandParseOptions = onormalise showDepsOpts } + where + showDepsBasicOpts = O.matchSeveralOrLast + showDepsOpts = showDepsBasicOpts `withStdOpts` oid type DepsGraph = Gr String () depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () depsCmd _ opts _ = do let repodir = fromMaybe "." (getRepourl opts) - withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> do - Sealed2 r <- readRepo repo >>= pruneRepo - let rFl = newset2FL r - deps = getDeps + withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do + Sealed2 rFl <- readRepo repo >>= pruneRepo + let deps = getDeps (removeInternalFL . mapFL_FL hopefully $ rFl) rFl dGraph = transitiveReduction $ @@ -119,29 +95,29 @@ , ImageScale UniformScale ] } - pruneRepo r = let matchFlags = toMatchFlags opts in + pruneRepo r = let matchFlags = O.matchSeveralOrLast ? opts in if firstMatch matchFlags then case getLastPatches matchFlags r of - Sealed2 ps -> return $ seal2 $ PatchSet NilRL ps + Sealed2 ps -> return $ seal2 ps else case matchingHead matchFlags r of - _ :> patches -> return $ seal2 $ PatchSet NilRL $ reverseFL patches + _ :> patches -> return $ seal2 patches getLastPatches matchFlags ps = case matchFirstPatchset matchFlags ps of Sealed p1s -> case findCommonWithThem ps p1s of - _ :> ps' -> seal2 $ reverseFL ps' + _ :> ps' -> seal2 ps' -makeGraph :: (RepoPatch p,ApplyState p ~ Tree) => [SPatchAndDeps p] -> DepsGraph +makeGraph :: [SPatchAndDeps p] -> DepsGraph makeGraph = uncurry mkGraph . (id *** concat) . unzip . map mkNodeWithEdges where mkNodeWithEdges :: SPatchAndDeps p -> (LNode String, [UEdge]) mkNodeWithEdges (Sealed2 father, Sealed2 childs) = (mkLNode father,mkUEdges) where mkNode :: LabelledPatch (Named p) wX wY -> Int - mkNode = fromInteger . getLabelInt . label + mkNode = getLabelInt . label mkUEdge :: [UEdge] -> LabelledPatch (Named p) wX wY -> [UEdge] mkUEdge les child = (mkNode father, mkNode child,()) : les mkLabel :: LabelledPatch (Named p) wX wY -> String - mkLabel = formatText 20 . (:[]) . BC.unpack . _piName . patch2patchinfo . lpPatch + mkLabel = formatText 20 . (:[]) . piName . patch2patchinfo . unLabel mkLNode :: LabelledPatch (Named p) wX wY -> LNode String mkLNode p = (mkNode p, mkLabel p) mkUEdges :: [UEdge] diff --git a/src/Darcs/UI/Commands/ShowFiles.hs b/src/Darcs/UI/Commands/ShowFiles.hs --- a/src/Darcs/UI/Commands/ShowFiles.hs +++ b/src/Darcs/UI/Commands/ShowFiles.hs @@ -15,18 +15,17 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} module Darcs.UI.Commands.ShowFiles ( showFiles ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) import Darcs.UI.Flags ( DarcsFlag, useCache ) -import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise - , defaultFlags, parseFlags ) +import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise + , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) +import Darcs.UI.Completion ( knownFileArgs ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), repoPatchType ) import Darcs.Patch ( IsRepoType, RepoPatch ) @@ -39,7 +38,7 @@ import Data.List( isPrefixOf ) -import Darcs.Patch.Match ( haveNonrangeMatch ) +import Darcs.Patch.Match ( haveNonrangeExplicitMatch ) import Darcs.Repository.Match ( getNonrangeMatch ) import Darcs.Util.Lock ( withDelayedDir ) @@ -70,53 +69,33 @@ "\n" ++ " darcs show files -0 | xargs -0 ls -ldS\n" -showFilesBasicOpts :: DarcsOption a - (Bool -> Bool -> Bool -> Bool -> [O.MatchFlag] -> Maybe String -> a) -showFilesBasicOpts - = O.files - ^ O.directories - ^ O.pending - ^ O.nullFlag - ^ O.matchUpToOne - ^ O.workingRepoDir - -showFilesOpts :: DarcsOption a - (Bool - -> Bool - -> Bool - -> Bool - -> [O.MatchFlag] - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showFilesOpts = showFilesBasicOpts `withStdOpts` oid - showFiles :: DarcsCommand [DarcsFlag] -showFiles = DarcsCommand { - commandProgramName = "darcs", - commandName = "files", - commandHelp = showFilesHelp, - commandDescription = showFilesDescription, - commandExtraArgs = -1, - commandExtraArgHelp = ["[FILE or DIRECTORY]..."], - commandCommand = manifestCmd toListFiles, - commandPrereq = amInRepository, - commandGetArgPossibilities = return [], - commandArgdefaults = nodefaults, - commandAdvancedOptions = [], - commandBasicOptions = odesc showFilesBasicOpts, - commandDefaults = defaultFlags showFilesOpts, - commandCheckOptions = ocheck showFilesOpts, - commandParseOptions = onormalise showFilesOpts } +showFiles = DarcsCommand + { commandProgramName = "darcs" + , commandName = "files" + , commandHelp = showFilesHelp + , commandDescription = showFilesDescription + , commandExtraArgs = -1 + , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] + , commandCommand = manifestCmd toListFiles + , commandPrereq = amInRepository + , commandCompleteArgs = knownFileArgs + , commandArgdefaults = nodefaults + , commandAdvancedOptions = [] + , commandBasicOptions = odesc showFilesBasicOpts + , commandDefaults = defaultFlags showFilesOpts + , commandCheckOptions = ocheck showFilesOpts + , commandParseOptions = onormalise showFilesOpts + } + where + showFilesBasicOpts + = O.files + ^ O.directories + ^ O.pending + ^ O.nullFlag + ^ O.matchUpToOne + ^ O.repoDir + showFilesOpts = showFilesBasicOpts `withStdOpts` oid toListFiles :: [DarcsFlag] -> Tree m -> [FilePath] toListFiles opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts) @@ -137,7 +116,7 @@ manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath] manifestHelper to_list opts argList = do - list' <- to_list opts `fmap` withRepository (useCache opts) (RepoJob slurp) + list' <- to_list opts `fmap` withRepository (useCache ? opts) (RepoJob slurp) case argList of [] -> return list' prefixes -> return (onlysubdirs prefixes list') @@ -146,7 +125,7 @@ slurp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO (Tree IO) slurp r = do - let fUpto = haveNonrangeMatch (repoPatchType r) matchFlags + let fUpto = haveNonrangeExplicitMatch (repoPatchType r) matchFlags fPending = parseFlags O.pending opts -- this covers all 4 possibilities case (fUpto,fPending) of diff --git a/src/Darcs/UI/Commands/ShowIndex.hs b/src/Darcs/UI/Commands/ShowIndex.hs --- a/src/Darcs/UI/Commands/ShowIndex.hs +++ b/src/Darcs/UI/Commands/ShowIndex.hs @@ -20,7 +20,6 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -{-# LANGUAGE CPP #-} module Darcs.UI.Commands.ShowIndex ( showIndex , showPristineCmd -- for alias @@ -30,9 +29,10 @@ import Darcs.Prelude import Control.Monad ( (>=>) ) -import Darcs.UI.Flags ( DarcsFlag(NullFlag), useCache ) +import Darcs.UI.Flags ( DarcsFlag, useCache ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) -import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( withRepository, RepoJob(..), readIndex ) import Darcs.Repository.State ( readRecorded ) @@ -44,62 +44,44 @@ import System.Posix.Types ( FileID ) -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BC import Data.Maybe ( fromJust ) import qualified Data.Map as M ( Map, lookup, fromList ) -showIndexBasicOpts :: DarcsOption a - (Bool -> Bool -> Bool -> Maybe String -> a) -showIndexBasicOpts = O.files ^ O.directories ^ O.nullFlag ^ O.workingRepoDir - -showIndexOpts :: DarcsOption a - (Bool - -> Bool - -> Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showIndexOpts = showIndexBasicOpts `withStdOpts` oid - showIndex :: DarcsCommand [DarcsFlag] -showIndex = DarcsCommand { - commandProgramName = "darcs", - 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.", - commandExtraArgs = 0, - commandExtraArgHelp = [], - commandCommand = showIndexCmd, - commandPrereq = amInRepository, - commandGetArgPossibilities = return [], - commandArgdefaults = nodefaults, - commandAdvancedOptions = [], - commandBasicOptions = odesc showIndexBasicOpts, - commandDefaults = defaultFlags showIndexOpts, - commandCheckOptions = ocheck showIndexOpts, - commandParseOptions = onormalise showIndexOpts } +showIndex = DarcsCommand + { commandProgramName = "darcs" + , 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." + , commandExtraArgs = 0 + , commandExtraArgHelp = [] + , commandCommand = showIndexCmd + , commandPrereq = amInRepository + , commandCompleteArgs = noArgs + , commandArgdefaults = nodefaults + , commandAdvancedOptions = [] + , commandBasicOptions = odesc showIndexBasicOpts + , commandDefaults = defaultFlags showIndexOpts + , commandCheckOptions = ocheck showIndexOpts + , commandParseOptions = onormalise showIndexOpts + } + where + showIndexBasicOpts = O.nullFlag ^ O.repoDir + showIndexOpts = showIndexBasicOpts `withStdOpts` oid dump :: [DarcsFlag] -> Maybe (M.Map FilePath FileID) -> Tree IO -> IO () dump opts fileids tree = do - let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0' + let line | O.nullFlag ? opts = \t -> putStr t >> putChar '\0' | otherwise = putStrLn output (p, i) = do let hash = case itemHash i of NoHash -> "(no hash available)" - h -> BS.unpack $ encodeBase16 h + h -> BC.unpack $ encodeBase16 h path = anchorPath "" p isdir = case i of SubTree _ -> "/" @@ -112,13 +94,13 @@ mapM_ output $ (floatPath ".", SubTree x) : list x showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -showIndexCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repo -> +showIndexCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \repo -> do index <- readIndex repo index_tree <- updateIndex index fileids <- (M.fromList . map (\((a,_),b) -> (anchorPath "" a,b))) <$> listFileIDs index dump opts (Just fileids) index_tree showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -showPristineCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ +showPristineCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ readRecorded >=> dump opts Nothing diff --git a/src/Darcs/UI/Commands/ShowPatchIndex.hs b/src/Darcs/UI/Commands/ShowPatchIndex.hs --- a/src/Darcs/UI/Commands/ShowPatchIndex.hs +++ b/src/Darcs/UI/Commands/ShowPatchIndex.hs @@ -3,67 +3,51 @@ import Prelude () import Darcs.Prelude -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag(Verbose), useCache ) +import Darcs.UI.Commands + ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Flags ( DarcsFlag, useCache, verbose ) import Prelude hiding ( (^) ) -import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Options + ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) -import Darcs.Repository.InternalTypes ( Repository(..) ) -import Darcs.Repository ( withRepository, RepoJob(..) ) +import Darcs.Repository ( withRepository, RepoJob(..), repoLocation ) import Darcs.Repository.PatchIndex -import Control.Arrow () - -showPatchIndexBasicOpts :: DarcsOption a - (Bool -> Bool -> Bool -> Maybe String -> a) -showPatchIndexBasicOpts = O.files ^ O.directories ^ O.nullFlag ^ O.workingRepoDir - -showPatchIndexOpts :: DarcsOption a - (Bool - -> Bool - -> Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showPatchIndexOpts = showPatchIndexBasicOpts `withStdOpts` oid + ( dumpPatchIndex, piTest, doesPatchIndexExist, isPatchIndexInSync) showPatchIndex :: DarcsCommand [DarcsFlag] -showPatchIndex = DarcsCommand { - commandProgramName = "darcs", - commandName = "patch-index", - commandDescription = "Check integrity of patch index", - commandHelp = - "When given the `--verbose` flag, the command dumps the complete content\n" - ++ "of the patch index and checks its integrity.", - commandExtraArgs = 0, - commandExtraArgHelp = [], - commandCommand = showPatchIndexCmd, - commandPrereq = amInHashedRepository, - commandGetArgPossibilities = return [], - commandArgdefaults = nodefaults, - commandAdvancedOptions = [], - commandBasicOptions = odesc showPatchIndexBasicOpts, - commandDefaults = defaultFlags showPatchIndexOpts, - commandCheckOptions = ocheck showPatchIndexOpts, - commandParseOptions = onormalise showPatchIndexOpts } +showPatchIndex = DarcsCommand + { commandProgramName = "darcs" + , commandName = "patch-index" + , commandDescription = "Check integrity of patch index" + , commandHelp = + "When given the `--verbose` flag, the command dumps the complete content\n" ++ + "of the patch index and checks its integrity." + , commandExtraArgs = 0 + , commandExtraArgHelp = [] + , commandCommand = showPatchIndexCmd + , commandPrereq = amInHashedRepository + , commandCompleteArgs = noArgs + , commandArgdefaults = nodefaults + , commandAdvancedOptions = [] + , commandBasicOptions = odesc showPatchIndexBasicOpts + , commandDefaults = defaultFlags showPatchIndexOpts + , commandCheckOptions = ocheck showPatchIndexOpts + , commandParseOptions = onormalise showPatchIndexOpts + } + where + showPatchIndexBasicOpts = O.nullFlag ^ O.repoDir + showPatchIndexOpts = showPatchIndexBasicOpts `withStdOpts` oid showPatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showPatchIndexCmd _ opts _ - | Verbose `elem` opts = do - withRepository (useCache opts) $ RepoJob $ \repo@(Repo repodir _ _ _) -> - dumpPatchIndex repodir >> piTest repo + | verbose opts = + withRepository (useCache ? opts) $ RepoJob $ \repo -> + let loc = repoLocation repo in dumpPatchIndex loc >> piTest loc | otherwise = - withRepository (useCache opts) $ RepoJob $ \(repo@(Repo repodir _ _ _)) -> do - ex <- doesPatchIndexExist repodir + withRepository (useCache ? opts) $ RepoJob $ \repo -> do + ex <- doesPatchIndexExist (repoLocation repo) if ex then do sy <- isPatchIndexInSync repo if sy diff --git a/src/Darcs/UI/Commands/ShowRepo.hs b/src/Darcs/UI/Commands/ShowRepo.hs --- a/src/Darcs/UI/Commands/ShowRepo.hs +++ b/src/Darcs/UI/Commands/ShowRepo.hs @@ -15,31 +15,35 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} module Darcs.UI.Commands.ShowRepo ( showRepo ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) import Data.Char ( toLower, isSpace ) import Data.List ( intercalate ) import Control.Monad ( when, unless, liftM ) import Text.Html ( tag, stringToHtml ) import Darcs.Util.Path ( AbsolutePath ) -import Darcs.UI.Flags ( DarcsFlag(XMLOutput, Verbose, NoFiles), useCache ) -import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Flags ( DarcsFlag, useCache, hasXmlOutput, verbose, enumeratePatches ) +import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) -import Darcs.Repository ( withRepository, RepoJob(..), readRepo ) -import Darcs.Repository.Internal ( Repository(..), repoXor ) -import Darcs.Repository.InternalTypes ( Pristine(..) ) -import Darcs.Repository.Cache ( Cache(..) ) -import Darcs.Repository.Format ( RepoFormat(..) ) -import Darcs.Repository.Prefs ( getPreflist ) -import Darcs.Repository.Motd ( getMotd ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.Repository + ( Repository + , repoFormat + , repoLocation + , repoPristineType + , repoCache + , withRepository + , RepoJob(..) + , readRepo ) +import Darcs.Repository.Hashed( repoXor ) +import Darcs.Repository.PatchIndex ( isPatchIndexDisabled, doesPatchIndexExist ) +import Darcs.Repository.Prefs ( getPreflist, getMotd ) import Darcs.Patch ( IsRepoType, RepoPatch ) -import Darcs.Patch.Set ( newset2RL ) +import Darcs.Patch.Set ( patchSet2RL ) import Darcs.Patch.Witnesses.Ordered ( lengthRL ) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.Patch.Apply( ApplyState ) @@ -52,39 +56,21 @@ "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" ++ "The 'Weak Hash' identifies the set of patches of a repository independently\n" ++ "of ordering. It can be used to easily compare two repositories of a same\n" ++ "project. It is not cryptographically secure.\n" ++ "\n" ++ + "By default, output includes statistics that require walking through the patches\n" ++ + "recorded in the repository, namely the 'Weak Hash' and the count of patches.\n" ++ + "If this data isn't needed, use `--no-enum-patches` to accelerate this command\n" ++ + "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" showRepoDescription :: String showRepoDescription = "Show repository summary information" -showRepoBasicOpts :: DarcsOption a (Maybe String -> Bool -> O.XmlOutput -> a) -showRepoBasicOpts = O.workingRepoDir ^ O.files ^ O.xmloutput - -showRepoOpts :: DarcsOption a - (Maybe String - -> Bool - -> O.XmlOutput - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showRepoOpts = showRepoBasicOpts `withStdOpts` oid - showRepo :: DarcsCommand [DarcsFlag] showRepo = DarcsCommand { commandProgramName = "darcs" @@ -95,7 +81,7 @@ , commandExtraArgHelp = [] , commandCommand = repoCmd , commandPrereq = amInRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showRepoBasicOpts @@ -103,10 +89,16 @@ , commandCheckOptions = ocheck showRepoOpts , commandParseOptions = onormalise showRepoOpts } + where + showRepoBasicOpts = O.repoDir ^ O.xmlOutput ^ O.enumPatches + showRepoOpts = showRepoBasicOpts `withStdOpts` oid repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -repoCmd _ opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr - in withRepository (useCache opts) $ RepoJob $ \repository -> actuallyShowRepo (putInfo put_mode) repository opts +repoCmd _ opts _ = + let put_mode = if hasXmlOutput opts then showInfoXML else showInfoUsr + in withRepository (useCache ? opts) $ + RepoJob $ \repository -> + actuallyShowRepo (putInfo put_mode) repository opts -- Some convenience functions to output a labelled text string or an -- XML tag + value (same API). If no value, output is suppressed @@ -123,11 +115,11 @@ safeTag ('#':cs) = "num_" ++ safeTag cs safeTag (c:cs) = toLower c : safeTag cs --- labelled strings: labels are right-aligned at 14 characters; +-- labelled strings: labels are right-aligned at 15 characters; -- subsequent lines in multi-line output are indented accordingly. showInfoUsr :: ShowInfo -showInfoUsr t i = replicate (14 - length t) ' ' ++ t ++ ": " ++ - intercalate ('\n' : replicate 16 ' ') (lines i) ++ "\n" +showInfoUsr t i = replicate (15 - length t) ' ' ++ t ++ ": " ++ + intercalate ('\n' : replicate 17 ' ') (lines i) ++ "\n" type PutInfo = String -> String -> IO () putInfo :: ShowInfo -> PutInfo @@ -137,19 +129,29 @@ -- sub-displays. The `out' argument is one of the above operations to -- output a labelled text string or an XML tag and contained value. -actuallyShowRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO () -actuallyShowRepo out r@(Repo loc rf pris cs) opts = do - when (XMLOutput `elem` opts) (putStr "\n") - when (Verbose `elem` opts) (out "Show" $ show r) - showRepoFormat out rf - out "Root" loc - showRepoAux out pris cs - showRepoPrefs out - unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show )) - unless (NoFiles `elem` opts) (showXor out r) - showRepoMOTD out r - when (XMLOutput `elem` opts) (putStr "\n") +actuallyShowRepo + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO () +actuallyShowRepo out r opts = do + when (hasXmlOutput opts) (putStr "\n") + when (verbose opts) (out "Show" $ show r) + out "Format" $ showInOneLine $ repoFormat r + let loc = repoLocation r + out "Root" loc + out "PristineType" $ show $ repoPristineType r + out "Cache" $ showInOneLine $ repoCache r + piExists <- doesPatchIndexExist loc + piDisabled <- isPatchIndexDisabled loc + out "PatchIndex" $ + case (piExists, piDisabled) of + (_, True) -> "disabled" + (True, False) -> "enabled" + (False, False) -> "enabled, but not yet created" + showRepoPrefs out + when (enumeratePatches opts) (do numPatches r >>= (out "Num Patches" . show) + showXor out r) + showRepoMOTD out r + when (hasXmlOutput opts) (putStr "\n") showXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => PutInfo -> Repository rt p wR wU wR -> IO () @@ -162,14 +164,8 @@ -- the routines below work to provide more human-readable information -- regarding the repository elements. -showRepoFormat :: PutInfo -> RepoFormat -> IO () -showRepoFormat out rf = out "Format" . intercalate ", " . lines . show $ rf - -showRepoAux :: PutInfo -> Pristine -> Cache -> IO () -showRepoAux out pris cs = - do out "Pristine" $ show pris - out "Cache" $ intercalate ", " $ lines $ show cs - +showInOneLine :: Show a => a -> String +showInOneLine = intercalate ", " . lines . show showRepoPrefs :: PutInfo -> IO () showRepoPrefs out = do @@ -179,10 +175,9 @@ where prefOut = uncurry out . (\(p,v) -> (p++" Pref", dropWhile isSpace v)) . break isSpace showRepoMOTD :: RepoPatch p => PutInfo -> Repository rt p wR wU wR -> IO () -showRepoMOTD out (Repo loc _ _ _) = getMotd loc >>= out "MOTD" . BC.unpack +showRepoMOTD out repo = getMotd (repoLocation repo) >>= out "MOTD" . BC.unpack -- Support routines to provide information used by the PutInfo operations above. numPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO Int -numPatches r = (lengthRL . newset2RL) `liftM` readRepo r - +numPatches r = (lengthRL . patchSet2RL) `liftM` readRepo r diff --git a/src/Darcs/UI/Commands/ShowTags.hs b/src/Darcs/UI/Commands/ShowTags.hs --- a/src/Darcs/UI/Commands/ShowTags.hs +++ b/src/Darcs/UI/Commands/ShowTags.hs @@ -27,14 +27,12 @@ import System.IO ( stderr, hPutStrLn ) import Darcs.Patch.Set ( PatchSet(..) ) -import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) ) +import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) -import Darcs.UI.Commands.Tag ( getTags ) +import Darcs.UI.Commands.Util ( repoTags ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl ) -import Darcs.UI.Options - ( DarcsOption, PrimDarcsOption - , oid, odesc, ocheck, onormalise, defaultFlags - ) +import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Text ( formatText ) import Darcs.Util.Path ( AbsolutePath ) @@ -51,24 +49,6 @@ ++ "if this happens." ] -showTagsBasicOpts :: PrimDarcsOption (Maybe String) -showTagsBasicOpts = O.possiblyRemoteRepo - -showTagsOpts :: DarcsOption a - (Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -showTagsOpts = showTagsBasicOpts `withStdOpts` oid - showTags :: DarcsCommand [DarcsFlag] showTags = DarcsCommand { commandProgramName = "darcs" @@ -79,7 +59,7 @@ , commandExtraArgHelp = [] , commandCommand = tagsCmd , commandPrereq = findRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showTagsBasicOpts @@ -87,14 +67,17 @@ , commandCheckOptions = ocheck showTagsOpts , commandParseOptions = onormalise showTagsOpts } + where + showTagsBasicOpts = O.possiblyRemoteRepo + showTagsOpts = showTagsBasicOpts `withStdOpts` oid tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in - withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> + withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> readRepo repo >>= printTags where printTags :: PatchSet rt p wW wZ -> IO () - printTags = join . fmap (sequence_ . map process) . getTags + printTags = join . fmap (sequence_ . map process) . repoTags process :: String -> IO () process t = normalize t t False >>= putStrLn normalize :: String -> String -> Bool -> IO String diff --git a/src/Darcs/UI/Commands/Tag.hs b/src/Darcs/UI/Commands/Tag.hs --- a/src/Darcs/UI/Commands/Tag.hs +++ b/src/Darcs/UI/Commands/Tag.hs @@ -15,37 +15,45 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.UI.Commands.Tag ( tag, getTags ) where +module Darcs.UI.Commands.Tag ( tag ) where import Prelude () import Darcs.Prelude import Control.Monad ( when ) -import Data.Maybe ( catMaybes ) +import System.IO ( hPutStr, stderr ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags - ( DarcsFlag(AskDeps), getDate, compression, verbosity, useCache, umask, getAuthor - , hasAuthor ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) -import qualified Darcs.UI.Options.All as O -import Darcs.UI.PatchHeader ( getLog ) -import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully ) -import Darcs.Repository ( withRepoLock, Repository, RepoJob(..), readRepo, - tentativelyAddPatch, finalizeRepositoryChanges, - ) +import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Patch.Info ( patchinfo ) +import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch - ( Patchy, PrimPatch, PrimOf + ( PrimPatch, PrimOf , IsRepoType, RepoPatch ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Info ( patchinfo, piTag ) -import Darcs.Patch.Depends ( getUncovered ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) -import Darcs.Patch.Named.Wrapped ( infopatch, adddeps, runInternalChecker, namedInternalChecker ) -import Darcs.Patch.Set ( PatchSet(..), emptyPatchSet, appendPSFL, newset2FL, patchSetfMap ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully ) +import Darcs.Patch.Named.Wrapped + ( infopatch, adddeps, runInternalChecker, namedInternalChecker ) +import Darcs.Patch.Set + ( PatchSet(..), emptyPatchSet, appendPSFL, patchSet2FL ) import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL, (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) + +import Darcs.Repository + ( withRepoLock, Repository, RepoJob(..), readRepo + , tentativelyAddPatch, finalizeRepositoryChanges, + ) +import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) ) + +import Darcs.UI.Commands + ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) +import Darcs.UI.Commands.Util ( repoTags ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Flags + ( DarcsFlag, getDate, compress, verbosity, useCache, umask, getAuthor, author ) +import Darcs.UI.Options + ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) +import qualified Darcs.UI.Options.All as O +import Darcs.UI.PatchHeader ( getLog ) import Darcs.UI.SelectChanges ( WhichChanges(..) , selectionContext @@ -53,12 +61,10 @@ , PatchSelectionContext(allowSkipAll) ) import qualified Darcs.UI.SelectChanges as S -import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) ) -import Darcs.Util.Path ( AbsolutePath ) +import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Tree( Tree ) -import System.IO ( hPutStr, stderr ) tagDescription :: String tagDescription = "Name the current repository state for future reference." @@ -91,47 +97,6 @@ "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" ++ "described in `darcs record`.\n" -tagBasicOpts :: DarcsOption a - (Maybe String - -> Maybe String - -> Bool - -> Maybe O.AskLongComment - -> Bool - -> Maybe String - -> a) -tagBasicOpts - = O.patchname - ^ O.author - ^ O.pipe - ^ O.askLongComment - ^ O.askdeps - ^ O.workingRepoDir - -tagAdvancedOpts :: DarcsOption a (O.Compression -> O.UMask -> a) -tagAdvancedOpts = O.compress ^ O.umask - -tagOpts :: DarcsOption a - (Maybe String - -> Maybe String - -> Bool - -> Maybe O.AskLongComment - -> Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.Compression - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts - tag :: DarcsCommand [DarcsFlag] tag = DarcsCommand { commandProgramName = "darcs" @@ -142,7 +107,7 @@ , commandExtraArgHelp = ["[TAGNAME]"] , commandCommand = tagCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc tagAdvancedOpts , commandBasicOptions = odesc tagBasicOpts @@ -150,6 +115,16 @@ , commandCheckOptions = ocheck tagOpts , commandParseOptions = onormalise tagOpts } + where + tagBasicOpts + = O.patchname + ^ O.author + ^ O.pipe + ^ O.askLongComment + ^ O.askDeps + ^ O.repoDir + tagAdvancedOpts = O.compress ^ O.umask + tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts filterNonInternal :: IsRepoType rt => PatchSet rt p wX wY -> PatchSet rt p wX wY filterNonInternal = @@ -159,25 +134,25 @@ tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagCmd _ opts args = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do date <- getDate (hasPipe opts) - the_author <- getAuthor (hasAuthor opts) (hasPipe opts) + the_author <- getAuthor (author ? opts) (hasPipe opts) patches <- readRepo repository - tags <- getTags patches + tags <- repoTags patches let nonInternalPatches = filterNonInternal patches Sealed chosenPatches <- - if AskDeps `elem` opts - then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (newset2FL nonInternalPatches) + if O.askDeps ? opts + then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (patchSet2FL nonInternalPatches) else return $ Sealed nonInternalPatches let deps = getUncovered chosenPatches (name, long_comment) <- get_name_log (NilFL :: FL (PrimOf p) wA wA) args tags myinfo <- patchinfo date name the_author long_comment let mypatch = infopatch myinfo NilFL - _ <- tentativelyAddPatch repository (compression opts) (verbosity opts) YesUpdateWorking + _ <- tentativelyAddPatch repository (compress ? opts) (verbosity ? opts) YesUpdateWorking $ n2pia $ adddeps mypatch deps - finalizeRepositoryChanges repository YesUpdateWorking (compression opts) + finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts) putStrLn $ "Finished tagging patch '"++name++"'" - where get_name_log ::(Patchy prim, PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String]) + where get_name_log ::(PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String]) get_name_log nilFL a tags = do (name, comment, _) <- getLog (case parseFlags O.patchname opts of @@ -196,9 +171,6 @@ " already exists." return ("TAG " ++ name, comment) -getTags :: PatchSet rt p wW wR -> IO [String] -getTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps - -- This may be useful for developers, but users don't care about -- internals: -- @@ -217,7 +189,7 @@ -> IO (Sealed (FL (PatchInfoAnd rt p) wX)) askAboutTagDepends flags ps = do let opts = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = [] , S.interactive = True , S.selectDeps = O.PromptDeps diff --git a/src/Darcs/UI/Commands/Test.hs b/src/Darcs/UI/Commands/Test.hs --- a/src/Darcs/UI/Commands/Test.hs +++ b/src/Darcs/UI/Commands/Test.hs @@ -37,14 +37,9 @@ , nodefaults , putInfo , amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag( SetScriptsExecutable - , Linear - , Backoff - , Bisect - , LeaveTestDir - ) - , useCache, verbosity ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Completion ( noArgs ) +import Darcs.UI.Flags ( DarcsFlag, useCache, verbosity ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( hopefully ) import Darcs.Repository ( @@ -66,24 +61,17 @@ , mapFL , mapRL_RL ) -import Darcs.Patch.Conflict ( Conflict ) -import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.ApplyMonad ( ApplyMonad ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Format ( PatchListFormat ) +import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.Patchy ( Patchy - , Invert - , Apply - , ShowPatch - ) +import Darcs.Patch.Invert ( Invert ) import Darcs.Patch ( RepoPatch , apply , description , invert ) import Darcs.Patch.Named.Wrapped ( WrappedNamed ) -import Darcs.Patch.Set ( newset2RL ) +import Darcs.Patch.Set ( patchSet2RL ) import Darcs.Util.Printer ( putDocLn , text ) @@ -131,31 +119,6 @@ ,"break the test is found at random." ] -testBasicOpts :: DarcsOption a - (O.TestStrategy -> O.LeaveTestDir -> Maybe String -> a) -testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.workingRepoDir - -testAdvancedOpts :: DarcsOption a (O.SetScriptsExecutable -> a) -testAdvancedOpts = O.setScriptsExecutable - -testOpts :: DarcsOption a - (O.TestStrategy - -> O.LeaveTestDir - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.SetScriptsExecutable - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -testOpts = testBasicOpts `withStdOpts` testAdvancedOpts - test :: DarcsCommand [DarcsFlag] test = DarcsCommand { commandProgramName = "darcs" @@ -166,7 +129,7 @@ , commandExtraArgHelp = ["[[INITIALIZATION]", "COMMAND]"] , commandCommand = testCommand , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc testAdvancedOpts , commandBasicOptions = odesc testBasicOpts @@ -174,6 +137,10 @@ , commandCheckOptions = ocheck testOpts , commandParseOptions = onormalise testOpts } + where + testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.repoDir + testAdvancedOpts = O.setScriptsExecutable + testOpts = testBasicOpts `withStdOpts` testAdvancedOpts -- | Functions defining a strategy for executing a test type Strategy = forall rt p wX wY @@ -186,11 +153,11 @@ testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () testCommand _ opts args = - withRepository (useCache opts) $ RepoJob $ \repository -> do + withRepository (useCache ? opts) $ RepoJob $ \repository -> do patches <- readRepo repository (init,testCmd) <- case args of [] -> - do t <- getTest (verbosity opts) + do t <- getTest (verbosity ? opts) return (return ExitSuccess, t) [cmd] -> do putStrLn $ "Using test command:\n"++cmd @@ -200,21 +167,22 @@ putStrLn $ "Using test command:\n"++cmd return (system init, system cmd) _ -> fail "Test expects zero to two arguments." - let wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir + let wd = case O.leaveTestDir ? opts of + O.YesLeaveTestDir -> withPermDir + O.NoLeaveTestDir -> withTempDir withRecorded repository (wd "testing") $ \_ -> do - when (SetScriptsExecutable `elem` opts) setScriptsExecutable + when (O.yes (O.setScriptsExecutable ? opts)) setScriptsExecutable _ <- init putInfo opts $ text "Running test...\n" testResult <- testCmd - let track = chooseStrategy opts - track opts testCmd testResult (mapRL_RL hopefully . newset2RL $ patches) + let track = chooseStrategy (O.testStrategy ? opts) + track opts testCmd testResult (mapRL_RL hopefully . patchSet2RL $ patches) -chooseStrategy :: [DarcsFlag] -> Strategy -chooseStrategy opts - | Bisect `elem` opts = trackBisect - | Linear `elem` opts = trackLinear - | Backoff `elem` opts = trackBackoff - | otherwise = oneTest +chooseStrategy :: O.TestStrategy -> Strategy +chooseStrategy O.Bisect = trackBisect +chooseStrategy O.Linear = trackLinear +chooseStrategy O.Backoff = trackBackoff +chooseStrategy O.Once = oneTest -- | test only the last recorded state oneTest :: Strategy @@ -229,7 +197,7 @@ trackLinear opts testCmd (ExitFailure _) (ps:<:p) = do let ip = invert p safeApply ip - when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ip + when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches ip putStrLn "Trying without the patch:" putDocLn $ description ip hFlush stdout @@ -260,7 +228,7 @@ case splitAtRL n ahead of ( ahead' :> skipped' ) -> do unapplyRL skipped' - when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches skipped' + when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches skipped' testResult <- testCmd case testResult of ExitFailure _ -> @@ -300,13 +268,13 @@ type BisectState = (Int, Int) -- | Create Bisect PatchTree from the RL -patchTreeFromRL :: (Patchy p) => RL p wX wY -> PatchTree p wX wY +patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY patchTreeFromRL (NilRL :<: l) = Leaf l patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of (r :> l) -> Fork (patchTreeFromRL l) (patchTreeFromRL r) -- | Convert PatchTree back to RL -patchTree2RL :: (Patchy p) => PatchTree p wX wY -> RL p wX wY +patchTree2RL :: PatchTree p wX wY -> RL p wX wY patchTree2RL (Leaf p) = NilRL :<: p patchTree2RL (Fork l r) = patchTree2RL r +<+ patchTree2RL l @@ -334,31 +302,29 @@ putStrLn "Last recent patch that fails the test (assuming monotony in the given range):" putDocLn (description p) -jumpHalfOnRight :: (IsHunk p, Conflict p, - PatchListFormat p, ShowPatch p, PatchInspect p, - Patchy p, ApplyMonad (ApplyState p) DefaultIO) +jumpHalfOnRight :: (Invert p, Apply p, PatchInspect p, + ApplyMonad (ApplyState p) DefaultIO) => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnRight opts l = do unapplyRL ps - when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ps + when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches ps where ps = patchTree2RL l -jumpHalfOnLeft :: (IsHunk p, Conflict p, - PatchListFormat p, ShowPatch p, PatchInspect p, - Patchy p, ApplyMonad (ApplyState p) DefaultIO) +jumpHalfOnLeft :: (Apply p, PatchInspect p, + ApplyMonad (ApplyState p) DefaultIO) => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnLeft opts r = do applyRL p - when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p + when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches p where p = patchTree2RL r -applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad (ApplyState p) DefaultIO) +applyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO) => RL p wX wY -> IO () applyRL patches = sequence_ (mapFL safeApply (reverseRL patches)) -unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad (ApplyState p) DefaultIO) +unapplyRL :: (Invert p, Apply p, ApplyMonad (ApplyState p) DefaultIO) => RL p wX wY -> IO () unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches) -safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad (ApplyState p) DefaultIO) +safeApply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO) => p wX wY -> IO () safeApply p = runDefault (apply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg diff --git a/src/Darcs/UI/Commands/TransferMode.hs b/src/Darcs/UI/Commands/TransferMode.hs --- a/src/Darcs/UI/Commands/TransferMode.hs +++ b/src/Darcs/UI/Commands/TransferMode.hs @@ -27,8 +27,9 @@ import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Exception ( prettyException ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag ) -import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Progress ( setProgressMode ) import Darcs.Util.Global ( darcsdir ) @@ -52,24 +53,6 @@ "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++ "hundreds of times!\n" -transferModeBasicOpts :: DarcsOption a (Maybe String -> a) -transferModeBasicOpts = O.workingRepoDir - -transferModeOpts :: DarcsOption a - (Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -transferModeOpts = transferModeBasicOpts `withStdOpts` oid - transferMode :: DarcsCommand [DarcsFlag] transferMode = DarcsCommand { commandProgramName = "darcs" @@ -78,7 +61,7 @@ , commandDescription = transferModeDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandCommand = transferModeCmd , commandPrereq = amInRepository , commandArgdefaults = nodefaults @@ -88,6 +71,9 @@ , commandCheckOptions = ocheck transferModeOpts , commandParseOptions = onormalise transferModeOpts } + where + transferModeBasicOpts = O.repoDir + transferModeOpts = transferModeBasicOpts `withStdOpts` oid transferModeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () transferModeCmd _ _ _ = do setProgressMode False diff --git a/src/Darcs/UI/Commands/Unrecord.hs b/src/Darcs/UI/Commands/Unrecord.hs --- a/src/Darcs/UI/Commands/Unrecord.hs +++ b/src/Darcs/UI/Commands/Unrecord.hs @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Unrecord ( unrecord @@ -31,17 +31,16 @@ import Prelude hiding ( (^) ) import Control.Exception ( catch, IOException ) -import Control.Monad ( when, unless ) -import Data.Maybe( isJust, mapMaybe ) -import Data.List ( intercalate ) +import Control.Monad ( when ) +import Data.Maybe( isJust ) import Darcs.Util.Tree( Tree ) import System.Exit ( exitSuccess ) import Darcs.Patch ( IsRepoType, RepoPatch, invert, commute, effect ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Bundle ( makeBundleN, contextPatches, minContext ) -import Darcs.Patch.Depends ( findCommonWithThem, newsetUnion ) -import Darcs.Patch.Match ( firstMatch, matchFirstPatchset, matchAPatchread, MatchFlag ) +import Darcs.Patch.Depends ( findCommonWithThem, patchSetUnion ) +import Darcs.Patch.Match ( firstMatch, matchFirstPatchset, matchAPatch, MatchFlag ) import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL, Origin, SealedPatchSet ) @@ -59,22 +58,23 @@ import Darcs.Util.Lock( writeDocBinFile ) import Darcs.Repository.Prefs ( getDefaultRepoPath ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias - , putVerbose, printDryRunMessageAndExit + , putVerbose , setEnvDarcsPatches, amInHashedRepository , putInfo ) -import Darcs.UI.Commands.Util ( getUniqueDPatchName ) +import Darcs.UI.Commands.Util ( getUniqueDPatchName, printDryRunMessageAndExit ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags - ( doReverse, compression, verbosity, getOutput - , useCache, dryRun, umask, DarcsFlag ( NotInRemote ), minimize - , diffAlgorithm, hasXmlOutput, hasSummary, isInteractive, selectDeps ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) + ( DarcsFlag, changesReverse, compress, verbosity, getOutput + , useCache, dryRun, umask, minimize + , diffAlgorithm, xmlOutput, isInteractive, selectDeps ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import Darcs.UI.Options.All ( notInRemoteFlagName ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( WhichChanges(..), selectionContext, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.English ( presentParticiple ) -import Darcs.Util.Printer ( text, putDoc, (<>), (<+>) ) +import Darcs.Util.Printer ( text, putDoc, vcat, (<>), (<+>), ($$) ) import Darcs.Util.Progress ( debugMessage ) unrecordDescription :: String @@ -91,41 +91,6 @@ , "possibility that another user may have already pulled the patch." ] -unrecordBasicOpts :: DarcsOption a - ([MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe String -> a) -unrecordBasicOpts - = O.matchSeveralOrLast - ^ O.selectDeps - ^ O.interactive -- True - ^ O.workingRepoDir - -unrecordAdvancedOpts :: DarcsOption a (O.Compression -> O.UMask -> Bool -> a) -unrecordAdvancedOpts - = O.compress - ^ O.umask - ^ O.changesReverse - -unrecordOpts :: DarcsOption a - ([MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.Compression - -> O.UMask - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -unrecordOpts = unrecordBasicOpts `withStdOpts` unrecordAdvancedOpts - unrecord :: DarcsCommand [DarcsFlag] unrecord = DarcsCommand { commandProgramName = "darcs" @@ -136,7 +101,7 @@ , commandExtraArgHelp = [] , commandCommand = unrecordCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc unrecordAdvancedOpts , commandBasicOptions = odesc unrecordBasicOpts @@ -144,20 +109,27 @@ , commandCheckOptions = ocheck unrecordOpts , commandParseOptions = onormalise unrecordOpts } + where + unrecordBasicOpts + = O.notInRemote + ^ O.matchSeveralOrLast + ^ O.selectDeps + ^ O.interactive -- True + ^ O.repoDir + unrecordAdvancedOpts + = O.compress + ^ O.umask + ^ O.changesReverse + unrecordOpts = unrecordBasicOpts `withStdOpts` unrecordAdvancedOpts unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrecordCmd _ opts _ = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do - allpatches <- readRepo repository - let matchFlags = parseFlags O.matchSeveralOrLast opts - (_ :> patches) <- return $ - if firstMatch matchFlags - then getLastPatches matchFlags allpatches - else matchingHead matchFlags allpatches - let direction = if doReverse opts then Last else LastReversed + (_ :> removal_candidates) <- preselectPatches opts repository + let direction = if changesReverse ? opts then Last else LastReversed context = selectionContext direction "unrecord" (patchSelOpts opts) Nothing Nothing - (_ :> to_unrecord) <- runSelection patches context + (_ :> to_unrecord) <- runSelection removal_candidates context when (nullFL to_unrecord) $ do putInfo opts "No patches selected!" exitSuccess @@ -165,9 +137,9 @@ text "About to write out (potentially) modified patches..." setEnvDarcsPatches to_unrecord invalidateIndex repository - _ <- tentativelyRemovePatches repository (compression opts) + _ <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking to_unrecord - finalizeRepositoryChanges repository YesUpdateWorking (compression opts) + finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts) putInfo opts "Finished unrecording." getLastPatches :: (IsRepoType rt, RepoPatch p) => [MatchFlag] -> PatchSet rt p Origin wR @@ -218,68 +190,6 @@ , "later to your repository with `darcs apply`." ] -obliterateBasicOpts :: DarcsOption a - ([Maybe String] - -> [MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Maybe O.Summary - -> Maybe O.Output - -> Bool - -> O.DiffAlgorithm - -> O.DryRun - -> O.XmlOutput - -> a) -obliterateBasicOpts - = O.notInRemote - ^ O.matchSeveralOrLast - ^ O.selectDeps - ^ O.interactive - ^ O.workingRepoDir - ^ O.summary - ^ O.output - ^ O.minimize - ^ O.diffAlgorithm - ^ O.dryRunXml - -obliterateAdvancedOpts :: DarcsOption a - (O.Compression -> O.UseIndex -> O.UMask -> Bool -> a) -obliterateAdvancedOpts - = O.compress - ^ O.useIndex - ^ O.umask - ^ O.changesReverse - -obliterateOpts :: DarcsOption a - ([Maybe String] - -> [MatchFlag] - -> O.SelectDeps - -> Maybe Bool - -> Maybe String - -> Maybe O.Summary - -> Maybe O.Output - -> Bool - -> O.DiffAlgorithm - -> DryRun - -> O.XmlOutput - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.Compression - -> UseIndex - -> O.UMask - -> Bool - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -obliterateOpts = obliterateBasicOpts `withStdOpts` obliterateAdvancedOpts - obliterate :: DarcsCommand [DarcsFlag] obliterate = DarcsCommand { commandProgramName = "darcs" @@ -290,7 +200,7 @@ , commandExtraArgHelp = [] , commandCommand = obliterateCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc obliterateAdvancedOpts , commandBasicOptions = odesc obliterateBasicOpts @@ -298,13 +208,28 @@ , commandCheckOptions = ocheck obliterateOpts , commandParseOptions = onormalise obliterateOpts } + where + obliterateBasicOpts + = O.notInRemote + ^ O.matchSeveralOrLast + ^ O.selectDeps + ^ O.interactive + ^ O.repoDir + ^ O.summary + ^ O.output + ^ O.minimize + ^ O.diffAlgorithm + ^ O.dryRunXml + obliterateAdvancedOpts + = O.compress + ^ O.useIndex + ^ O.umask + ^ O.changesReverse + obliterateOpts = obliterateBasicOpts `withStdOpts` obliterateAdvancedOpts obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd = genericObliterateCmd "obliterate" -data NotInRemoteLocation = NotInDefaultRepo - | NotInRemotePath String - -- | genericObliterateCmd is the function that executes the "obliterate" and -- "unpull" commands. The first argument is the name under which the command is -- invoked (@unpull@ or @obliterate@). @@ -314,31 +239,17 @@ -> [String] -> IO () genericObliterateCmd cmdname _ opts _ = - let cacheOpt = useCache opts - verbOpt = verbosity opts - in withRepoLock (dryRun opts) cacheOpt YesUpdateWorking (umask opts) $ + let cacheOpt = useCache ? opts + verbOpt = verbosity ? opts + in withRepoLock (dryRun ? opts) cacheOpt YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do -- FIXME we may need to honour --ignore-times here, although this -- command does not take that option (yet) - pend <- unrecordedChanges (UseIndex, ScanKnown, diffAlgorithm opts) repository Nothing - allpatches <- readRepo repository - let collectNotIns (NotInRemote nir) = case nir of - Just p -> Just $ NotInRemotePath p - Nothing -> Just NotInDefaultRepo - collectNotIns _ = Nothing - notIns = mapMaybe collectNotIns opts - (auto_kept :> removal_candidates) <- case notIns of - [] -> do - let matchFlags = parseFlags O.matchSeveralOrLast opts - return $ if firstMatch matchFlags - then getLastPatches matchFlags allpatches - else matchingHead matchFlags allpatches - nirs -> do - (Sealed thems) <- - getNotInRemotePatches verbOpt cacheOpt repository nirs - return $ findCommonWithThem allpatches thems + pend <- unrecordedChanges (UseIndex, ScanKnown, diffAlgorithm ? opts) + O.NoLookForMoves O.NoLookForReplaces repository Nothing + (auto_kept :> removal_candidates) <- preselectPatches opts repository - let direction = if doReverse opts then Last else LastReversed + let direction = if changesReverse ? opts then Last else LastReversed context = selectionContext direction cmdname (patchSelOpts opts) Nothing Nothing (kept :> removed) <- runSelection removal_candidates context @@ -352,9 +263,9 @@ Just (_ :> p_after_pending) -> do printDryRunMessageAndExit "obliterate" verbOpt - (hasSummary O.NoSummary opts) - (dryRun opts) - (hasXmlOutput opts) + (O.summary ? opts) + (dryRun ? opts) + (xmlOutput ? opts) (isInteractive True opts) removed setEnvDarcsPatches removed @@ -362,11 +273,11 @@ savetoBundle opts (auto_kept `appendPSFL` kept) removed invalidateIndex repository _ <- tentativelyRemovePatches repository - (compression opts) YesUpdateWorking removed + (compress ? opts) YesUpdateWorking removed tentativelyAddToPending repository YesUpdateWorking $ invert $ effect removed finalizeRepositoryChanges repository - YesUpdateWorking (compression opts) + YesUpdateWorking (compress ? opts) debugMessage "Applying patches to working directory..." _ <- applyToWorking repository verbOpt (invert p_after_pending) @@ -376,30 +287,27 @@ putInfo opts $ "Finished" <+> text (presentParticiple cmdname) <> "." -- | Get the union of the set of patches in each specified location -getNotInRemotePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) - => O.Verbosity -> O.UseCache - -> Repository rt p wX wU wT -> [NotInRemoteLocation] - -> IO (SealedPatchSet rt p Origin) -getNotInRemotePatches verbOpt cacheOpt repository nirs = do - unless (verbOpt == O.Quiet) $ - putStrLn $ "Determining patches not in" ++ pluralExtra ++ ":\n" ++ names +remotePatches :: (IsRepoType rt, RepoPatch p) + => [DarcsFlag] + -> Repository rt p wX wU wT -> [O.NotInRemote] + -> IO (SealedPatchSet rt p Origin) +remotePatches opts repository nirs = do nirsPaths <- mapM getNotInRemotePath nirs - newsetUnion `fmap` mapM readNir nirsPaths + putInfo opts $ "Determining patches not in" <+> pluralExtra nirsPaths $$ + itemize nirsPaths + patchSetUnion `fmap` mapM readNir nirsPaths where - toName (NotInRemotePath s) = "'" ++ s ++ "'" - toName NotInDefaultRepo = "Default push/pull repo" - - pluralExtra = if length names > 1 then " any of" else "" - names = intercalate "\n" $ map ((leader ++) . toName) nirs - leader = " - " + pluralExtra names = if length names > 1 then "any of" else mempty + itemize = vcat . map (text . (" - " ++)) readNir n = do - r <- identifyRepositoryFor repository cacheOpt n + r <- identifyRepositoryFor repository (useCache ? opts) n rps <- readRepo r return $ seal rps - getNotInRemotePath (NotInRemotePath p) = return p - getNotInRemotePath NotInDefaultRepo = do + getNotInRemotePath :: O.NotInRemote -> IO String + getNotInRemotePath (O.NotInRemotePath p) = return p + getNotInRemotePath O.NotInDefaultRepo = do defaultRepo <- getDefaultRepoPath let err = fail $ "No default push/pull repo configured, please pass a " ++ "repo name to --" ++ notInRemoteFlagName @@ -418,7 +326,7 @@ mh :: forall wX . PatchSet rt p Origin wX -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX mh s@(PatchSet _ x) - | or (mapRL (matchAPatchread matchFlags) x) = contextPatches s + | or (mapRL (matchAPatch matchFlags) x) = contextPatches s mh (PatchSet (ts :<: Tagged t _ ps) x) = case mh (PatchSet ts (ps :<: t)) of (start :> patches) -> start :> patches +<+ x @@ -428,7 +336,7 @@ -> PatchSet rt p Origin wZ -> FL (PatchInfoAnd rt p) wZ wT -> IO () savetoBundle opts kept removed@(x :>: _) = do let genFullBundle = makeBundleN Nothing kept (mapFL_FL hopefully removed) - bundle <- if not (minimize opts) + bundle <- if not (minimize ? opts) then genFullBundle else do putInfo opts "Minimizing context, to generate bundle with full context hit ctrl-C..." ( case minContext kept removed of @@ -441,12 +349,33 @@ useAbsoluteOrStd writeDocBinFile putDoc outname bundle savetoBundle _ _ NilFL = return () +preselectPatches + :: (IsRepoType rt, RepoPatch p) + => [DarcsFlag] + -> Repository rt p wR wU wT + -> IO ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR) +preselectPatches opts repo = do + allpatches <- readRepo repo + let matchFlags = parseFlags O.matchSeveralOrLast opts + case O.notInRemote ? opts of + [] -> do + return $ + if firstMatch matchFlags + then getLastPatches matchFlags allpatches + else matchingHead matchFlags allpatches + -- FIXME what about match options when we have --not-in-remote? + -- It looks like they are simply ignored. + nirs -> do + (Sealed thems) <- + remotePatches opts repo nirs + return $ findCommonWithThem allpatches thems + patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.interactive = isInteractive True flags - , S.selectDeps = selectDeps flags - , S.summary = hasSummary O.NoSummary flags + , S.selectDeps = selectDeps ? flags + , S.summary = O.summary ? flags , S.withContext = O.NoContext } diff --git a/src/Darcs/UI/Commands/Unrevert.hs b/src/Darcs/UI/Commands/Unrevert.hs --- a/src/Darcs/UI/Commands/Unrevert.hs +++ b/src/Darcs/UI/Commands/Unrevert.hs @@ -15,29 +15,25 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, GADTs #-} - - module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where import Prelude () import Darcs.Prelude -import Prelude hiding ( (^), catch ) - import Control.Exception ( catch, IOException ) import System.Exit ( exitSuccess ) import Darcs.Util.Tree( Tree ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) +import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags - ( diffingOpts, verbosity, useCache, umask, compression, diffAlgorithm - , isInteractive, isUnified ) + ( diffingOpts, verbosity, useCache, umask, compress, diffAlgorithm + , isInteractive, withContext ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown (..), Reorder(..), AllowConflicts(..), ExternalMerge(..) , WantGuiPause(..), UpdateWorking(..), DryRun(NoDryRun) ) import Darcs.UI.Flags ( DarcsFlag ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) +import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..), unrevertUrl, considerMergeToWorking, @@ -48,6 +44,7 @@ import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, commute, fromPrims ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Named.Wrapped ( namepatch ) +import Darcs.Patch.Rebase ( dropAnyRebase ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) ) @@ -67,7 +64,6 @@ import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) -#include "impossible.h" unrevertDescription :: String unrevertDescription = @@ -83,51 +79,14 @@ "took place. Darcs will ask for confirmation before executing an\n" ++ "interactive command that will DEFINITELY prevent unreversion.\n" -unrevertBasicOpts :: DarcsOption a - (O.UseIndex - -> Maybe Bool - -> Maybe String - -> O.WithContext - -> O.DiffAlgorithm - -> a) -unrevertBasicOpts - = O.useIndex - ^ O.interactive -- True - ^ O.workingRepoDir - ^ O.withContext - ^ O.diffAlgorithm - -unrevertAdvancedOpts :: DarcsOption a (O.UMask -> a) -unrevertAdvancedOpts = O.umask - -unrevertOpts :: DarcsOption a - (UseIndex - -> Maybe Bool - -> Maybe String - -> O.WithContext - -> O.DiffAlgorithm - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UMask - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -unrevertOpts = unrevertBasicOpts `withStdOpts` unrevertAdvancedOpts - patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = [] , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default - , S.withContext = isUnified flags + , S.withContext = withContext ? flags } unrevert :: DarcsCommand [DarcsFlag] @@ -140,7 +99,7 @@ , commandExtraArgHelp = [] , commandCommand = unrevertCmd , commandPrereq = amInHashedRepository - , commandGetArgPossibilities = return [] + , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc unrevertAdvancedOpts , commandBasicOptions = odesc unrevertBasicOpts @@ -148,27 +107,37 @@ , commandCheckOptions = ocheck unrevertOpts , commandParseOptions = onormalise unrevertOpts } + where + unrevertBasicOpts + = O.useIndex + ^ O.interactive -- True + ^ O.repoDir + ^ O.withContext + ^ O.diffAlgorithm + unrevertAdvancedOpts = O.umask + unrevertOpts = unrevertBasicOpts `withStdOpts` unrevertAdvancedOpts unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrevertCmd _ opts [] = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do + withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do us <- readRepo repository Sealed them <- unrevertPatchBundle repository recorded <- readRecorded repository - unrecorded <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository Nothing + unrecorded <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) + O.NoLookForMoves O.NoLookForReplaces repository Nothing Sealed h_them <- return $ mergeThem us them Sealed pw <- considerMergeToWorking repository "unrevert" YesAllowConflictsAndMark YesUpdateWorking NoExternalMerge NoWantGuiPause - (compression opts) (verbosity opts) NoReorder - ( UseIndex, ScanKnown, diffAlgorithm opts ) + (compress ? opts) (verbosity ? opts) NoReorder + ( UseIndex, ScanKnown, diffAlgorithm ? opts ) NilFL h_them let context = selectionContextPrim First "unrevert" (patchSelOpts opts) Nothing Nothing (Just recorded) (p :> skipped) <- runSelection pw context tentativelyAddToPending repository YesUpdateWorking p withSignalsBlocked $ - do finalizeRepositoryChanges repository YesUpdateWorking (compression opts) - _ <- applyToWorking repository (verbosity opts) p `catch` \(e :: IOException) -> + do finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts) + _ <- applyToWorking repository (verbosity ? opts) p `catch` \(e :: IOException) -> fail ("Error applying unrevert to working directory...\n" ++ show e) debugMessage "I'm about to writeUnrevert." @@ -187,7 +156,7 @@ _ -> exitSuccess writeUnrevert repository NilFL recorded pend Just (p' :> _) -> do - rep <- readRepo repository + rep <- dropAnyRebase <$> readRepo repository date <- getIsoDateTime np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') bundle <- makeBundleN (Just recorded) rep (np :>: NilFL) diff --git a/src/Darcs/UI/Commands/Util.hs b/src/Darcs/UI/Commands/Util.hs --- a/src/Darcs/UI/Commands/Util.hs +++ b/src/Darcs/UI/Commands/Util.hs @@ -15,49 +15,76 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Util ( announceFiles , filterExistingPaths , testTentativeAndMaybeExit + , printDryRunMessageAndExit , getUniqueRepositoryName , getUniqueDPatchName + , expandDirs + , doesDirectoryReallyExist + , checkUnrelatedRepos + , repoTags ) where -import Control.Monad ( unless ) +import Control.Monad ( when, unless ) +import Data.Maybe ( catMaybes ) import Prelude () import Darcs.Prelude -import System.Exit ( ExitCode(..), exitWith ) +import System.Exit ( ExitCode(..), exitWith, exitSuccess ) +import System.FilePath.Posix ( () ) +import System.Posix.Files ( isDirectory ) -import Darcs.Util.Tree.Monad ( virtualTreeIO, exists ) -import Darcs.Util.Tree ( Tree ) +import Darcs.Patch ( RepoPatch, xmlSummary ) +import Darcs.Patch.Depends ( areUnrelatedRepos ) +import Darcs.Patch.Info ( toXml, piTag ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM ) +import Darcs.Patch.Set ( PatchSet(..), patchSetfMap ) +import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) -import Darcs.Patch ( RepoPatch ) import Darcs.Repository ( Repository, readRecorded, testTentative ) -import Darcs.Repository.State ( readUnrecordedFiltered ) +import Darcs.Repository.State + ( readUnrecordedFiltered, readWorking, restrictBoring + , TreeFilter(..), applyTreeFilter + ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Bundle ( patchFilename ) + +import Darcs.UI.PrintPatch ( showFriendly ) import Darcs.UI.Options.All ( Verbosity(..), SetScriptsExecutable, TestChanges (..) - , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..) ) + , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..) + , Summary(..), DryRun(..), XmlOutput(..), LookForMoves + ) + import Darcs.Util.Exception ( clarifyErrors ) +import Darcs.Util.File ( getFileStatus, withCurrentDirectory ) import Darcs.Util.Path - ( SubPath, toFilePath, getUniquePathName, floatPath ) -import Darcs.Util.Printer ( putDocLn, text, (<>), (<+>) ) -import Darcs.Util.Prompt ( PromptConfig(..), promptChar ) + ( SubPath, toFilePath, getUniquePathName, floatPath + , simpleSubPath, toPath, anchorPath + ) +import Darcs.Util.Printer + ( text, (<>), (<+>), hsep, ($$), vcat, vsep + , putDocLn, insertBeforeLastline, prefix + ) +import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn ) import Darcs.Util.Text ( pathlist ) +import Darcs.Util.Tree.Monad ( virtualTreeIO, exists ) +import Darcs.Util.Tree ( Tree ) +import qualified Darcs.Util.Tree as Tree + announceFiles :: Verbosity -> Maybe [SubPath] -> String -> IO () announceFiles Quiet _ _ = return () announceFiles _ (Just subpaths) message = putDocLn $ text message <> text ":" <+> pathlist (map toFilePath subpaths) announceFiles _ _ _ = return () -testTentativeAndMaybeExit :: (RepoPatch p, ApplyState p ~ Tree) - => Repository rt p wR wU wT +testTentativeAndMaybeExit :: Repository rt p wR wU wT -> Verbosity -> TestChanges -> SetScriptsExecutable @@ -78,6 +105,47 @@ yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') []) unless (yn == 'y') doExit +-- | @'printDryRunMessageAndExit' action flags 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\"@ @flags@ is the list of flags +-- which were sent to darcs @patches@ is the sequence of patches which would be +-- touched by @action@. +printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree) + => String + -> Verbosity -> Summary -> DryRun -> XmlOutput + -> Bool -- interactive + -> FL (PatchInfoAnd rt p) wX wY + -> IO () +printDryRunMessageAndExit action v s d x interactive patches = do + when (d == YesDryRun) $ do + putInfoX $ hsep [ "Would", text action, "the following changes:" ] + putDocLn put_mode + putInfoX $ text "" + putInfoX $ text "Making no changes: this is a dry run." + exitSuccess + when (not interactive && s == YesSummary) $ do + putInfoX $ hsep [ "Will", text action, "the following changes:" ] + putDocLn put_mode + where + put_mode = if x == YesXml + then text "" $$ + vcat (mapFL (indent . xml_info s) patches) $$ + text "" + else vsep $ mapFL (showFriendly v s) patches + + putInfoX = if x == YesXml then const (return ()) else putDocLn + + xml_info YesSummary = xml_with_summary + xml_info NoSummary = toXml . info + + xml_with_summary hp + | Just p <- hopefullyM hp = insertBeforeLastline (toXml $ info hp) + (indent $ xmlSummary p) + xml_with_summary hp = toXml (info hp) + + indent = prefix " " + -- | Given a repository and two common command options, classify the given list -- of subpaths according to whether they exist in the pristine or working tree. -- Paths which are neither in working nor pristine are reported and dropped. @@ -88,11 +156,12 @@ -> Verbosity -> UseIndex -> ScanKnown + -> LookForMoves -> [SubPath] -> IO ([SubPath],[SubPath]) -filterExistingPaths repo verb useidx scan paths = do +filterExistingPaths repo verb useidx scan lfm paths = do pristine <- readRecorded repo - working <- readUnrecordedFiltered repo useidx scan (Just paths) + working <- readUnrecordedFiltered repo useidx scan lfm (Just paths) let filepaths = map toFilePath paths check = virtualTreeIO $ mapM (exists . floatPath) filepaths (in_pristine, _) <- check pristine @@ -122,3 +191,46 @@ buildMsg n = "Directory or file '"++ name ++ "' already exists, creating dpatch as '"++ n ++"'" + +-- | For each directory in the list of 'SubPath's, add all paths +-- under that directory to the list. If the first argument is 'True', then +-- include even boring files. +-- +-- This is used by the add and remove commands to handle the --recursive option. +expandDirs :: Bool -> [SubPath] -> IO [SubPath] +expandDirs includeBoring subpaths = + do + boringFilter <- + if includeBoring + then return (TreeFilter id) + else restrictBoring Tree.emptyTree + fmap (map (fromJust . simpleSubPath)) $ + concat `fmap` mapM (expandOne boringFilter . toPath) subpaths + where + expandOne boringFilter "" = listFiles boringFilter + expandOne boringFilter f = do + isdir <- doesDirectoryReallyExist f + if not isdir + then return [f] + else do + fs <- withCurrentDirectory f (listFiles boringFilter) + return $ f: map (f ) fs + listFiles boringFilter = do + working <- applyTreeFilter boringFilter <$> readWorking + return $ map (anchorPath "" . fst) $ Tree.list working + +doesDirectoryReallyExist :: FilePath -> IO Bool +doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f + +checkUnrelatedRepos :: RepoPatch p + => Bool + -> PatchSet rt p wStart wX + -> PatchSet rt p wStart wY + -> IO () +checkUnrelatedRepos allowUnrelatedRepos us them = + when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $ + do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?" + unless confirmed $ putStrLn "Cancelled." >> exitSuccess + +repoTags :: PatchSet rt p wX wY -> IO [String] +repoTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps diff --git a/src/Darcs/UI/Commands/Util/Tree.hs b/src/Darcs/UI/Commands/Util/Tree.hs --- a/src/Darcs/UI/Commands/Util/Tree.hs +++ b/src/Darcs/UI/Commands/Util/Tree.hs @@ -30,47 +30,42 @@ import Control.Monad ( forM ) import Control.Monad.State.Strict( gets ) -import qualified Data.ByteString.Char8 as BSC -import Data.Char ( toLower ) - -import Darcs.Util.Tree.Monad - ( withDirectory, fileExists, directoryExists - , virtualTreeMonad, currentDirectory - , TreeMonad ) -import qualified Darcs.Util.Tree.Monad as HS ( exists, tree ) +import qualified Darcs.Util.Tree.Monad as TM + ( TreeMonad, withDirectory, fileExists, directoryExists + , virtualTreeMonad, currentDirectory, exists, tree ) import Darcs.Util.Tree ( Tree, listImmediate, findTree ) import Darcs.Util.Path - ( AnchoredPath(..), Name(..), floatPath ) + ( AnchoredPath(..), floatPath, eqAnycase ) -treeHasAnycase :: (Functor m, Monad m) +treeHasAnycase :: Monad m => Tree m -> FilePath -> m Bool treeHasAnycase tree path = - fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree + fst `fmap` TM.virtualTreeMonad (existsAnycase $ floatPath path) tree -existsAnycase :: (Functor m, Monad m) +existsAnycase :: Monad m => AnchoredPath - -> TreeMonad m Bool + -> TM.TreeMonad m Bool existsAnycase (AnchoredPath []) = return True -existsAnycase (AnchoredPath (Name x:xs)) = do - wd <- currentDirectory - Just tree <- gets (flip findTree wd . HS.tree) - let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree, - BSC.map toLower n == BSC.map toLower x ] +existsAnycase (AnchoredPath (x:xs)) = do + wd <- TM.currentDirectory + Just tree <- gets (flip findTree wd . TM.tree) + let subs = [ AnchoredPath [n] | (n, _) <- listImmediate tree, + eqAnycase n x ] or `fmap` forM subs (\path -> do - file <- fileExists path + file <- TM.fileExists path if file then return True - else withDirectory path (existsAnycase $ AnchoredPath xs)) + else TM.withDirectory path (existsAnycase $ AnchoredPath xs)) -treeHas :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool -treeHas tree path = fst `fmap` virtualTreeMonad (HS.exists $ floatPath path) tree +treeHas :: Monad m => Tree m -> FilePath -> m Bool +treeHas tree path = fst `fmap` TM.virtualTreeMonad (TM.exists $ floatPath path) tree -treeHasDir :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool -treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree +treeHasDir :: Monad m => Tree m -> FilePath -> m Bool +treeHasDir tree path = fst `fmap` TM.virtualTreeMonad (TM.directoryExists $ floatPath path) tree -treeHasFile :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool -treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree +treeHasFile :: Monad m => Tree m -> FilePath -> m Bool +treeHasFile tree path = fst `fmap` TM.virtualTreeMonad (TM.fileExists $ floatPath path) tree diff --git a/src/Darcs/UI/Commands/WhatsNew.hs b/src/Darcs/UI/Commands/WhatsNew.hs --- a/src/Darcs/UI/Commands/WhatsNew.hs +++ b/src/Darcs/UI/Commands/WhatsNew.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.UI.Commands.WhatsNew ( whatsnew @@ -37,17 +34,16 @@ import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch , applyToTree, plainSummaryPrims, primIsHunk - , listTouchedFiles, IsRepoType ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Choices ( patchChoicesLps, lpPatch ) +import Darcs.Patch.Apply ( Apply, ApplyState ) +import Darcs.Patch.Choices ( mkPatchChoices, labelPatches, unLabel ) +import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.FileHunk ( IsHunk (..) ) -import Darcs.Patch.Format ( PatchListFormat (..) ) +import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect (..) ) -import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.Prim.Class ( PrimDetails (..) ) -import Darcs.Patch.Show ( ShowPatch ) +import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) import Darcs.Patch.Split ( primSplitter ) import Darcs.Patch.TouchesFiles ( choosePreTouching ) import Darcs.Patch.Witnesses.Ordered @@ -58,29 +54,29 @@ ( Sealed (..), Sealed2 (..) , unFreeLeft ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.WZipper ( FZipper (..) ) import Darcs.Repository ( RepoJob (..), Repository - , listRegisteredFiles, readRecorded, readRepo - , unrecordedChangesWithPatches, withRepository + , readRecorded + , unrecordedChanges, withRepository ) import Darcs.Repository.Diff ( treeDiff ) import Darcs.Repository.Prefs ( filetypeFunction ) -import Darcs.Repository.State ( getMovesPs, getReplaces ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, amInRepository , commandAlias, nodefaults ) -import Darcs.Repository.Resolution ( patchsetConflictResolutions ) +import Darcs.UI.Completion ( modifiedFileArgs ) import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths ) import Darcs.UI.Flags - ( DarcsFlag (Summary, LookForAdds, LookForMoves), diffAlgorithm, diffingOpts - , isUnified, useCache, fixSubPaths - , verbosity, isInteractive, isUnified, lookForAdds, lookForMoves, lookForReplaces, hasSummary - , scanKnown, useIndex + ( DarcsFlag, diffAlgorithm + , withContext, useCache, fixSubPaths + , verbosity, isInteractive + , lookForAdds, lookForMoves, lookForReplaces + , scanKnown, useIndex, diffingOpts ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) +import Darcs.UI.Options + ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PrintPatch ( contextualPrintPatch, printPatch @@ -98,73 +94,37 @@ , skipOne, printSummary ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) -import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, fp2fn ) +import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath ) import Darcs.Util.Printer - ( putDocLn, renderString, RenderMode(..) + ( putDocLn, renderString , text, vcat ) import Darcs.Util.Prompt ( PromptConfig (..), promptChar ) - -whatsnewBasicOpts :: DarcsOption a - (Maybe O.Summary - -> O.WithContext - -> Bool - -> O.LookFor - -> O.DiffAlgorithm - -> Maybe String - -> Maybe Bool - -> a) -whatsnewBasicOpts - = O.summary - ^ O.withContext - ^ O.machineReadable - ^ O.lookfor - ^ O.diffAlgorithm - ^ O.workingRepoDir - ^ O.interactive -- False - -whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> O.IncludeBoring -> a) -whatsnewAdvancedOpts = O.useIndex ^ O.includeBoring - -whatsnewOpts :: DarcsOption a - (Maybe O.Summary - -> O.WithContext - -> Bool - -> O.LookFor - -> O.DiffAlgorithm - -> Maybe String - -> Maybe Bool - -> Maybe O.StdCmdAction - -> Bool - -> Bool - -> O.Verbosity - -> Bool - -> O.UseIndex - -> O.IncludeBoring - -> O.UseCache - -> Maybe String - -> Bool - -> Maybe String - -> Bool - -> a) -whatsnewOpts = whatsnewBasicOpts `withStdOpts` whatsnewAdvancedOpts +commonAdvancedOpts :: DarcsOption a (O.UseIndex -> O.IncludeBoring -> a) +commonAdvancedOpts = O.useIndex ^ O.includeBoring patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions - { S.verbosity = verbosity flags + { S.verbosity = verbosity ? flags , S.matchFlags = [] , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default - , S.summary = hasSummary (defaultSummary flags) flags - , S.withContext = isUnified flags + , S.summary = getSummary flags + , S.withContext = withContext ? flags } -defaultSummary :: [DarcsFlag] -> O.Summary -defaultSummary flags - | lookForAdds flags == O.YesLookForAdds = O.YesSummary - | parseFlags O.machineReadable flags = O.YesSummary - | otherwise = O.NoSummary +-- lookForAdds and machineReadable set YesSummary +-- unless NoSummary was given expressly +-- (or by default e.g. status) +getSummary :: [DarcsFlag] -> O.Summary +getSummary flags = case O.maybeSummary Nothing ? flags of + Just O.NoSummary -> O.NoSummary + Just O.YesSummary -> O.YesSummary + Nothing + | O.yes (lookForAdds flags) -> O.YesSummary + | O.machineReadable ? flags -> O.YesSummary + | otherwise -> O.NoSummary whatsnew :: DarcsCommand [DarcsFlag] whatsnew = DarcsCommand @@ -176,14 +136,24 @@ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = whatsnewCmd , commandPrereq = amInRepository - , commandGetArgPossibilities = listRegisteredFiles + , commandCompleteArgs = modifiedFileArgs , commandArgdefaults = nodefaults - , commandAdvancedOptions = odesc whatsnewAdvancedOpts + , commandAdvancedOptions = odesc commonAdvancedOpts , commandBasicOptions = odesc whatsnewBasicOpts , commandDefaults = defaultFlags whatsnewOpts , commandCheckOptions = ocheck whatsnewOpts , commandParseOptions = onormalise whatsnewOpts } + where + whatsnewBasicOpts + = O.maybeSummary Nothing + ^ O.withContext + ^ O.machineReadable + ^ O.lookfor + ^ O.diffAlgorithm + ^ O.repoDir + ^ O.interactive -- False + whatsnewOpts = whatsnewBasicOpts `withStdOpts` commonAdvancedOpts whatsnewDescription :: String whatsnewDescription = "List unrecorded changes in the working tree." @@ -207,9 +177,9 @@ "* `a f` and `a d/` respectively mean a new, but unadded, file or\n" ++ " directory, when using `--look-for-adds`.\n" ++ "\n" ++ - " An exclamation mark (!) as in `R! foo.c`, means the hunk is known to\n" ++ - " conflict with a hunk in another patch. The phrase `duplicated`\n" ++ - " means the hunk is known to be identical to a hunk in another patch.\n" ++ + " An exclamation mark (!) as in `R! foo.c`, means the change is known to\n" ++ + " conflict with a change in another patch. The phrase `duplicated`\n" ++ + " means the change is known to be identical to a change in another patch.\n" ++ "\n" ++ "The `--machine-readable` option implies `--summary` while making it more\n" ++ "parsable. Modified files are only shown as `M f`, and moves are shown in\n" ++ @@ -225,70 +195,96 @@ whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () whatsnewCmd fps opts args = - withRepository (useCache opts) $ RepoJob $ \(repo :: Repository rt p wR wU wR) -> do - let scan = scanKnown (O.adds (parseFlags O.lookfor opts)) (parseFlags O.includeBoring opts) + withRepository (useCache ? opts) $ RepoJob $ \(repo :: Repository rt p wR wU wR) -> do + let scan = scanKnown (lookForAdds opts) (O.includeBoring ? opts) existing_files <- do files <- if null args then return Nothing else Just . nubSort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." - files' <- traverse (filterExistingPaths repo (verbosity opts) (useIndex opts) scan) files + files' <- traverse + (filterExistingPaths + repo (verbosity ? opts) (useIndex ? opts) scan (lookForMoves opts)) + files let files'' = fmap snd files' when (files'' == Just []) $ fail "None of the files you specified exist." return files'' - let isLookForMoves = lookForMoves opts == O.YesLookForMoves && parseFlags O.summary opts /= Just O.NoSummary - isLookForAdds = lookForAdds opts == O.YesLookForAdds && parseFlags O.summary opts /= Just O.NoSummary - isLookForReplaces = lookForReplaces opts == O.YesLookForReplaces - isMachineReadable = parseFlags O.machineReadable opts - -- LookForAdds and LookForMoves implies Summary, unless it's explcitly disabled. - opts' | isLookForAdds = (Summary : filter (\o -> LookForAdds /= o && - LookForMoves /= o ) opts) - | isMachineReadable = (Summary:opts) - | otherwise = opts - movesPs <- if isLookForMoves - then getMovesPs repo existing_files - else return NilFL - Sealed replacePs <- if isLookForReplaces - then getReplaces (diffingOpts opts) repo existing_files - else return (Sealed NilFL) - Sealed noLookChanges <- filteredUnrecordedChanges opts' repo existing_files movesPs - (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) + + -- get all unrecorded changes, possibly including unadded or even boring + -- files if the appropriate options were supplied + Sealed allInterestingChanges <- + filteredUnrecordedChanges (diffingOpts opts) + (lookForMoves opts) (lookForReplaces opts) + repo existing_files + + -- get the recorded state pristine <- readRecorded repo - -- If we are looking for moves, return the corresponding FL of changes. - -- If we are looking for adds, return the corresponding FL of changes. - Sealed unaddedNewPathsPs <- if isLookForAdds + + -- the case --look-for-adds and --summary must be handled specially + -- in order to distinguish added and unadded files + + -- TODO: it would be nice if we could return the pair + -- (noLookChanges,unaddedNewPathsPs) in one go and also + -- with proper witnesses (e.g. as noLookChanges +>+ unaddedNewPathsPs) + -- This would also obviate the need for samePatchType. + Sealed noLookChanges <- + if haveLookForAddsAndSummary + then + -- do *not* look for adds here: + filteredUnrecordedChanges (O.useIndex ? opts, O.ScanKnown, O.diffAlgorithm ? opts) + (lookForMoves opts) (lookForReplaces opts) + repo existing_files + else return (Sealed NilFL) + Sealed unaddedNewPathsPs <- + if haveLookForAddsAndSummary then do - -- Use opts not opts', here, since we *do* want to look for adds. - Sealed lookChanges <- filteredUnrecordedChanges opts repo existing_files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) - noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine - lookAddsTree <- applyAddPatchesToPristine lookChanges pristine - ftf <- filetypeFunction - -- Return the patches that create files/dirs that aren't yet added. - unFreeLeft <$> treeDiff (diffAlgorithm opts) ftf noLookAddsTree lookAddsTree + noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine + lookAddsTree <- applyAddPatchesToPristine allInterestingChanges pristine + ftf <- filetypeFunction + -- Return the patches that create files/dirs that aren't yet added. + unFreeLeft <$> treeDiff (diffAlgorithm ? opts) ftf noLookAddsTree lookAddsTree else return (Sealed NilFL) - announceFiles (verbosity opts) existing_files "What's new in" - exitOnNoChanges (unaddedNewPathsPs, noLookChanges) + -- avoid ambiguous typing for unaddedNewPathsPs: + samePatchType noLookChanges unaddedNewPathsPs + + exitOnNoChanges allInterestingChanges + announceFiles (verbosity ? opts) existing_files "What's new in" if maybeIsInteractive opts - then runInteractive (interactiveHunks pristine) opts' pristine noLookChanges - else do - printChanges repo opts' pristine noLookChanges - printUnaddedPaths unaddedNewPathsPs + then + runInteractive (interactiveHunks pristine) (patchSelOpts opts) + (diffAlgorithm ? opts) pristine allInterestingChanges + else + if haveLookForAddsAndSummary + then do + printChanges pristine noLookChanges + printUnaddedPaths unaddedNewPathsPs + else do + printChanges pristine allInterestingChanges where - -- |Filter out hunk patches (leaving add patches) and return the tree + haveSummary = O.yes (getSummary opts) + haveLookForAddsAndSummary = haveSummary && O.yes (lookForAdds opts) + + -- Filter out hunk patches (leaving add patches) and return the tree -- resulting from applying the filtered patches to the pristine tree. applyAddPatchesToPristine ps pristine = do adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps applyToTree (reverseRL adds) pristine - exitOnNoChanges :: (FL p wX wY, FL p wU wV) -> IO () - exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!" - exitWith $ ExitFailure 1 + exitOnNoChanges :: FL p wX wY -> IO () + exitOnNoChanges NilFL = do putStrLn "No changes!" + exitWith $ ExitFailure 1 exitOnNoChanges _ = return () + -- This function does nothing. Its purpose is to enforce the + -- same patch type for the two passed FLs. This is necessary + -- in order to avoid ambiguous typing for unaddedNewPathsPs. + samePatchType :: FL p wX wY -> FL p wU wV -> IO () + samePatchType _ _ = return () + printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO () printUnaddedPaths NilFL = return () printUnaddedPaths ps = - putDocLn . lowercaseAs . renderString Encode . (plainSummaryPrims False []) $ ps + putDocLn . lowercaseAs . renderString . (plainSummaryPrims False) $ ps -- Make any add markers lowercase, to distinguish new-but-unadded files -- from those that are unrecorded, but added. @@ -296,56 +292,55 @@ lowercaseA ('A' : x) = 'a' : x lowercaseA x = x - -- |Appropriately print changes, according to the passed flags. - printChanges :: forall rt p wR wU wX wY. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository rt p wR wU wR -> [DarcsFlag] -> Tree IO -> FL (PrimOf p) wX wY + -- Appropriately print changes, according to the passed flags. + -- Note this cannot make distinction between unadded and added files. + printChanges :: ( IsHunk p, ShowPatch p, ShowContextPatch p + , PatchListFormat p, Apply p + , PrimDetails p, ApplyState p ~ Tree) + => Tree IO -> FL p wX wY -> IO () - printChanges repo opts' pristine changes - | Summary `elem` opts' = do - r <- readRepo repo - Sealed res <- return $ patchsetConflictResolutions r - let conflictFns = map fp2fn $ nubSort $ listTouchedFiles res - putDocLn $ plainSummaryPrims machineReadable conflictFns changes - | isUnified opts' == O.YesContext = contextualPrintPatch pristine changes + printChanges pristine changes + | haveSummary = putDocLn $ plainSummaryPrims machineReadable changes + | O.yes (withContext ? opts) = contextualPrintPatch pristine changes | otherwise = printPatch changes where machineReadable = parseFlags O.machineReadable opts - -- |return the unrecorded changes that affect an optional list of paths. - filteredUnrecordedChanges :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree, - ApplyState (PrimOf p) ~ Tree) - => [DarcsFlag] + -- return the unrecorded changes that affect an optional list of paths. + filteredUnrecordedChanges :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) + => (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) + -> O.LookForMoves + -> O.LookForReplaces -> Repository rt p wR wU wT -> Maybe [SubPath] - -> FL (PrimOf p) wR wT -- look-for-moves patches - -> FL (PrimOf p) wT wT -- look-for-replaces patches -> IO (Sealed (FL (PrimOf p) wT)) - filteredUnrecordedChanges opts' repo files movesPs replacesPs = + filteredUnrecordedChanges diffing lfm lfr repo files = let filePaths = map toFilePath <$> files in - choosePreTouching filePaths <$> unrecordedChangesWithPatches movesPs replacesPs (diffingOpts opts') repo files + choosePreTouching filePaths <$> + unrecordedChanges diffing lfm lfr repo files -- | Runs the 'InteractiveSelectionM' code -runInteractive :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, - PrimPatch p, PatchInspect p, PrimDetails p, - ApplyState p ~ Tree) +runInteractive :: PrimPatch p => InteractiveSelectionM p wX wY () -- Selection to run - -> [DarcsFlag] -- Command-line options + -> S.PatchSelectionOptions + -> O.DiffAlgorithm -> Tree IO -- Pristine -> FL p wX wY -- A list of patches -> IO () -runInteractive i opts pristine ps' = do - let (choices',lps') = patchChoicesLps ps' - let ps = evalStateT i $ +runInteractive i patchsel diffalg pristine ps' = do + let lps' = labelPatches Nothing ps' + choices' = mkPatchChoices lps' + ps = evalStateT i $ ISC { total = lengthFL lps' , current = 0 , lps = FZipper NilRL lps' , choices = choices' } void $ runReaderT ps $ - selectionContextPrim First "view" (patchSelOpts opts) - (Just (primSplitter (diffAlgorithm opts))) + selectionContextPrim First "view" patchsel + (Just (primSplitter diffalg)) Nothing (Just pristine) -- | The interactive part of @darcs whatsnew@ -interactiveHunks :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, +interactiveHunks :: (IsHunk p, ShowPatch p, ShowContextPatch p, Commute p, PatchInspect p, PrimDetails p, ApplyState p ~ Tree) => Tree IO -> InteractiveSelectionM p wX wY () interactiveHunks pristine = do @@ -353,7 +348,7 @@ case c of Nothing -> liftIO $ putStrLn "No more changes!" Just (Sealed2 lp) -> do - liftIO $ printPatch (lpPatch lp) + liftIO $ printPatch (unLabel lp) repeatThis lp where repeatThis lp = do @@ -362,14 +357,14 @@ (PromptConfig thePrompt (keysFor basic_options) (keysFor adv_options) (Just 'n') "?h") case yorn of - -- View hunk in context - 'v' -> liftIO (contextualPrintPatch pristine (lpPatch lp)) + -- View change in context + 'v' -> liftIO (contextualPrintPatch pristine (unLabel lp)) >> repeatThis lp -- View summary of the change - 'x' -> liftIO (printSummary (lpPatch lp)) + 'x' -> liftIO (printSummary (unLabel lp)) >> repeatThis lp - -- View hunk and move on - 'y' -> liftIO (contextualPrintPatch pristine (lpPatch lp)) + -- View change and move on + 'y' -> liftIO (contextualPrintPatch pristine (unLabel lp)) >> decide True lp >> next_hunk -- Go to the next patch 'n' -> decide False lp >> next_hunk @@ -379,12 +374,12 @@ (return ()) (\f -> decideWholeFile f False) next_hunk - -- View hunk in a pager - 'p' -> liftIO (printPatchPager $ lpPatch lp) + -- View change in a pager + 'p' -> liftIO (printPatchPager $ unLabel lp) >> repeatThis lp - -- Next hunk + -- Next change 'j' -> next_hunk - -- Previous hunk + -- Previous change 'k' -> prev_hunk -- Start from the first change 'g' -> start_over @@ -397,34 +392,49 @@ next_hunk = skipOne >> skipMundane >> interactiveHunks pristine prev_hunk = backOne >> interactiveHunks pristine options_yn = - [ KeyPress 'v' "view this hunk in a context" - , KeyPress 'y' - "view this hunk in a context and go to the next one" - , KeyPress 'n' "go to the next hunk" ] + [ KeyPress 'v' "view this change in a context" + , KeyPress 'y' "view this change in a context and go to the next one" + , KeyPress 'n' "skip this change and its dependencies" ] optionsView = - [ KeyPress 'p' "view this hunk in context wih pager " - , KeyPress 'x' "view a summary of this patch" + [ KeyPress 'p' "view this change in context wih pager " + , KeyPress 'x' "view a summary of this change" ] optionsNav = [ KeyPress 'q' "quit whatsnew" , KeyPress 's' "skip the rest of the changes to this file" - , KeyPress 'j' "skip to the next hunk" - , KeyPress 'k' "back up to previous hunk" - , KeyPress 'g' "start over from the first hunk" + , KeyPress 'j' "go to the next change" + , KeyPress 'k' "back up to previous change" + , KeyPress 'g' "start over from the first change" ] basic_options = [ options_yn ] adv_options = [ optionsView, optionsNav ] --- |status is an alias for whatsnew, with implicit Summary and LookForAdds + +-- | status is an alias for whatsnew, with implicit Summary and LookForAdds -- flags. We override the default description, to include the implicit flags. status :: DarcsCommand [DarcsFlag] -status = statusAlias { commandCommand = statusCmd - , commandDescription = statusDesc - } +status = statusAlias + { commandDescription = statusDesc + , commandAdvancedOptions = odesc commonAdvancedOpts + , commandBasicOptions = odesc statusBasicOpts + , commandDefaults = defaultFlags statusOpts + , commandCheckOptions = ocheck statusOpts + , commandParseOptions = onormalise statusOpts + } where statusAlias = commandAlias "status" Nothing whatsnew - statusCmd fps fs = commandCommand whatsnew fps (Summary : LookForAdds : fs) statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '." + statusBasicOpts + = O.maybeSummary (Just O.YesSummary) + ^ O.withContext + ^ O.machineReadable + ^ O.lookforadds O.YesLookForAdds + ^ O.lookforreplaces + ^ O.lookformoves + ^ O.diffAlgorithm + ^ O.repoDir + ^ O.interactive + statusOpts = statusBasicOpts `withStdOpts` commonAdvancedOpts maybeIsInteractive :: [DarcsFlag] -> Bool maybeIsInteractive = maybe False id . parseFlags O.interactive diff --git a/src/Darcs/UI/CommandsAux.hs b/src/Darcs/UI/CommandsAux.hs --- a/src/Darcs/UI/CommandsAux.hs +++ b/src/Darcs/UI/CommandsAux.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.UI.CommandsAux ( checkPaths , maliciousPatches diff --git a/src/Darcs/UI/Completion.hs b/src/Darcs/UI/Completion.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/UI/Completion.hs @@ -0,0 +1,185 @@ +-- | How to complete arguments +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +module Darcs.UI.Completion + ( fileArgs, knownFileArgs, unknownFileArgs, modifiedFileArgs + , noArgs, prefArgs + ) where + +import Prelude () +import Darcs.Prelude + +import Data.List ( (\\), stripPrefix ) +import Data.List.Ordered ( nubSort, minus ) +import Data.Maybe ( mapMaybe ) + +import Darcs.Patch ( listTouchedFiles ) + +import Darcs.Repository.Flags + ( UseCache(..) + ) +import Darcs.Repository.Prefs + ( getPreflist + ) +import Darcs.Repository.Job + ( RepoJob(..) + , withRepository + ) +import Darcs.Repository.State + ( readRecordedAndPending + , readUnrecordedFiltered + , unrecordedChanges + , restrictDarcsdir + , applyTreeFilter + , TreeFilter(..) + ) + +import Darcs.UI.Flags ( DarcsFlag ) +import qualified Darcs.UI.Flags as Flags +import qualified Darcs.UI.Options.All as O + +import Darcs.Util.File + ( doesDirectoryReallyExist + ) +import Darcs.Util.Global + ( darcsdir + ) +import Darcs.Util.Path + ( AnchoredPath, anchorPath + , AbsolutePath, toPath, floatSubPath, makeSubPathOf + ) +import Darcs.Util.Tree as Tree + ( Tree, ItemType(..) + , expand, expandPath, list, findTree, itemType, emptyTree + ) +import Darcs.Util.Tree.Plain ( readPlainTree ) + +-- | Return all files available under the original working +-- directory regardless of their repo state. +-- Subdirectories get a separator (slash) appended. +fileArgs :: (AbsolutePath, AbsolutePath) + -> [DarcsFlag] + -> [String] + -> IO [FilePath] +fileArgs (_, orig) _flags args = + notYetListed args $ + fmap (map anchoredToFilePath . listItems) $ + Tree.expand . applyTreeFilter restrictDarcsdir =<< readPlainTree (toPath orig) + +-- | Return all files available under the original working directory that +-- are unknown to darcs but could be added. +-- Subdirectories get a separator (slash) appended. +unknownFileArgs :: (AbsolutePath, AbsolutePath) + -> [DarcsFlag] + -> [String] + -> IO [FilePath] +unknownFileArgs fps flags args = notYetListed args $ do + let sk = if Flags.includeBoring flags then O.ScanBoring else O.ScanAll + lfm = Flags.lookForMoves flags + lfr = Flags.lookForReplaces flags + RepoTrees {have, known} <- repoTrees O.UseIndex sk lfm lfr + known_paths <- listHere known fps + have_paths <- listHere have fps + return $ map anchoredToFilePath $ nubSort have_paths `minus` nubSort known_paths + +-- | Return all files available under the original working directory that +-- are known to darcs (either recorded or pending). +-- Subdirectories get a separator (slash) appended. +knownFileArgs :: (AbsolutePath, AbsolutePath) + -> [DarcsFlag] + -> [String] + -> IO [FilePath] +knownFileArgs fps flags args = notYetListed args $ do + let (ui, sk, _) = Flags.diffingOpts flags + lfm = Flags.lookForMoves flags + lfr = Flags.lookForReplaces flags + RepoTrees {known} <- repoTrees ui sk lfm lfr + map anchoredToFilePath <$> listHere known fps + +-- | Return all files available under the original working directory that +-- are modified (relative to the recorded state). +-- Subdirectories get a separator (slash) appended. +modifiedFileArgs :: (AbsolutePath, AbsolutePath) + -> [DarcsFlag] + -> [String] + -> IO [FilePath] +modifiedFileArgs fps flags args = notYetListed args $ do + let (ui, sk, _) = Flags.diffingOpts flags + lfm = Flags.lookForMoves flags + lfr = Flags.lookForReplaces flags + RepoTrees {new} <- repoTrees ui sk lfm lfr + case uncurry makeSubPathOf fps of + Nothing -> return [] + Just here -> + return $ mapMaybe (stripPathPrefix (toPath here) . drop 2) new + +-- | Return the available prefs of the given kind. +prefArgs :: String + -> (AbsolutePath, AbsolutePath) + -> [DarcsFlag] + -> [String] + -> IO [String] +prefArgs name _ _ _ = getPreflist name + +-- | Return an empty list. +noArgs :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String] +noArgs _ _ _ = return [] + +-- * unexported helper functions + +data RepoTrees m = RepoTrees + { have :: Tree m -- ^ working tree + , known :: Tree m -- ^ recorded and pending + , new :: [FilePath] -- ^ unrecorded paths + } + +repoTrees :: O.UseIndex -> O.ScanKnown -> O.LookForMoves -> O.LookForReplaces + -> IO (RepoTrees IO) +repoTrees ui sk lfm lfr = do + inDarcsRepo <- doesDirectoryReallyExist darcsdir + if inDarcsRepo then + withRepository NoUseCache $ RepoJob $ \r -> do + known <- readRecordedAndPending r + have <- readUnrecordedFiltered r ui sk lfm Nothing + -- we are only interested in the affected paths so the diff + -- algorithm is irrelevant + new <- listTouchedFiles <$> unrecordedChanges (ui, sk, O.MyersDiff) lfm lfr r Nothing + return $ RepoTrees {..} + else + return RepoTrees {have = emptyTree, known = emptyTree, new = []} + +-- this is for completion which should give us everything under the original wd +subtreeHere :: Tree IO -> (AbsolutePath, AbsolutePath) -> IO (Maybe (Tree IO)) +subtreeHere tree fps = + case floatSubPath <$> uncurry makeSubPathOf fps of + Nothing -> do + return Nothing -- here is no subtree of the repo + Just here -> do + flip findTree here <$> expandPath tree here + +listHere :: Tree IO + -> (AbsolutePath, AbsolutePath) + -> IO [(AnchoredPath, ItemType)] +listHere tree fps = do + msubtree <- subtreeHere tree fps + case msubtree of + Nothing -> return [] + Just subtree -> listItems <$> expand subtree + +listItems :: Tree m -> [(AnchoredPath, ItemType)] +listItems = map (\(p, i) -> (p, itemType i)) . Tree.list + +anchoredToFilePath :: (AnchoredPath, ItemType) -> [Char] +anchoredToFilePath (path, TreeType) = anchorPath "" path -- ++ "/" +anchoredToFilePath (path, BlobType) = anchorPath "" path + +stripPathPrefix :: FilePath -> FilePath -> Maybe FilePath +stripPathPrefix = stripPrefix . addSlash where + addSlash [] = [] + addSlash xs = xs ++ "/" + +-- | Turn an action that creates all possible completions into one +-- that removes already given arguments. +notYetListed :: [String] -> IO [String] -> IO [String] +notYetListed already complete = do + possible <- complete + return $ possible \\ already diff --git a/src/Darcs/UI/Defaults.hs b/src/Darcs/UI/Defaults.hs --- a/src/Darcs/UI/Defaults.hs +++ b/src/Darcs/UI/Defaults.hs @@ -6,7 +6,7 @@ import Control.Monad.Writer import Data.Char ( isSpace ) import Data.Functor.Compose ( Compose(..) ) -import Data.List ( nub, intercalate ) +import Data.List ( nub ) import Data.Maybe ( catMaybes ) import qualified Data.Map as M import System.Console.GetOpt @@ -85,11 +85,9 @@ showCmdName (NormalCmd name) = name runChecks :: String -> ([DarcsFlag] -> [String]) -> [DarcsFlag] -> Writer [String] [DarcsFlag] -runChecks source check fs = case check fs of - [] -> return fs - es -> do - tell [intercalate "\n" $ map ((source++": ")++) es] - return fs +runChecks source check fs = do + tell $ map ((source++": ")++) $ check fs + return fs -- | Parse a list of lines from a defaults file, returning a list of 'DarcsFlag', -- given the current working directory, the command name, and a list of 'DarcsOption' diff --git a/src/Darcs/UI/Email.hs b/src/Darcs/UI/Email.hs --- a/src/Darcs/UI/Email.hs +++ b/src/Darcs/UI/Email.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP #-} module Darcs.UI.Email ( makeEmail , readEmail , formatHeader + -- just for testing + , prop_qp_roundtrip ) where import Prelude () @@ -11,14 +12,12 @@ import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf ) import Darcs.Util.Printer - ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS - , RenderMode(..) - ) + ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS ) import Darcs.Util.ByteString ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS ) import qualified Data.ByteString as B (ByteString, length, null, tail ,drop, head, concat, singleton - ,pack, append, empty, unpack + ,pack, append, empty, unpack, snoc ) import qualified Data.ByteString.Char8 as BC (index, head, pack) import Data.ByteString.Internal as B (c2w, createAndTrim) @@ -131,7 +130,8 @@ word8ToUDigit :: Word8 -> Char word8ToUDigit = toUpper . intToDigit . fromIntegral --- TODO is this doing mime encoding?? +-- Encode a ByteString according to "Quoted Printable" defined by MIME +-- (https://tools.ietf.org/html/rfc2045#section-6.7) qpencode :: B.ByteString -> B.ByteString qpencode s = unsafePerformIO -- Really only (3 + 2/75) * length or something in the worst case @@ -143,7 +143,7 @@ c | c == newline -> do poke (buf `plusPtr` bufi) newline encode ps' qlineMax buf (bufi+1) - | n == 0 && B.length ps > 1 -> + | n == 0 && B.length ps >= 1 -> do poke (buf `plusPtr` bufi) equals poke (buf `plusPtr` (bufi+1)) newline encode ps qlineMax buf (bufi + 2) @@ -220,7 +220,7 @@ fromMaybe "x-unknown" mcharset ++ "\"") $$ text "Content-Transfer-Encoding: quoted-printable" $$ text "" - $$ packedString (qpencode (renderPS Standard contents)) + $$ packedString (qpencode (renderPS contents)) $$ text "" $$ text "--=_" Nothing -> empty) @@ -229,10 +229,10 @@ $$ text "Content-Transfer-Encoding: quoted-printable" $$ text "Content-Description: Patch preview" $$ text "" - $$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS Standard bundle) of + $$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS bundle) of Just s -> packedString $ qpencode s -- this should not happen, but in case it does, keep everything - Nothing -> packedString $ qpencode $ renderPS Standard bundle) + Nothing -> packedString $ qpencode $ renderPS bundle) $$ text "--=_" $$ text "Content-Type: application/x-darcs-patch" <> (case mfilename of @@ -242,7 +242,7 @@ $$ text "Content-Disposition: attachment" $$ text "Content-Description: A darcs patch for your repository!" $$ text "" - $$ packedString (qpencode (renderPS Standard bundle)) + $$ packedString (qpencode (renderPS bundle)) $$ text "--=_--" $$ text "" $$ text "." @@ -257,3 +257,6 @@ Nothing -> s -- if it wasn't an email in the first place, just pass along. Just s' -> qpdecode s' +-- note: qpdecode appends an extra '\n' +prop_qp_roundtrip :: B.ByteString -> Bool +prop_qp_roundtrip s = B.snoc s 10 == (qpdecode . qpencode) s diff --git a/src/Darcs/UI/External.hs b/src/Darcs/UI/External.hs --- a/src/Darcs/UI/External.hs +++ b/src/Darcs/UI/External.hs @@ -28,6 +28,7 @@ import Prelude () import Darcs.Prelude +import Darcs.Util.Text ( showCommandLine ) import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( unless, when, filterM, liftM2, void ) @@ -35,11 +36,7 @@ import System.Exit ( ExitCode(..) ) import System.Environment ( getEnv -#if __GLASGOW_HASKELL__ >= 706 , getExecutablePath -#else - , getProgName -#endif ) import System.IO ( hPutStr, hPutStrLn, hClose, hIsTerminalDevice, stdout, stderr, Handle ) @@ -49,7 +46,10 @@ import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) ) import System.Process.Internals ( ProcessHandle ) -import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 ) +import GHC.IO.Encoding + ( getFileSystemEncoding + , setForeignEncoding + , setLocaleEncoding ) import Foreign.C.String ( CString, peekCString ) @@ -95,7 +95,7 @@ import Darcs.Util.Printer ( Doc, Printers, hPutDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS, simplePrinters, hPutDocCompr, - text, empty, packedString, vcat, renderString, RenderMode(..) ) + text, empty, packedString, vcat, renderString ) import qualified Darcs.Util.Ratified as Ratified import Darcs.UI.Email ( formatHeader ) @@ -116,28 +116,24 @@ -- |Get the name of the darcs executable (as supplied by @getExecutablePath@) darcsProgram :: IO String -#if __GLASGOW_HASKELL__ >= 706 darcsProgram = getExecutablePath -#else -darcsProgram = getProgName -#endif -pipeDoc :: RenderMode -> String -> [String] -> Doc -> IO ExitCode +pipeDoc :: String -> [String] -> Doc -> IO ExitCode pipeDoc = pipeDocInternal (PipeToOther simplePrinters) data WhereToPipe = PipeToSsh Compression -- ^ if pipe to ssh, can choose to compress or not | PipeToOther Printers -- ^ otherwise, can specify printers -pipeDocInternal :: WhereToPipe -> RenderMode -> String -> [String] -> Doc -> IO ExitCode -pipeDocInternal whereToPipe target c args inp = withoutNonBlock $ withoutProgress $ - do debugMessage $ unwords (c:args) +pipeDocInternal :: WhereToPipe -> String -> [String] -> Doc -> IO ExitCode +pipeDocInternal whereToPipe c args inp = withoutNonBlock $ withoutProgress $ + do debugMessage $ "Exec: " ++ showCommandLine (c:args) (Just i,_,_,pid) <- createProcess (proc c args){ std_in = CreatePipe - {- , delegate_ctlc = True -- requires process 1.2.2.0 -} } + , delegate_ctlc = True} debugMessage "Start transferring data" case whereToPipe of - PipeToSsh GzipCompression -> hPutDocCompr target i inp - PipeToSsh NoCompression -> hPutDoc target i inp - PipeToOther printers -> hPutDocWith printers target i inp + PipeToSsh GzipCompression -> hPutDocCompr i inp + PipeToSsh NoCompression -> hPutDoc i inp + PipeToOther printers -> hPutDocWith printers i inp hClose i rval <- waitForProcess pid debugMessage "Finished transferring data" @@ -145,10 +141,10 @@ putStrLn $ "Command not found:\n "++ show (c:args) return rval -pipeDocSSH :: Compression -> RenderMode -> SshFilePath -> [String] -> Doc -> IO ExitCode -pipeDocSSH compress target remoteAddr args input = do +pipeDocSSH :: Compression -> SshFilePath -> [String] -> Doc -> IO ExitCode +pipeDocSSH compress remoteAddr args input = do (ssh, ssh_args) <- getSSH SSH - pipeDocInternal (PipeToSsh compress) target ssh (ssh_args++ (sshUhost remoteAddr:args)) input + pipeDocInternal (PipeToSsh compress) ssh (ssh_args ++ ("--":sshUhost remoteAddr:args)) input sendEmail :: String -> String -> String -> String -> String -> String -> IO () sendEmail f t s cc scmd body = @@ -169,7 +165,7 @@ putHeader "Subject" s unless (null cc) $ putHeader "Cc" cc putHeader "X-Mail-Originator" "Darcs Version Control System" - hPutDocLn Standard h body + hPutDocLn h body where putHeader field value = B.hPut h (B.append (formatHeader field value) newline) newline = B.singleton 10 @@ -200,10 +196,10 @@ withOpenTemp $ \(hat,at) -> do ftable' <- case mbundle of Just (content,bundle) -> do - hPutDocLn Standard hat bundle - return [ ('b', renderString Standard content) , ('a', at) ] + hPutDocLn hat bundle + return [ ('b', renderString content) , ('a', at) ] Nothing -> - return [ ('b', renderString Standard body) ] + return [ ('b', renderString body) ] hClose hat let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable' r <- execSendmail ftable scmd fn @@ -217,7 +213,7 @@ withCString cc $ \ccp -> withCString s $ \sp -> withOpenTemp $ \(h,fn) -> do - hPutDoc Standard h body + hPutDoc h body hClose h writeDocBinFile "mailed_patch" body cfn <- canonFilename fn @@ -245,7 +241,7 @@ hPutStrLn h $ "To: "++ t hPutStrLn h $ find_from (linesPS body) hPutStrLn h $ find_subject (linesPS body) - hPutDocLn Standard h $ fixit $ linesPS body + hPutDocLn h $ fixit $ linesPS body hClose h let ftable = [('t',t)] r <- execSendmail ftable scmd fn @@ -299,15 +295,15 @@ #endif execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString -execPSPipe c args ps = fmap (renderPS Standard) - $ execDocPipe Standard c args +execPSPipe c args ps = fmap renderPS + $ execDocPipe c args $ packedString ps -execAndGetOutput :: RenderMode -> FilePath -> [String] -> Doc +execAndGetOutput :: FilePath -> [String] -> Doc -> IO (ProcessHandle, MVar (), B.ByteString) -execAndGetOutput target c args instr = do +execAndGetOutput c args instr = do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing - _ <- forkIO $ hPutDoc target i instr >> hClose i + _ <- forkIO $ hPutDoc i instr >> hClose i mvare <- newEmptyMVar _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed hPutStr stderr) @@ -315,9 +311,9 @@ out <- B.hGetContents o return (pid, mvare, out) -execDocPipe :: RenderMode -> String -> [String] -> Doc -> IO Doc -execDocPipe target c args instr = withoutProgress $ do - (pid, mvare, out) <- execAndGetOutput target c args instr +execDocPipe :: String -> [String] -> Doc -> IO Doc +execDocPipe c args instr = withoutProgress $ do + (pid, mvare, out) <- execAndGetOutput c args instr rval <- waitForProcess pid takeMVar mvare case rval of @@ -327,9 +323,9 @@ -- The following is needed for diff, which returns non-zero whenever -- the files differ. -execPipeIgnoreError :: RenderMode -> String -> [String] -> Doc -> IO Doc -execPipeIgnoreError target c args instr = withoutProgress $ do - (pid, mvare, out) <- execAndGetOutput target c args instr +execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc +execPipeIgnoreError c args instr = withoutProgress $ do + (pid, mvare, out) <- execAndGetOutput c args instr _ <- waitForProcess pid takeMVar mvare return $ if B.null out then empty else packedString out @@ -341,7 +337,7 @@ signString (SignSSL idf) d = signSSL idf d signPGP :: [String] -> Doc -> IO Doc -signPGP args = execDocPipe Standard "gpg" ("--clearsign":args) +signPGP args = execDocPipe "gpg" ("--clearsign":args) signSSL :: String -> Doc -> IO Doc signSSL idfile t = @@ -356,7 +352,7 @@ >>= B.writeFile cert opensslDoc ["smime", "-sign", "-signer", cert, "-inkey", idfile, "-noattr", "-text"] t - where opensslDoc = execDocPipe Standard "openssl" + where opensslDoc = execDocPipe "openssl" opensslPS = execPSPipe "openssl" @@ -418,27 +414,27 @@ where opensslPS = execPSPipe "openssl" viewDoc :: Doc -> IO () -viewDoc = viewDocWith simplePrinters Encode +viewDoc = viewDocWith simplePrinters -viewDocWith :: Printers -> RenderMode -> Doc -> IO () -viewDocWith pr mode msg = do +viewDocWith :: Printers -> Doc -> IO () +viewDocWith pr msg = do isTerminal <- hIsTerminalDevice stdout - void $ if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString mode msg) + void $ if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg) then do mbViewerPlusArgs <- getViewer case mbViewerPlusArgs of Just viewerPlusArgs -> do let (viewer : args) = words viewerPlusArgs - pipeDocToPager viewer args pr mode msg + pipeDocToPager viewer args pr msg Nothing -> return $ ExitFailure 127 -- No such command -- TEMPORARY passing the -K option should be removed as soon as -- we can use the delegate_ctrl_c feature in process - `ortryrunning` pipeDocToPager "less" ["-RK"] pr mode msg - `ortryrunning` pipeDocToPager "more" [] pr mode msg + `ortryrunning` pipeDocToPager "less" ["-RK"] pr msg + `ortryrunning` pipeDocToPager "more" [] pr msg #ifdef WIN32 - `ortryrunning` pipeDocToPager "more.com" [] pr mode msg + `ortryrunning` pipeDocToPager "more.com" [] pr msg #endif - `ortryrunning` pipeDocToPager "" [] pr mode msg - else pipeDocToPager "" [] pr mode msg + `ortryrunning` pipeDocToPager "" [] pr msg + else pipeDocToPager "" [] pr msg where lengthGreaterThan n _ | n <= 0 = True lengthGreaterThan _ [] = False lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs @@ -448,13 +444,13 @@ `catchall` return Nothing -pipeDocToPager :: String -> [String] -> Printers -> RenderMode -> Doc -> IO ExitCode +pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode -pipeDocToPager "" _ pr mode inp = do - hPutDocLnWith pr mode stdout inp +pipeDocToPager "" _ pr inp = do + hPutDocLnWith pr stdout inp return ExitSuccess -pipeDocToPager c args pr mode inp = pipeDocInternal (PipeToOther pr) mode c args inp +pipeDocToPager c args pr inp = pipeDocInternal (PipeToOther pr) c args inp -- | Given two shell commands as arguments, execute the former. The -- latter is then executed if the former failed because the executable @@ -522,7 +518,6 @@ getEditor :: IO String getEditor = getEnv "DARCS_EDITOR" `catchall` - getEnv "DARCSEDITOR" `catchall` getEnv "VISUAL" `catchall` getEnv "EDITOR" `catchall` return "nano" @@ -532,37 +527,45 @@ a `catchall` b = a `catchNonSignal` (\_ -> b) --- | In some environments, darcs requires that certain global GHC library variables that --- control the encoding used in internal translations are set to specific values. +-- | On Posix systems, GHC by default uses the user's locale encoding to +-- determine how to decode/encode the raw byte sequences in the Posix API +-- to/from 'String'. It also uses certain special variants of this +-- encoding to determine how to handle encoding errors. -- --- @setDarcsEncoding@ enforces those settings, and should be called before the --- first time any darcs operation is run, and again if anything else might have --- set those encodings to different values. +-- See "GHC.IO.Encoding" for details. -- --- Note that it isn't thread-safe and has a global effect on your program. +-- In particular, the default variant used for command line arguments and +-- environment variables is //ROUNDTRIP, which means that /any/ byte sequence +-- can be decoded and re-encoded w/o failure or loss of information. To +-- enable this, GHC uses code points that are outside the range of the regular +-- unicode set. This is what you get with 'getFileSystemEncoding'. -- --- The current behaviour of this function is as follows, though this may --- change in future: +-- We need to preserve the raw bytes e.g. for file names passed in by the +-- user and also when reading file names from disk; also when re-generating +-- files from patches, and when we display them to the user. -- --- Encodings are only set on GHC 7.4 and up, on any non-Windows platform. +-- So we want to use this encoding variant for *all* IO and for (almost) all +-- conversions between raw bytes and 'String's. The encoding used for IO from +-- and to handles is controlled by 'setLocaleEncoding' which we use here to +-- make it equal to the //ROUNDTRIP variant. -- --- Two encodings are set, both to @GHC.IO.Encoding.char8@: --- @GHC.IO.Encoding.setFileSystemEncoding@ and @GHC.IO.Encoding.setForeignEncoding@. +-- @setDarcsEncoding@ should be called before the +-- first time any darcs operation is run, and again if anything else might have +-- set those encodings to different values. -- --- Prevent HLint from warning us about a redundant do if the macro isn't --- defined: +-- Note that it isn't thread-safe and has a global effect on your program. +-- +-- On Windows, this function does (and should) not do anything. setDarcsEncodings :: IO () +#ifdef WIN32 +setDarcsEncodings = return () +#else setDarcsEncodings = do - --- This is needed for appropriate behaviour from getArgs and from general --- filesystem calls (e.g. getDirectoryContents, readFile, ...) - setFileSystemEncoding char8 - --- This ensures that foreign calls made by hashed-storage to stat --- filenames returned from getDirectoryContents are translated appropriately - setForeignEncoding char8 - - return () + e <- getFileSystemEncoding + -- TODO check if we have to set this, too. + setForeignEncoding e + setLocaleEncoding e +#endif -- The following functions are copied from the encoding package (BSD3 -- licence, by Henning Günther). diff --git a/src/Darcs/UI/Flags.hs b/src/Darcs/UI/Flags.hs --- a/src/Darcs/UI/Flags.hs +++ b/src/Darcs/UI/Flags.hs @@ -17,59 +17,35 @@ {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Flags - ( -- TODO we want to stop exporting the constructors of DarcsFlag - -- from here. First need to change all the relevant code over to the - -- using helpers from this module instead. - F.DarcsFlag( .. ) - , compression + ( F.DarcsFlag + -- FIXME these are temporary exceptions + ( WorkRepoDir -- init + , NewRepo -- convert, clone + , UpToPattern -- clone --to-xxx -> -xxx hack + , UpToPatch -- same + , UpToHash -- same + , OnePattern -- same + , OnePatch -- same + , OneHash -- same + ) , remoteDarcs - , reorder - , minimize - , editDescription , diffingOpts , diffOpts , scanKnown - , externalMerge , wantGuiPause , isInteractive - , maxCount , willRemoveLogFile - , isUnified - , doHappyForwarding , includeBoring - , doAllowCaseOnly - , doAllowWindowsReserved - , doReverse - , usePacks - , showChangesOnlyToFiles - , removeFromAmended - , toMatchFlags - , verbosity - , useCache - , umask - , dryRun , lookForAdds , lookForMoves , lookForReplaces - , diffAlgorithm - , runTest - , testChanges - , setScriptsExecutable - , withWorkingDir - , leaveTestDir - , remoteRepos , setDefault - , cloneKind - , workRepo , allowConflicts - , runPatchIndex - , useIndex - , hasSummary , hasXmlOutput - , selectDeps - , hasAuthor , hasLogfile - , patchFormat + , quiet + , verbose + , enumeratePatches , fixRemoteRepos , fixUrl @@ -83,15 +59,53 @@ , fileHelpAuthor , environmentHelpEmail , getSubject - , getCharset , getInReplyTo , getCc , environmentHelpSendmail - , siblings , getOutput , getDate - , getReply - , applyAs + + -- * Re-exports + , O.compress + , O.diffAlgorithm + , O.reorder + , O.minimize + , O.editDescription + , O.externalMerge + , O.maxCount + , O.matchAny + , O.withContext + , O.happyForwarding + , O.allowCaseDifferingFilenames + , O.allowWindowsReservedFilenames + , O.changesReverse + , O.usePacks + , O.onlyToFiles + , O.amendUnrecord + , O.verbosity + , O.useCache + , O.useIndex + , O.umask + , O.dryRun + , O.runTest + , O.testChanges + , O.setScriptsExecutable + , O.withWorkingDir + , O.leaveTestDir + , O.remoteRepos + , O.cloneKind + , O.workRepo + , O.patchIndexNo + , O.patchIndexYes + , O.xmlOutput + , O.selectDeps + , O.author + , O.reply + , O.patchFormat + , O.charset + , O.siblings + , O.applyAs + , O.enumPatches ) where import Prelude () @@ -107,28 +121,25 @@ import Control.Monad ( unless ) import System.Directory ( doesDirectoryExist, createDirectory ) import System.FilePath.Posix ( () ) +import System.Environment ( lookupEnv ) -import qualified Darcs.Patch.Match as MF ( MatchFlag(..) ) import Darcs.UI.External ( catchall ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag( .. ) ) import Darcs.UI.Options.Core import qualified Darcs.UI.Options.All as O -import Darcs.Util.Environment ( maybeGetEnv ) -import Darcs.Util.Exception ( firstJustIO ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( askUser , askUserListItem ) -import Darcs.Util.Lock ( writeLocaleFile ) +import Darcs.Util.Lock ( writeTextFile ) import Darcs.Repository.Prefs ( getPreflist , getGlobal , globalPrefsDirDoc , globalPrefsDir ) -import Darcs.Util.ByteString ( decodeString ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.IsoDate ( getIsoDateTime, cleanLocalDate ) import Darcs.Util.Path @@ -146,20 +157,17 @@ type Config = [F.DarcsFlag] -compression :: Config -> O.Compression -compression = parseFlags O.compress +verbose :: Config -> Bool +verbose = (== O.Verbose) . parseFlags O.verbosity +quiet :: Config -> Bool +quiet = (== O.Quiet) . parseFlags O.verbosity + remoteDarcs :: Config -> O.RemoteDarcs remoteDarcs = O.remoteDarcs . parseFlags O.network -reorder :: Config -> O.Reorder -reorder = parseFlags O.reorder - -minimize :: Config -> Bool -minimize = parseFlags O.minimize - -editDescription :: Config -> Bool -editDescription = parseFlags O.editDescription +enumeratePatches :: Config -> Bool +enumeratePatches = (== O.YesEnumPatches) . parseFlags O.enumPatches diffOpts :: O.UseIndex -> O.LookForAdds -> O.IncludeBoring -> O.DiffAlgorithm -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) diffOpts use_index look_for_adds include_boring diff_alg = @@ -172,17 +180,15 @@ scanKnown O.YesLookForAdds O.YesIncludeBoring = O.ScanBoring diffingOpts :: Config -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) -diffingOpts flags = diffOpts (useIndex flags) (lookForAdds flags) O.NoIncludeBoring (diffAlgorithm flags) - -externalMerge :: Config -> O.ExternalMerge -externalMerge = parseFlags O.useExternalMerge +diffingOpts flags = diffOpts (O.useIndex ? flags) (lookForAdds flags) + (parseFlags O.includeBoring flags) (O.diffAlgorithm ? flags) -- | This will become dis-entangled as soon as we inline these functions. wantGuiPause :: Config -> O.WantGuiPause wantGuiPause fs = if (hasDiffCmd fs || hasExternalMerge fs) && hasPause fs then O.YesWantGuiPause else O.NoWantGuiPause where - hasDiffCmd = isJust . O._diffCmd . parseFlags O.extDiff - hasExternalMerge = (/= O.NoExternalMerge) . parseFlags O.useExternalMerge + hasDiffCmd = isJust . O.diffCmd . parseFlags O.extDiff + hasExternalMerge = (/= O.NoExternalMerge) . parseFlags O.externalMerge hasPause = (== O.YesWantGuiPause) . parseFlags O.pauseForGui -- | Non-trivial interaction between options. Explicit @-i@ or @-a@ dominates, @@ -198,102 +204,30 @@ decide O.YesDryRun _ _ Nothing = False decide _ _ _ Nothing = def -maxCount :: Config -> Maybe Int -maxCount = parseFlags O.matchMaxcount - willRemoveLogFile :: Config -> Bool willRemoveLogFile = O._rmlogfile . parseFlags O.logfile -isUnified :: Config -> O.WithContext -isUnified = parseFlags O.withContext - -doHappyForwarding :: Config -> Bool -doHappyForwarding = parseFlags O.happyForwarding - includeBoring :: Config -> Bool includeBoring cfg = case parseFlags O.includeBoring cfg of O.NoIncludeBoring -> False O.YesIncludeBoring -> True -doAllowCaseOnly :: Config -> Bool -doAllowCaseOnly = parseFlags O.allowCaseDifferingFilenames - -doAllowWindowsReserved :: Config -> Bool -doAllowWindowsReserved = parseFlags O.allowWindowsReservedFilenames - -doReverse :: Config -> Bool -doReverse = parseFlags O.changesReverse - -usePacks :: Config -> Bool -usePacks = parseFlags O.usePacks - -showChangesOnlyToFiles :: Config -> Bool -showChangesOnlyToFiles = parseFlags O.onlyToFiles - -removeFromAmended :: Config -> Bool -removeFromAmended = parseFlags O.amendUnrecord - -toMatchFlags :: Config -> [MF.MatchFlag] -toMatchFlags = parseFlags O.matchAny - -verbosity :: Config -> O.Verbosity -verbosity = parseFlags O.verbosity - -useCache :: Config -> O.UseCache -useCache = parseFlags O.useCache - -umask :: Config -> O.UMask -umask = parseFlags O.umask - -dryRun :: Config -> O.DryRun -dryRun = parseFlags O.dryRun - -runPatchIndex :: Config -> O.WithPatchIndex -runPatchIndex = parseFlags O.patchIndex - lookForAdds :: Config -> O.LookForAdds lookForAdds = O.adds . parseFlags O.lookfor lookForReplaces :: Config -> O.LookForReplaces lookForReplaces = O.replaces . parseFlags O.lookfor -diffAlgorithm :: Config -> O.DiffAlgorithm -diffAlgorithm = parseFlags O.diffAlgorithm - lookForMoves :: Config -> O.LookForMoves lookForMoves = O.moves . parseFlags O.lookfor -runTest :: Config -> O.RunTest -runTest = parseFlags O.test - -testChanges :: Config -> O.TestChanges -testChanges = parseFlags O.testChanges - -setScriptsExecutable :: Config -> O.SetScriptsExecutable -setScriptsExecutable = parseFlags O.setScriptsExecutable - -withWorkingDir :: Config -> O.WithWorkingDir -withWorkingDir = parseFlags O.useWorkingDir - -leaveTestDir :: Config -> O.LeaveTestDir -leaveTestDir = parseFlags O.leaveTestDir - -remoteRepos :: Config -> O.RemoteRepos -remoteRepos = parseFlags O.remoteRepos - setDefault :: Bool -> Config -> O.SetDefault setDefault defYes = maybe def noDef . parseFlags O.setDefault where def = if defYes then O.YesSetDefault False else O.NoSetDefault False noDef yes = if yes then O.YesSetDefault True else O.NoSetDefault True -cloneKind :: Config -> O.CloneKind -cloneKind = parseFlags O.partial - -workRepo :: Config -> O.WorkRepo -workRepo = parseFlags O.workRepo - allowConflicts :: Config -> O.AllowConflicts -allowConflicts = maybe O.NoAllowConflicts id . parseFlags (O.conflicts O.NoAllowConflicts) +allowConflicts = maybe O.NoAllowConflicts id . parseFlags O.conflictsNo -- | Ugly. The alternative is to put the remoteRepos accessor into the IO monad, -- which is hardly better. @@ -394,10 +328,10 @@ as <- getEasyAuthor case as of [a] -> if alwaysAsk then - askForAuthor (fancyPrompt as) (fancyPrompt as) + askForAuthor False (fancyPrompt as) (fancyPrompt as) else return a - [] -> askForAuthor shortPrompt longPrompt - _ -> askForAuthor (fancyPrompt as) (fancyPrompt as) + [] -> askForAuthor True shortPrompt longPrompt + _ -> askForAuthor False (fancyPrompt as) (fancyPrompt as) where shortPrompt = askUser "What is your email address? " longPrompt = askUser "What is your email address (e.g. Fred Bloggs )? " @@ -408,31 +342,42 @@ if str == "Other" then longPrompt else return str - askForAuthor askfn1 askfn2 = do - aminrepo <- doesDirectoryExist (darcsdir++"/prefs") + askForAuthor storeGlobal askfn1 askfn2 = do + aminrepo <- doesDirectoryExist (darcsdir "prefs") if aminrepo && store then do + prefsdir <- if storeGlobal + then tryGlobalPrefsDir + else return $ darcsdir "prefs" putDocLn $ text "Each patch is attributed to its author, usually by email address (for" $$ text "example, `Fred Bloggs '). Darcs could not determine" $$ text "your email address, so you will be prompted for it." $$ text "" $$ - text ("Your address will be stored in " ++ globalPrefsDirDoc ++ "author") $$ - text "It will be used for all patches you record in ALL repositories." $$ - text ("If you move that file to " ++ darcsdir "prefs" "author, it will") $$ - text "be used for patches recorded in this repository only." + text ("Your address will be stored in " ++ prefsdir) + if prefsdir /= darcsdir "prefs" then + putDocLn $ + text "It will be used for all patches you record in ALL repositories." $$ + text ("If you move that file to " ++ darcsdir "prefs" "author" ++ ", it will") $$ + text "be used for patches recorded in this repository only." + else + putDocLn $ + text "It will be used for all patches you record in this repository only." $$ + text ("If you move that file to " ++ globalPrefsDirDoc ++ "author, it will") $$ + text "be used for all patches recorded in ALL repositories." add <- askfn1 - maybeprefsdir <- globalPrefsDir - prefsdir <- case maybeprefsdir of - Nothing -> do - putStrLn "WARNING: Global preference directory could not be found." - return $ darcsdir "prefs" - Just dir -> do exists <- doesDirectoryExist dir - unless exists $ createDirectory dir - return dir - writeLocaleFile (prefsdir "author") $ + writeTextFile (prefsdir "author") $ unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add return add else askfn2 + tryGlobalPrefsDir = do + maybeprefsdir <- globalPrefsDir + case maybeprefsdir of + Nothing -> do + putStrLn "WARNING: Global preference directory could not be found." + return $ darcsdir "prefs" + Just dir -> do exists <- doesDirectoryExist dir + unless exists $ createDirectory dir + return dir -- | 'getEasyAuthor' tries to get the author name first from the repository preferences, -- then from global preferences, then from environment variables. Returns @[]@ @@ -442,9 +387,9 @@ getEasyAuthor = firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist "author" , nonblank `fmap` getGlobal "author" - , maybeToList `fmap` maybeGetEnv "DARCS_EMAIL" - , maybeToList `fmap` maybeGetEnv "EMAIL" - ] >>= mapM decodeString + , maybeToList `fmap` lookupEnv "DARCS_EMAIL" + , maybeToList `fmap` lookupEnv "EMAIL" + ] where nonblank = filter (not . null) -- this could perhaps be simplified with Control.Monad @@ -481,7 +426,7 @@ getSendmailCmd :: Config -> IO String getSendmailCmd fs = case parseFlags O.sendmailCmd fs of Just cmd -> return cmd - Nothing -> fmap (maybe "" id) $ firstJustIO [ maybeGetEnv "SENDMAIL" ] + Nothing -> fmap (maybe "" id) $ lookupEnv "SENDMAIL" -- | Accessor for output option getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd @@ -489,9 +434,6 @@ go (O.Output ap) = ap go (O.OutputAutoName ap) = makeAbsoluteOrStd ap fp -getCharset :: Config -> Maybe String -getCharset = parseFlags O.charset - -- |'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. @@ -509,33 +451,8 @@ getInReplyTo :: Config -> Maybe String getInReplyTo = O._inReplyTo . parseFlags O.headerFields -getReply :: Config -> Maybe String -getReply = parseFlags O.reply - --- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags. -siblings :: Config -> [AbsolutePath] -siblings = parseFlags O.siblings - -useIndex :: Config -> O.UseIndex -useIndex = parseFlags O.useIndex - -hasSummary :: O.Summary -> Config -> O.Summary -hasSummary def = maybe def id . parseFlags O.summary - -hasXmlOutput :: Config -> O.XmlOutput -hasXmlOutput = parseFlags O.xmloutput - -selectDeps :: Config -> O.SelectDeps -selectDeps = parseFlags O.selectDeps +hasXmlOutput :: Config -> Bool +hasXmlOutput = (== O.YesXml) . parseFlags O.xmlOutput hasLogfile :: Config -> Maybe AbsolutePath hasLogfile = O._logfile . parseFlags O.logfile - -hasAuthor :: Config -> Maybe String -hasAuthor = parseFlags O.author - -patchFormat :: Config -> O.PatchFormat -patchFormat = parseFlags O.patchFormat - -applyAs :: Config -> Maybe String -applyAs = parseFlags O.applyAs diff --git a/src/Darcs/UI/Message/Send.hs b/src/Darcs/UI/Message/Send.hs deleted file mode 100644 --- a/src/Darcs/UI/Message/Send.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- Copyright (C) 2002-2004 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# LANGUAGE CPP, TypeOperators #-} - --- | Help text and UI messages for @darcs send@ -module Darcs.UI.Message.Send where - -import Prelude () -import Darcs.Prelude - -import Darcs.Util.Path ( FilePathLike(..), toFilePath ) -import Darcs.Repository.Flags ( DryRun(..) ) -import Darcs.Util.Text ( sentence, quote ) -import Darcs.Util.Printer - -cmdDescription :: String -cmdDescription = - "Prepare a bundle of patches to be applied to some target repository." - -cmdHelp :: String -cmdHelp = unlines - [ "Send is used to prepare a bundle of patches that can be applied to a target" - , "repository. Send accepts the URL of the repository as an argument. When" - , "called without an argument, send will use the most recent repository that" - , "was either pushed to, pulled from or sent to. By default, the patch bundle" - , "is saved to a file, although you may directly send it by mail." - , "" - , "The `--output`, `--output-auto-name`, and `--to` flags determine" - , "what darcs does with the patch bundle after creating it. If you provide an" - , "`--output` argument, the patch bundle is saved to that file. If you" - , "specify `--output-auto-name`, the patch bundle is saved to a file with an" - , "automatically generated name. If you give one or more `--to` arguments," - , "the bundle of patches is sent to those locations. The locations may either" - , "be email addresses or urls that the patch should be submitted to via HTTP." - , "" - , "If you provide the `--mail` flag, darcs will look at the contents" - , "of the `_darcs/prefs/email` file in the target repository (if it exists)," - , "and send the patch by email to that address. In this case, you may use" - , "the `--cc` option to specify additional recipients without overriding the" - , "default repository email address." - , "" - , "If `_darcs/prefs/post` exists in the target repository, darcs will" - , "upload to the URL contained in that file, which may either be a" - , "`mailto:` URL, or an `http://` URL. In the latter case, the" - , "patch is posted to that URL." - , "" - , "If there is no email address associated with the repository, darcs will" - , "prompt you for an email address." - , "" - , "Use the `--subject` flag to set the subject of the e-mail to be sent." - , "If you don't provide a subject on the command line, darcs will make one up" - , "based on names of the patches in the patch bundle." - , "" - , "Use the `--in-reply-to` flag to set the In-Reply-To and References headers" - , "of the e-mail to be sent. By default no additional headers are included so" - , "e-mail will not be treated as reply by mail readers." - , "" - , "If you want to include a description or explanation along with the bundle" - , "of patches, you need to specify the `--edit-description` flag, which" - , "will cause darcs to open up an editor with which you can compose a message" - , "to go along with your patches." - , "" - , "If you want to use a command different from the default one for sending" - , "email, you need to specify a command line with the `--sendmail-command`" - , "option. The command line can contain some format specifiers which are" - , "replaced by the actual values. Accepted format specifiers are `%s` for" - , "subject, `%t` for to, `%c` for cc, `%b` for the body of the mail, `%f` for" - , "from, `%a` for the patch bundle and the same specifiers in uppercase for the" - , "URL-encoded values." - , "Additionally you can add `%<` to the end of the command line if the command" - , "expects the complete email message on standard input. E.g. the command lines" - , "for evolution and msmtp look like this:" - , "" - , " evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\"" - , " msmtp -t %<" - , "" - , "Do not confuse the `--author` options with the return address" - , "that `darcs send` will set for your patch bundle." - , "" - , "For example, if you have two email addresses A and B:" - , "" - , "* If you use `--author A` but your machine is configured to send mail from" - , " address B by default, then the return address on your message will be B." - , "* If you use `--from A` and your mail client supports setting the" - , " From: address arbitrarily (some non-Unix-like mail clients, especially," - , " may not support this), then the return address will be A; if it does" - , " not support this, then the return address will be B." - , "* If you supply neither `--from` nor `--author` then the return" - , " address will be B." - , "" - , "In addition, unless you specify the sendmail command with" - , "`--sendmail-command`, darcs sends email using the default email" - , "command on your computer. This default command is determined by the" - , "`configure` script. Thus, on some non-Unix-like OSes," - , "`--from` is likely to not work at all." - ] - -cannotSendToSelf :: String -cannotSendToSelf = "Can't send to current repository! Did you mean send --context?" - -creatingPatch :: String -> Doc -creatingPatch repodir = "Creating patch to" <+> text (quote repodir) <> "..." - -noWorkingSendmail :: Doc -noWorkingSendmail = "No working sendmail instance on your machine!" - -nothingSendable :: Doc -nothingSendable = "No recorded local changes to send!" - -selectionIs :: [Doc] -> Doc -selectionIs descs = text "We have the following patches to send:" $$ vcat descs - -selectionIsNull :: Doc -selectionIsNull = text "You don't want to send any patches, and that's fine with me!" - -emailBackedUp :: String -> Doc -emailBackedUp mf = sentence $ "Email body left in" <+> text mf - -promptCharSetWarning :: String -> String -promptCharSetWarning msg = "Warning: " ++ msg ++ " Send anyway?" - -charsetAborted :: Doc -charsetAborted = "Aborted. You can specify charset with the --charset option." - -charsetCouldNotGuess :: String -charsetCouldNotGuess = "darcs could not guess the charset of your mail." - -currentEncodingIs :: String -> String -currentEncodingIs e = "Current locale encoding: " ++ e - -charsetUtf8MailDiffLocale :: String -charsetUtf8MailDiffLocale = "your mail is valid UTF-8 but your locale differs." - -aborted :: Doc -aborted = "Aborted." - -success :: String -> String -> Doc -success to cc = sentence $ - "Successfully sent patch bundle to:" <+> text to <+> copies cc - where - copies "" = "" - copies x = "and cc'ed" <+> text x - -postingPatch :: String -> Doc -postingPatch url = "Posting patch to" <+> text url - -wroteBundle :: FilePathLike a => a -> Doc -wroteBundle a = sentence $ "Wrote patch to" <+> text (toFilePath a) - -savedButNotSent :: String -> Doc -savedButNotSent to = - text ("The usual recipent for this bundle is: " ++ to) - $$ text "To send it automatically, make sure sendmail is working," - <+> text "and add 'send mail' to _darcs/prefs/defaults or" - <+> text " ~/.darcs/defaults" - -willSendTo :: DryRun -> [String] -> Doc -willSendTo dr addresses = - "Patch bundle" <+> will <+> " be sent to:" <+> text (unwords addresses) - where - will = case dr of { YesDryRun -> "would"; NoDryRun -> "will" } - -promptTarget :: String -promptTarget = "What is the target email address? " - -aboutToEdit :: FilePath -> String -aboutToEdit file = "About to edit file " ++ file - -promptNoDescriptionChange :: String -promptNoDescriptionChange = "File content did not change. Continue anyway?" diff --git a/src/Darcs/UI/Options.hs b/src/Darcs/UI/Options.hs --- a/src/Darcs/UI/Options.hs +++ b/src/Darcs/UI/Options.hs @@ -1,6 +1,5 @@ module Darcs.UI.Options ( module Darcs.UI.Options.Core - , module Darcs.UI.Options.Markdown , DarcsOption , PrimDarcsOption , DarcsOptDescr @@ -10,22 +9,14 @@ import Prelude () import Darcs.Prelude -import Data.Functor.Compose -import System.Console.GetOpt +import Data.Functor.Compose ( getCompose ) +import System.Console.GetOpt ( OptDescr ) -import Darcs.UI.Options.All +import Darcs.UI.Options.All ( DarcsOption ) import Darcs.UI.Options.Core -import Darcs.UI.Options.Markdown import Darcs.UI.Options.Util ( DarcsOptDescr, PrimDarcsOption ) import Darcs.Util.Path ( AbsolutePath ) --- * Type instantiations - --- | The @instance Functor OptDescr@ was introduced only in base-4.7.0.0, which is --- why we implement it here manually. +-- | Instantiate a 'DarcsOptDescr' with an 'AbsolutePath' optDescr :: AbsolutePath -> DarcsOptDescr f -> OptDescr f -optDescr path = omap ($path) . getCompose where - omap f (Option s l a h) = Option s l (amap f a) h - amap f (NoArg a) = NoArg (f a) - amap f (ReqArg mkF n) = ReqArg (fmap f mkF) n - amap f (OptArg mkF n) = OptArg (fmap f mkF) n +optDescr path = fmap ($ path) . getCompose diff --git a/src/Darcs/UI/Options/All.hs b/src/Darcs/UI/Options/All.hs --- a/src/Darcs/UI/Options/All.hs +++ b/src/Darcs/UI/Options/All.hs @@ -28,6 +28,9 @@ module Darcs.UI.Options.All ( DarcsOption + -- conversion to 'Bool' + , YesNo (..) + -- root , RootAction (..) , rootActions @@ -40,6 +43,8 @@ , verbosity , timings , anyVerbosity + , HooksConfig (..) -- re-export + , HookConfig (..) -- re-export , preHook , postHook , hooks @@ -48,7 +53,7 @@ -- interactivity , XmlOutput (..) - , xmloutput + , xmlOutput , DryRun (..) -- re-export , dryRun , dryRunXml @@ -56,23 +61,24 @@ , pipe , WantGuiPause (..) -- re-export , pauseForGui - , askdeps + , askDeps -- patch selection , module Darcs.UI.Options.Matching -- re-export , SelectDeps (..) , selectDeps , changesReverse - , matchMaxcount + , maxCount -- local or remote repo(s) , WorkRepo (..) -- re-export , workRepo - , workingRepoDir + , repoDir , RemoteRepos (..) -- re-export , remoteRepos , possiblyRemoteRepo , reponame + , NotInRemote (..) , notInRemote , notInRemoteFlagName , RepoCombinator (..) @@ -80,7 +86,7 @@ , allowUnrelatedRepos , justThisRepo , WithWorkingDir (..) -- re-export - , useWorkingDir + , withWorkingDir , SetDefault (..) -- re-export , setDefault @@ -99,11 +105,13 @@ , LookForMoves (..) -- re-export , LookForReplaces (..) -- re-export , lookfor + , lookforadds + , lookforreplaces + , lookformoves -- files to consider , UseIndex (..) -- re-export , ScanKnown (..) -- re-export - , diffing , IncludeBoring (..) , includeBoring , allowProblematicFilenames @@ -118,7 +126,6 @@ , diffAlgorithm , WithContext (..) , withContext - , unidiff , ExternalDiff (..) , extDiff @@ -126,7 +133,7 @@ , TestChanges (..) , testChanges , RunTest (..) -- re-export - , test + , runTest , LeaveTestDir (..) -- re-export , leaveTestDir @@ -151,16 +158,17 @@ -- merging patches , AllowConflicts (..) -- re-export - , conflicts + , conflictsNo + , conflictsYes , ExternalMerge (..) -- re-export - , useExternalMerge + , externalMerge -- optimizations , Compression (..) -- re-export , compress , usePacks , WithPatchIndex (..) -- re-export - , patchIndex + , patchIndexNo , patchIndexYes , Reorder (..) -- re-export , reorder @@ -172,6 +180,7 @@ , output , Summary (..) , summary + , maybeSummary , RemoteDarcs (..) -- re-export , NetworkOptions (..) , network @@ -188,12 +197,11 @@ , selectAuthor -- annotate - , humanReadable , machineReadable -- clone , CloneKind (..) - , partial + , cloneKind -- dist , distname @@ -225,13 +233,16 @@ , pending , nullFlag + -- show repo + , EnumPatches (..) + , enumPatches + -- gzcrcs , GzcrcsAction (..) , gzcrcsActions -- optimize , siblings - , reorderPatches , optimizePatchIndex ) where @@ -241,7 +252,6 @@ import Prelude hiding ( (^) ) import Data.Char ( isDigit ) import Data.List ( intercalate ) -import Data.Maybe ( listToMaybe ) import Darcs.Repository.Flags ( Compression (..) @@ -271,6 +281,8 @@ , WithWorkingDir (..) , PatchFormat (..) , IncludeBoring (..) + , HooksConfig (..) + , HookConfig (..) ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) ) @@ -288,6 +300,79 @@ type RawDarcsOption = forall v. v -> RawOptSpec Flag v +-- * Conversion to 'Bool' + +class YesNo a where + yes :: a -> Bool + no :: a -> Bool + no = not . yes + +instance YesNo Compression where + yes NoCompression = False + yes GzipCompression = True + +instance YesNo WithPatchIndex where + yes NoPatchIndex = False + yes YesPatchIndex = True + +instance YesNo Reorder where + yes NoReorder = False + yes Reorder = True + +instance YesNo UseCache where + yes NoUseCache = False + yes YesUseCache = True + +instance YesNo DryRun where + yes NoDryRun = False + yes YesDryRun = True + +instance YesNo LookForAdds where + yes NoLookForAdds = False + yes YesLookForAdds = True + +instance YesNo LookForReplaces where + yes NoLookForReplaces = False + yes YesLookForReplaces = True + +instance YesNo LookForMoves where + yes NoLookForMoves = False + yes YesLookForMoves = True + +instance YesNo IncludeBoring where + yes NoIncludeBoring = False + yes YesIncludeBoring = True + +instance YesNo RunTest where + yes NoRunTest = False + yes YesRunTest = True + +instance YesNo SetScriptsExecutable where + yes NoSetScriptsExecutable = False + yes YesSetScriptsExecutable = True + +instance YesNo LeaveTestDir where + yes NoLeaveTestDir = False + yes YesLeaveTestDir = True + +instance YesNo UseIndex where + yes IgnoreIndex = False + yes UseIndex = True + +instance YesNo WantGuiPause where + yes NoWantGuiPause = False + yes YesWantGuiPause = True + +instance YesNo WithWorkingDir where + yes NoWorkingDir = False + yes WithWorkingDir = True + +data EnumPatches = NoEnumPatches | YesEnumPatches deriving (Eq, Show) + +instance YesNo EnumPatches where + yes NoEnumPatches = False + yes YesEnumPatches = True + -- * Root command -- | Options for darcs iself that act like sub-commands. @@ -295,13 +380,13 @@ rootActions :: PrimDarcsOption (Maybe RootAction) rootActions = withDefault Nothing - [ RawNoArg ['h'] ["help", "overview"] F.Help (Just RootHelp) + [ RawNoArg ['h'] ["help"] F.Help (Just RootHelp) "show a brief description of all darcs commands and top-level options" - , RawNoArg ['v'] ["version"] F.Version (Just Version) "show the darcs version" + , RawNoArg ['v','V'] ["version"] F.Version (Just Version) "show the darcs version" , RawNoArg [] ["exact-version"] F.ExactVersion (Just ExactVersion) "show the exact darcs version" -- the switch --commands is here for compatibility only - , RawNoArg [] ["commands","list-options"] F.ListCommands (Just ListCommands) + , RawNoArg [] ["commands"] F.ListCommands (Just ListCommands) "show plain list of available options and commands, for auto-completion" ] @@ -342,15 +427,22 @@ -- ** Hooks -hooks :: DarcsOption a (Maybe String -> Bool -> Maybe String -> Bool -> a) -hooks = preHook ^ postHook +hooks :: DarcsOption a (HooksConfig -> a) +hooks = imap (Iso fw bw) $ preHook ^ postHook where + fw k (HooksConfig pr po) = k pr po + bw k pr po = k (HooksConfig pr po) -preHook :: DarcsOption a (Maybe String -> Bool -> a) -preHook = prehookCmd ^ hookPrompt "prehook" F.AskPrehook F.RunPrehook +hookIso :: Iso (Maybe String -> Bool -> a) (HookConfig -> a) +hookIso = (Iso fw bw) where + fw k (HookConfig c p) = k c p + bw k c p = k (HookConfig c p) -postHook :: DarcsOption a (Maybe String -> Bool -> a) -postHook = posthookCmd ^ hookPrompt "posthook" F.AskPosthook F.RunPosthook +preHook :: DarcsOption a (HookConfig -> a) +preHook = imap hookIso $ prehookCmd ^ hookPrompt "prehook" F.AskPrehook F.RunPrehook +postHook :: DarcsOption a (HookConfig -> a) +postHook = imap hookIso $ posthookCmd ^ hookPrompt "posthook" F.AskPosthook F.RunPosthook + prehookCmd :: PrimDarcsOption (Maybe String) prehookCmd = withDefault Nothing [ RawStrArg [] ["prehook"] F.PrehookCmd unF Just unV @@ -397,30 +489,27 @@ data XmlOutput = NoXml | YesXml deriving (Eq, Show) -xmloutput :: PrimDarcsOption XmlOutput -xmloutput = withDefault NoXml [__xmloutput YesXml] +instance YesNo XmlOutput where + yes NoXml = False + yes YesXml = True +xmlOutput :: PrimDarcsOption XmlOutput +xmlOutput = withDefault NoXml [__xmloutput YesXml] + __xmloutput :: RawDarcsOption __xmloutput val = RawNoArg [] ["xml-output"] F.XMLOutput val "generate XML formatted output" --- | 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. --- --- See also issue2397. +-- | TODO someone wrote here long ago that any time --dry-run is a possibility +-- automated users should be able to examine the results more +-- easily with --xml. See also issue2397. +-- dryRun w/o xml is currently used in add, pull, and repair. + dryRun :: PrimDarcsOption DryRun -dryRun = (imap . cps) (Iso fw bw) $ singleNoArg [] ["dry-run"] F.DryRun "don't actually take the action" - where - fw True = YesDryRun - fw False = NoDryRun - bw YesDryRun = True - bw NoDryRun = False +dryRun = withDefault NoDryRun + [ RawNoArg [] ["dry-run"] F.DryRun YesDryRun "don't actually take the action" ] dryRunXml :: DarcsOption a (DryRun -> XmlOutput -> a) -dryRunXml = dryRun ^ xmloutput - -__dryrun :: RawDarcsOption -__dryrun val = RawNoArg [] ["dry-run"] F.DryRun val "don't actually take the action" +dryRunXml = dryRun ^ xmlOutput pipe :: PrimDarcsOption Bool pipe = singleNoArg [] ["pipe"] F.Pipe "ask user interactively for the patch metadata" @@ -437,8 +526,8 @@ , RawNoArg [] ["no-pause-for-gui"] F.NoPauseForGui NoWantGuiPause "return immediately after external diff or merge command finishes" ] -askdeps :: PrimDarcsOption Bool -askdeps = withDefault False +askDeps :: PrimDarcsOption Bool +askDeps = withDefault False [ RawNoArg [] ["ask-deps"] F.AskDeps True "manually select dependencies" , RawNoArg [] ["no-ask-deps"] F.NoAskDeps False "automatically select dependencies" ] @@ -465,22 +554,28 @@ -- should take either a plain 'String' argument (leaving it to a later stage -- to parse the 'String' to an 'Int'), or else a @'Maybe' 'Int'@, taking -- the possibility of a failed parse into account. -matchMaxcount :: PrimDarcsOption (Maybe Int) -matchMaxcount = OptSpec {..} where - ounparse k (Just n) = k [ F.MaxCount n ] - ounparse k Nothing = k [] - oparse k fs = k $ listToMaybe [ s | F.MaxCount s <- fs ] - ocheck fs = case [ "--max-count="++show n | F.MaxCount n <- fs ] of - cfs@(_:_:_) -> ["conflicting flags: " ++ intercalate ", " cfs] - _ -> [] - odesc = [ strArg [] ["max-count"] (F.MaxCount . toInt) "NUMBER" - "return only NUMBER results" ] - toInt s = if not (null s) && all isDigit s then read s else (-1) +maxCount :: PrimDarcsOption (Maybe Int) +maxCount = (withDefault Nothing + [ RawStrArg [] ["max-count"] F.MaxCount unF toV unV "NUMBER" + "return only NUMBER results" ]) + {ocheck=check} + where + unF f = [ s | F.MaxCount s <- [f] ] + unV x = [ show s | Just s <- [x] ] + toV s = if good s then Just (read s) else Nothing + check fs = + [ "invalid argument to --max-count: '"++s++"'" | s <- args, not (good s) ] ++ + if length args > 1 + then ["conflicting flags: " ++ intercalate ", " (map ("--max-count="++) args)] + else [] + where + args = [ s | F.MaxCount s <- fs ] + good s = not (null s) && all isDigit s -- * Local or remote repo workRepo :: PrimDarcsOption WorkRepo -workRepo = imap (Iso fw bw) $ workingRepoDir ^ possiblyRemoteRepo where +workRepo = imap (Iso fw bw) $ repoDir ^ possiblyRemoteRepo where fw k (WorkRepoDir s) = k (Just s) Nothing fw k (WorkRepoPossibleURL s) = k Nothing (Just s) fw k WorkRepoCurrentDir = k Nothing Nothing @@ -488,8 +583,8 @@ bw k Nothing (Just s) = k (WorkRepoPossibleURL s) bw k Nothing Nothing = k WorkRepoCurrentDir -workingRepoDir :: PrimDarcsOption (Maybe String) -workingRepoDir = singleStrArg [] ["repodir"] F.WorkRepoDir arg "DIRECTORY" +repoDir :: PrimDarcsOption (Maybe String) +repoDir = singleStrArg [] ["repodir"] F.WorkRepoDir arg "DIRECTORY" "specify the repository directory in which to run" where arg (F.WorkRepoDir s) = Just s arg _ = Nothing @@ -518,13 +613,21 @@ notInRemoteFlagName :: String notInRemoteFlagName = "not-in-remote" -notInRemote :: PrimDarcsOption [Maybe String] -notInRemote = +data NotInRemote + = NotInDefaultRepo + | NotInRemotePath String + +notInRemote :: PrimDarcsOption [NotInRemote] +notInRemote = (imap . cps) (Iso (map fw) (map bw)) $ multiOptStrArg [] [notInRemoteFlagName] F.NotInRemote args "URL/PATH" $ "select all patches not in the default push/pull repository or at " ++ "location URL/PATH" where args fs = [s | F.NotInRemote s <- fs] + fw (Just s) = NotInRemotePath s + fw Nothing = NotInDefaultRepo + bw (NotInRemotePath s) = Just s + bw NotInDefaultRepo = Nothing data RepoCombinator = Intersection | Union | Complement deriving (Eq, Show) @@ -546,8 +649,8 @@ "Limit the check or repair to the current repo" -- | convert, clone, init -useWorkingDir :: PrimDarcsOption WithWorkingDir -useWorkingDir = withDefault WithWorkingDir +withWorkingDir :: PrimDarcsOption WithWorkingDir +withWorkingDir = withDefault WithWorkingDir [ RawNoArg [] ["with-working-dir"] F.UseWorkingDir WithWorkingDir "Create a working directory (normal repository)" , RawNoArg [] ["no-working-dir"] F.UseNoWorkingDir NoWorkingDir @@ -625,12 +728,12 @@ } lookfor :: PrimDarcsOption LookFor -lookfor = imap (Iso fw bw) (lookforadds ^ lookforreplaces ^ lookformoves) where +lookfor = imap (Iso fw bw) (lookforadds NoLookForAdds ^ lookforreplaces ^ lookformoves) where fw k (LookFor a r m) = k a r m bw k a r m = k (LookFor a r m) -lookforadds :: PrimDarcsOption LookForAdds -lookforadds = withDefault NoLookForAdds +lookforadds :: LookForAdds -> PrimDarcsOption LookForAdds +lookforadds def = withDefault def [ RawNoArg ['l'] ["look-for-adds"] F.LookForAdds YesLookForAdds "look for (non-boring) files that could be added" , RawNoArg [] ["dont-look-for-adds","no-look-for-adds"] F.NoLookForAdds NoLookForAdds @@ -654,12 +757,6 @@ -- * Files to consider -diffing :: PrimDarcsOption (UseIndex, ScanKnown, DiffAlgorithm) -diffing = imap (Iso curry3 uncurry3) $ useIndex ^ scanKnown ^ diffAlgorithm - where - uncurry3 k x y z = k (x,y,z) - curry3 k (x,y,z) = k x y z - useIndex :: PrimDarcsOption UseIndex useIndex = (imap . cps) (Iso fw bw) ignoreTimes where fw False = UseIndex @@ -667,15 +764,6 @@ bw UseIndex = False bw IgnoreIndex = True -scanKnown :: PrimDarcsOption ScanKnown -scanKnown = imap (Iso fw bw) $ lookforadds ^ includeBoring where - fw k ScanKnown = k NoLookForAdds NoIncludeBoring - fw k ScanAll = k YesLookForAdds NoIncludeBoring - fw k ScanBoring = k YesLookForAdds YesIncludeBoring - bw k NoLookForAdds _ = k ScanKnown - bw k YesLookForAdds NoIncludeBoring = k ScanAll - bw k YesLookForAdds YesIncludeBoring = k ScanBoring - includeBoring :: PrimDarcsOption IncludeBoring includeBoring = withDefault NoIncludeBoring [ RawNoArg [] ["boring"] F.Boring YesIncludeBoring "don't skip boring files" @@ -729,6 +817,10 @@ data WithContext = NoContext | YesContext deriving (Eq, Show) +instance YesNo WithContext where + yes NoContext = False + yes YesContext = True + withContext :: PrimDarcsOption WithContext withContext = (imap . cps) (Iso fw bw) $ withDefault False [ RawNoArg ['u'] ["unified"] F.Unified True @@ -740,42 +832,46 @@ bw NoContext = False bw YesContext = True -unidiff :: PrimDarcsOption Bool -unidiff = withDefault True - [ RawNoArg ['u'] ["unified"] F.Unified True "pass -u option to diff" - , RawNoArg [] ["no-unified"] F.NonUnified False "output patch in diff's dumb format" ] - -data ExternalDiff = ExternalDiff { _diffCmd :: Maybe String, _diffOpts :: [String] } deriving (Eq, Show) +data ExternalDiff = ExternalDiff + { diffCmd :: Maybe String + , diffOpts :: [String] + , diffUnified :: Bool + } deriving (Eq, Show) extDiff :: PrimDarcsOption ExternalDiff -extDiff = imap (Iso fw bw) $ extDiffCmd ^ extDiffOpts where - fw k (ExternalDiff cmd opts) = k cmd opts - bw k cmd opts = k (ExternalDiff cmd opts) +extDiff = imap (Iso fw bw) $ __extDiffCmd ^ __extDiffOpts ^ __unidiff where + fw k (ExternalDiff cmd opts uni) = k cmd opts uni + bw k cmd opts uni = k (ExternalDiff cmd opts uni) -extDiffCmd :: PrimDarcsOption (Maybe String) -extDiffCmd = singleStrArg [] ["diff-command"] F.DiffCmd arg "COMMAND" +__extDiffCmd :: PrimDarcsOption (Maybe String) +__extDiffCmd = singleStrArg [] ["diff-command"] F.DiffCmd arg "COMMAND" "specify diff command (ignores --diff-opts)" where arg (F.DiffCmd s) = Just s arg _ = Nothing -extDiffOpts :: PrimDarcsOption [String] -extDiffOpts = multiStrArg [] ["diff-opts"] F.DiffFlags mkV "OPTIONS" +__extDiffOpts :: PrimDarcsOption [String] +__extDiffOpts = multiStrArg [] ["diff-opts"] F.DiffFlags mkV "OPTIONS" "options to pass to diff" where mkV fs = [ s | F.DiffFlags s <- fs ] +__unidiff :: PrimDarcsOption Bool +__unidiff = withDefault True + [ RawNoArg ['u'] ["unified"] F.Unified True "pass -u option to diff" + , RawNoArg [] ["no-unified"] F.NonUnified False "output patch in diff's dumb format" ] + -- * Runnign tests data TestChanges = NoTestChanges | YesTestChanges LeaveTestDir deriving (Eq) testChanges :: PrimDarcsOption TestChanges -testChanges = imap (Iso fw bw) $ test ^ leaveTestDir where +testChanges = imap (Iso fw bw) $ runTest ^ leaveTestDir where fw k NoTestChanges = k NoRunTest {- undefined -} YesLeaveTestDir fw k (YesTestChanges ltd) = k YesRunTest ltd bw k NoRunTest _ = k NoTestChanges bw k YesRunTest ltd = k (YesTestChanges ltd) -test :: PrimDarcsOption RunTest -test = withDefault NoRunTest +runTest :: PrimDarcsOption RunTest +runTest = withDefault NoRunTest [ RawNoArg [] ["test"] F.Test YesRunTest "run the test script" , RawNoArg [] ["no-test"] F.NoTest NoRunTest "don't run the test script" ] @@ -805,8 +901,8 @@ arg _ = Nothing to :: PrimDarcsOption [String] -to = multiStrArg [] ["to"] F.Target mkV "EMAIL" "specify destination email" - where mkV fs = [ s | F.Target s <- fs ] +to = multiStrArg [] ["to"] F.To mkV "EMAIL" "specify destination email" + where mkV fs = [ s | F.To s <- fs ] cc :: PrimDarcsOption [String] cc = multiStrArg [] ["cc"] F.Cc mkV "EMAIL" "mail results to additional EMAIL(s)" @@ -937,25 +1033,28 @@ -- * Merging patches --- applyConflictOptions = conflicts NoAllowConflicts --- pullConflictOptions = conflicts YesAllowConflictsAndMark +-- | push, apply, rebase apply: default to 'NoAllowConflicts' +conflictsNo :: PrimDarcsOption (Maybe AllowConflicts) +conflictsNo = conflicts NoAllowConflicts +-- | pull, rebase pull: default to 'YesAllowConflictsAndMark' +conflictsYes :: PrimDarcsOption (Maybe AllowConflicts) +conflictsYes = conflicts YesAllowConflictsAndMark + conflicts :: AllowConflicts -> PrimDarcsOption (Maybe AllowConflicts) conflicts def = withDefault (Just def) [ RawNoArg [] ["mark-conflicts"] F.MarkConflicts (Just YesAllowConflictsAndMark) "mark conflicts" , RawNoArg [] ["allow-conflicts"] F.AllowConflicts (Just YesAllowConflicts) "allow conflicts, but don't mark them" --- , RawNoArg [] ["no-resolve-conflicts"] --- NoAllowConflicts "equivalent to --dont-allow-conflicts, for backwards compatibility" , RawNoArg [] ["dont-allow-conflicts","no-allow-conflicts","no-resolve-conflicts"] F.NoAllowConflicts (Just NoAllowConflicts) "fail if there are patches that would create conflicts" , RawNoArg [] ["skip-conflicts"] F.SkipConflicts Nothing "filter out any patches that would create conflicts" ] -- Technically not an isomorphism, see 'sendmailIso'. -useExternalMerge :: PrimDarcsOption ExternalMerge -useExternalMerge = imap (Iso fw bw) $ singleStrArg [] ["external-merge"] F.ExternalMerge arg +externalMerge :: PrimDarcsOption ExternalMerge +externalMerge = imap (Iso fw bw) $ singleStrArg [] ["external-merge"] F.ExternalMerge arg "COMMAND" "use external tool to merge conflicts" where arg (F.ExternalMerge s) = Just s @@ -978,8 +1077,8 @@ , RawNoArg [] ["no-packs"] F.NoPacks False "don't use repository packs" ] -- for init, clone and convert: patch index disabled by default -patchIndex :: PrimDarcsOption WithPatchIndex -patchIndex = withDefault NoPatchIndex [__patchIndex YesPatchIndex, __noPatchIndex NoPatchIndex] +patchIndexNo :: PrimDarcsOption WithPatchIndex +patchIndexNo = withDefault NoPatchIndex [__patchIndex YesPatchIndex, __noPatchIndex NoPatchIndex] -- for log and annotate: patch index enabled by default patchIndexYes :: PrimDarcsOption WithPatchIndex @@ -1025,8 +1124,23 @@ data Summary = NoSummary | YesSummary deriving (Eq, Show) -summary :: PrimDarcsOption (Maybe Summary) -summary = withDefault Nothing +instance YesNo Summary where + yes NoSummary = False + yes YesSummary = True + +-- all commands except whatsnew +summary :: PrimDarcsOption Summary +summary = (imap . cps) (Iso fw bw) $ maybeSummary Nothing + where + fw Nothing = NoSummary + fw (Just NoSummary) = NoSummary + fw (Just YesSummary) = YesSummary + bw NoSummary = Nothing + bw YesSummary = Just YesSummary + +-- needed for whatsnew +maybeSummary :: Maybe Summary -> PrimDarcsOption (Maybe Summary) +maybeSummary def = withDefault def [ RawNoArg ['s'] ["summary"] F.Summary (Just YesSummary) "summarize changes" , RawNoArg [] ["no-summary"] F.NoSummary (Just NoSummary) "don't summarize changes" ] @@ -1091,24 +1205,21 @@ -- ** annotate --- | TODO: These should be mutually exclusive, but are they? The code is almost inscrutable. -humanReadable :: PrimDarcsOption Bool -humanReadable = withDefault False [__humanReadable True] +machineReadable :: PrimDarcsOption Bool +machineReadable = withDefault False + [ __humanReadable False + , __machineReadable True ] __humanReadable :: RawDarcsOption __humanReadable val = RawNoArg [] ["human-readable"] F.HumanReadable val "give human-readable output" --- | See above. -machineReadable :: PrimDarcsOption Bool -machineReadable = withDefault False [__machineReadable True] - __machineReadable :: RawDarcsOption __machineReadable val = RawNoArg [] ["machine-readable"] F.MachineReadable val "give machine-readable output" -- ** clone -partial :: PrimDarcsOption CloneKind -partial = withDefault NormalClone +cloneKind :: PrimDarcsOption CloneKind +cloneKind = withDefault NormalClone [ RawNoArg [] ["lazy"] F.Lazy LazyClone "get patch files only as needed" , RawNoArg [] ["complete"] F.Complete CompleteClone "get a complete copy of the repository" ] @@ -1155,11 +1266,18 @@ -- ** log -data ChangesFormat = HumanReadable | MachineReadable | GenContext | GenXml | NumberPatches | CountPatches deriving (Eq, Show) +data ChangesFormat + = HumanReadable + | MachineReadable + | GenContext + | GenXml + | NumberPatches + | CountPatches + deriving (Eq, Show) changesFormat :: PrimDarcsOption (Maybe ChangesFormat) changesFormat = withDefault Nothing - [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "give output suitable for get --context" + [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "give output suitable for clone --context" , __xmloutput (Just GenXml) , __humanReadable (Just HumanReadable) , __machineReadable (Just MachineReadable) @@ -1191,7 +1309,7 @@ , RawNoArg [] ["backoff"] F.Backoff Backoff "exponential backoff search" , RawNoArg [] ["bisect"] F.Bisect Bisect "binary instead of linear search" ] --- ** show files/index +-- ** show files files :: PrimDarcsOption Bool files = withDefault True @@ -1206,12 +1324,21 @@ pending :: PrimDarcsOption Bool pending = withDefault True [ RawNoArg [] ["pending"] F.Pending True "reflect pending patches in output" - , RawNoArg [] ["no-pending"] F.NoPending False "only included recorded patches in output" ] + , RawNoArg [] ["no-pending"] F.NoPending False "only include recorded patches in output" ] -- "null" is already taken nullFlag :: PrimDarcsOption Bool nullFlag = singleNoArg ['0'] ["null"] F.NullFlag "separate file names by NUL characters" +-- ** show repo + +enumPatches :: PrimDarcsOption EnumPatches +enumPatches = withDefault YesEnumPatches + [ RawNoArg [] ["enum-patches"] F.EnumPatches YesEnumPatches + "include statistics requiring enumeration of patches" + , RawNoArg [] ["no-enum-patches"] F.NoEnumPatches NoEnumPatches + "don't include statistics requiring enumeration of patches" ] + -- ** gzcrcs data GzcrcsAction = GzcrcsCheck | GzcrcsRepair deriving (Eq, Show) @@ -1224,11 +1351,9 @@ -- ** optimize siblings :: PrimDarcsOption [AbsolutePath] -siblings = multiAbsPathArg [] ["sibling"] F.Sibling mkV "URL" "specify a sibling directory" +siblings = multiAbsPathArg [] ["sibling"] F.Sibling mkV "DIRECTORY" + "specify a sibling directory" where mkV fs = [ s | F.Sibling s <- fs ] - -reorderPatches :: PrimDarcsOption Bool -reorderPatches = singleNoArg [] ["reorder-patches"] F.Reorder "reorder the patches in the repository" reorder :: PrimDarcsOption Reorder reorder = withDefault NoReorder diff --git a/src/Darcs/UI/Options/Core.hs b/src/Darcs/UI/Options/Core.hs --- a/src/Darcs/UI/Options/Core.hs +++ b/src/Darcs/UI/Options/Core.hs @@ -283,6 +283,9 @@ ocheck _ = [] odesc = [] +instance Semigroup (PrimOptSpec d f a [v]) where + (<>) = oappend + -- | See 'oappend' and 'oempty'. instance Monoid (PrimOptSpec d f a [v]) where mappend = oappend @@ -295,3 +298,13 @@ -- prop> parseFlags o fs = oparse o id fs parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v parseFlags o fs = oparse o id fs + +-- no assoiativity, higher precedence than comparisons operators (4) +-- and lower than arithemic operators (6,7,8) +infix 5 ? + +-- | Operator version of 'parseFlags' +-- +-- prop> opt ? flags = parseFlags opt flags +(?) :: (forall a. PrimOptSpec d f a v) -> [f] -> v +(?) = parseFlags diff --git a/src/Darcs/UI/Options/Flags.hs b/src/Darcs/UI/Options/Flags.hs --- a/src/Darcs/UI/Options/Flags.hs +++ b/src/Darcs/UI/Options/Flags.hs @@ -16,7 +16,7 @@ | LeaveTestDir | NoLeaveTestDir | Timings | Debug | DebugHTTP | Verbose | NormalVerbosity | Quiet - | Target String | Cc String + | To String | Cc String | Output AbsolutePathOrStd | OutputAutoName AbsolutePath | Mail | Subject String | InReplyTo String | Charset String | SendmailCmd String | Author String | SelectAuthor | PatchName String @@ -24,7 +24,7 @@ | OneHash String | AfterPatch String | UpToPatch String | AfterHash String | UpToHash String - | TagName String | LastN Int | MaxCount Int | PatchIndexRange Int Int + | TagName String | LastN Int | MaxCount String | PatchIndexRange Int Int | NumberPatches | OneTag String | AfterTag String | UpToTag String | GenContext | Context AbsolutePath | Count @@ -95,4 +95,5 @@ | NoAmendUnrecord | AmendUnrecord | PatchIndexFlag | NoPatchIndexFlag + | EnumPatches | NoEnumPatches deriving ( Eq, Show ) diff --git a/src/Darcs/UI/Options/Matching.hs b/src/Darcs/UI/Options/Matching.hs --- a/src/Darcs/UI/Options/Matching.hs +++ b/src/Darcs/UI/Options/Matching.hs @@ -21,14 +21,17 @@ , matchSeveralOrLast , matchRange , matchSeveralOrRange - , matchAny -- temporary, for toMatchFlags + -- * exported for for checking + , context + , matchLast + , matchFrom + , matchAny -- temporary hack ) where import Prelude () import Darcs.Prelude hiding ( last ) import Data.Char ( isDigit ) -import Data.Monoid ( (<>) ) import Darcs.Patch.Match ( MatchFlag(..) ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) ) @@ -59,10 +62,13 @@ matchOneNontag :: MatchOption matchOneNontag = match <> patch <> hash --- | Used by: rebase pull, apply, send, push, pull, fetch +-- | Used by: rebase pull/apply, send, push, pull, apply, fetch matchSeveral :: MatchOption matchSeveral = matches <> patches <> tags <> hash +matchLast :: MatchOption +matchLast = last + -- | Used by: rebase unsuspend/reify matchSeveralOrFirst :: MatchOption matchSeveralOrFirst = mconcat [ matchTo, last, matches, patches, tags, hash ] @@ -89,7 +95,7 @@ matchAny :: MatchOption matchAny = mconcat [ toMatch, toPatch, toHash, toTag, fromMatch, fromPatch, fromHash, fromTag, - tag, tags, patch, patches, match, matches, index, indexes, context, last ] + tag, tags, patch, patches, hash, match, matches, index, indexes, context, last ] -- * Primitive matching options @@ -220,7 +226,7 @@ "select the last NUMBER patches" ] toInt s = if not (null s) && all isDigit s then read s else (-1) --- | TODO: see 'Darcs.UI.Options.matchMaxcount'. +-- | TODO: see 'Darcs.UI.Options.maxCount'. index = OptSpec {..} where ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ] oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ] @@ -230,7 +236,7 @@ then F.PatchIndexRange (read s) (read s) else F.PatchIndexRange 0 0 --- | TODO: see 'Darcs.UI.Options.matchMaxcount'. +-- | TODO: see 'Darcs.UI.Options.maxCount'. indexes = OptSpec {..} where ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ] oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ] diff --git a/src/Darcs/UI/PatchHeader.hs b/src/Darcs/UI/PatchHeader.hs --- a/src/Darcs/UI/PatchHeader.hs +++ b/src/Darcs/UI/PatchHeader.hs @@ -10,7 +10,7 @@ import Darcs.Prelude import Darcs.Patch - ( IsRepoType, RepoPatch, Patchy, PrimPatch, PrimOf, fromPrims + ( IsRepoType, RepoPatch, PrimPatch, PrimOf, fromPrims , effect , summaryFL ) @@ -27,9 +27,8 @@ import Darcs.Repository ( Repository ) import Darcs.Util.Lock - ( readLocaleFile - , writeLocaleFile - , appendToFile + ( readTextFile + , writeTextFile ) import Darcs.UI.External ( editFile ) @@ -38,13 +37,12 @@ import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.UI.SelectChanges ( askAboutDepends ) -import Darcs.Util.ByteString ( encodeLocale ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import Darcs.Util.English ( capitalize ) import Darcs.Util.Global ( darcsLastMessage ) import Darcs.Util.Path ( FilePathLike, toFilePath ) import Darcs.Util.Prompt ( PromptConfig(..), askUser, promptChar, promptYorn ) -import Darcs.Util.Printer ( hPutDocLn, text, ($$), prefixLines, RenderMode(..) ) +import Darcs.Util.Printer ( text, ($$), vcat, prefixLines, renderString ) import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) import Darcs.Util.Tree ( Tree ) @@ -53,7 +51,6 @@ import Control.Monad ( when, void ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Trans.State.Strict ( StateT(..), evalStateT, get, put ) -import qualified Data.ByteString as B ( hPut ) import Data.List ( isPrefixOf ) import System.Exit ( exitSuccess ) import System.IO ( stdin ) @@ -83,7 +80,7 @@ -- It ensures the patch name is not empty nor starts with the prefix TAG. -- -- The last result component is a possible path to a temporary file that should be removed later. -getLog :: forall prim wX wY . (Patchy prim, PrimPatch prim) +getLog :: forall prim wX wY . PrimPatch prim => Maybe String -- ^ patchname option -> Bool -- ^ pipe option -> O.Logfile -- ^ logfile option @@ -102,7 +99,7 @@ thelog <- lines `fmap` Ratified.hGetContents stdin return (p, thelog, Nothing) go _ (O.Logfile { O._logfile = Just f }) _ = do - mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return []) + mlp <- readTextFile f `catch` (\(_ :: IOException) -> return []) firstname <- case (patchname_specified, mlp) of (FlagPatchName p, []) -> return p (_, p:_) -> if badName p @@ -165,7 +162,7 @@ actually_get_log p = do let logf = darcsLastMessage -- TODO: make sure encoding used for logf is the same everywhere -- probably should be locale because the editor will assume it - writeLocaleFile logf $ unlines $ p : default_log + writeTextFile logf $ unlines $ p : default_log append_info logf p _ <- editFile logf (name,long) <- read_long_comment logf p @@ -177,28 +174,25 @@ read_long_comment :: FilePathLike p => p -> String -> IO (String, [String]) read_long_comment f oldname = - do f' <- readLocaleFile f - let t = filter (not.("#" `isPrefixOf`)) $ (lines.filter (/='\r')) f' - case t of [] -> return (oldname, []) - (n:ls) -> return (n, ls) + do t <- readTextFile f + let filter_out_info = filter (not.("#" `isPrefixOf`)) + case reverse $ dropWhile null $ reverse $ filter_out_info t of + [] -> return (oldname, []) + (n:ls) -> return (n, ls) - append_info f oldname = - do fc <- readLocaleFile f - appendToFile f $ \h -> - do case fc of - _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n")) - | last fc /= '\n' -> B.hPut h (encodeLocale "\n") - | otherwise -> return () - hPutDocLn Encode h - $ text "# Please enter the patch name in the first line, and" - $$ text "# optionally, a long description in the following lines." - $$ text "#" - $$ text "# Lines starting with '#' will be ignored." - $$ text "#" - $$ text "#" - $$ text "# Summary of selected changes:" - $$ text "#" - $$ prefixLines (text "#") (summaryFL chs) + append_info f oldname = do + fc <- readTextFile f + writeTextFile f $ renderString + $ vcat (map text $ if null fc then [oldname] else fc) + $$ text "# Please enter the patch name in the first line, and" + $$ text "# optionally, a long description in the following lines." + $$ text "#" + $$ text "# Lines starting with '#' will be ignored." + $$ text "#" + $$ text "#" + $$ text "# Summary of selected changes:" + $$ text "#" + $$ prefixLines (text "#") (summaryFL chs) -- |specify whether to ask about dependencies with respect to a particular repository, or not data AskAboutDeps rt p wR wU wT = AskAboutDeps (Repository rt p wR wU wT) | NoAskAboutDeps diff --git a/src/Darcs/UI/PrintPatch.hs b/src/Darcs/UI/PrintPatch.hs --- a/src/Darcs/UI/PrintPatch.hs +++ b/src/Darcs/UI/PrintPatch.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.UI.PrintPatch ( printPatch , contextualPrintPatch @@ -35,17 +33,16 @@ import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch ( showContextPatch, showPatch, showNicely, description, summary ) -import Darcs.Patch.Show ( ShowPatch ) +import Darcs.Patch.Show ( ShowPatch, ShowContextPatch, ShowPatchFor(ForDisplay) ) import Darcs.UI.External ( viewDocWith ) ---import Darcs.UI.Flags ( DarcsFlag(Summary, Verbose), isUnified ) import Darcs.UI.Options.All ( Verbosity(..), Summary(..), WithContext(..) ) -import Darcs.Util.Printer ( Doc, putDocLnWith, RenderMode(..) ) +import Darcs.Util.Printer ( Doc, putDocLnWith ) -- | @'printFriendly' opts patch@ prints @patch@ in accordance with the flags -- in opts, ie, whether @--verbose@ or @--summary@ were passed at the -- command-line. -printFriendly :: (ShowPatch p, ApplyState p ~ Tree) => Maybe (Tree IO) +printFriendly :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) => Maybe (Tree IO) -> Verbosity -> Summary -> WithContext -> p wX wY -> IO () printFriendly (Just pristine) _ _ YesContext = contextualPrintPatch pristine printFriendly _ v s _ = putDocLnWith fancyPrinters . showFriendly v s @@ -59,16 +56,16 @@ -- | 'printPatch' prints a patch on standard output. printPatch :: ShowPatch p => p wX wY -> IO () -printPatch p = putDocLnWith fancyPrinters $ showPatch p +printPatch p = putDocLnWith fancyPrinters $ showPatch ForDisplay p -- | 'printPatchPager' runs '$PAGER' and shows a patch in it. printPatchPager :: ShowPatch p => p wX wY -> IO () -printPatchPager p = viewDocWith fancyPrinters Standard $ showPatch p +printPatchPager p = viewDocWith fancyPrinters $ showPatch ForDisplay p -- | 'contextualPrintPatch' prints a patch, together with its context, on -- standard output. -contextualPrintPatch :: (ShowPatch p, ApplyState p ~ Tree) => Tree IO +contextualPrintPatch :: (ShowContextPatch p, ApplyState p ~ Tree) => Tree IO -> p wX wY -> IO () contextualPrintPatch s p = do - (contextedPatch, _) <- virtualTreeIO (showContextPatch p) s + (contextedPatch, _) <- virtualTreeIO (showContextPatch ForDisplay p) s putDocLnWith fancyPrinters contextedPatch diff --git a/src/Darcs/UI/RunCommand.hs b/src/Darcs/UI/RunCommand.hs --- a/src/Darcs/UI/RunCommand.hs +++ b/src/Darcs/UI/RunCommand.hs @@ -15,7 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} -- | This is the actual heavy lifter code, which is responsible for parsing the -- arguments and then running the command itself. module Darcs.UI.RunCommand ( runTheCommand ) where @@ -30,15 +29,15 @@ getOpt ) import System.Exit ( ExitCode ( ExitSuccess ), exitWith ) -import Darcs.UI.Options ( DarcsOption, (^), odesc, oparse, parseFlags, optDescr ) +import Darcs.UI.Options ( (^), odesc, oparse, parseFlags, optDescr, (?) ) import Darcs.UI.Options.All ( stdCmdActions, StdCmdAction(..) , anyVerbosity, verbosity, Verbosity(..), network, NetworkOptions(..) - , preHook, postHook ) + , HooksConfig(..), hooks ) import Darcs.UI.Defaults ( applyDefaults ) import Darcs.UI.External ( viewDoc ) -import Darcs.UI.Flags ( DarcsFlag (NewRepo), toMatchFlags, fixRemoteRepos ) +import Darcs.UI.Flags ( DarcsFlag (NewRepo), matchAny, fixRemoteRepos ) import Darcs.UI.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ) , CommandControl @@ -49,20 +48,22 @@ , commandExtraArgHelp , commandExtraArgs , commandArgdefaults - , commandGetArgPossibilities + , commandCompleteArgs , commandOptions , commandParseOptions , wrappedCommandName , disambiguateCommands - , getCommandHelp - , getCommandMiniHelp , getSubcommands , extractCommands , superName - , subusage ) import Darcs.UI.Commands.GZCRCs ( doCRCWarnings ) import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH ) +import Darcs.UI.Usage + ( getCommandHelp + , getCommandMiniHelp + , subusage + ) import Darcs.Patch.Match ( checkMatchSyntax ) import Darcs.Repository.Prefs ( getGlobal, getPreflist ) @@ -72,7 +73,6 @@ import Darcs.Util.Exception ( die ) import Darcs.Util.Global ( setDebugMode, setTimingsMode ) import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute ) -import Darcs.Util.Printer ( text ) import Darcs.Util.Progress ( setProgressMode ) import Darcs.Util.Text ( chompTrailingNewline, quote ) @@ -101,16 +101,18 @@ -- must use the (saved) original working directory to resolve possibly -- relative paths to absolute paths. prereq_errors <- commandPrereq cmd cmdline_flags + -- we must get the cwd again because commandPrereq has the side-effect of changing it. + new_wd <- getCurrentDirectory user_defs <- getGlobal "defaults" repo_defs <- getPreflist "defaults" let (flags,flag_errors) = applyDefaults (fmap commandName msuper) cmd old_wd user_defs repo_defs cmdline_flags case parseFlags stdCmdActions flags of - Just Help -> viewDoc $ text $ getCommandHelp msuper cmd + Just Help -> viewDoc $ getCommandHelp msuper cmd Just ListOptions -> do setProgressMode False - file_args <- commandGetArgPossibilities cmd - putStrLn $ intercalate "\n" $ getOptionsOptions options : file_args + possible_args <- commandCompleteArgs cmd (new_wd, old_wd) flags orig_extra + mapM_ putStrLn $ optionList options ++ possible_args Just Disable -> die $ "Command "++commandName cmd++" disabled with --disable option!" Nothing -> case prereq_errors of @@ -121,35 +123,31 @@ [] -> do extra <- commandArgdefaults cmd flags old_wd orig_extra case extraArgumentsError extra cmd msuper of - Nothing -> runWithHooks cmd old_wd flags extra + Nothing -> runWithHooks cmd (new_wd, old_wd) flags extra Just msg -> die msg es -> die (intercalate "\n" es) fixupMsgs :: (a, b, [String]) -> (a, b, [String]) fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es) -withHookOpts :: DarcsOption a (t2 -> t3 -> t4 -> t1) - -> (t2 -> t3 -> t4 -> t -> t1) -> [DarcsFlag] -> t -> a -withHookOpts opts runHook flags path = oparse opts runHook' flags where - runHook' mcmd ask verb = runHook mcmd ask verb path - runWithHooks :: DarcsCommand pf - -> AbsolutePath -> [DarcsFlag] -> [String] -> IO () -runWithHooks cmd old_wd flags extra = do - -- NOTE: we must get the cwd again because commandPrereq has the side-effect of changing it. - new_wd <- getCurrentDirectory - checkMatchSyntax $ toMatchFlags flags + -> (AbsolutePath, AbsolutePath) + -> [DarcsFlag] -> [String] -> IO () +runWithHooks cmd (new_wd, old_wd) flags extra = do + checkMatchSyntax $ matchAny ? flags -- set any global variables oparse (anyVerbosity ^ network) setGlobalVariables flags -- actually run the command and its hooks - preHookExitCode <- withHookOpts (preHook ^ verbosity) runPrehook flags new_wd + let hooksCfg = parseFlags hooks flags + let verb = parseFlags verbosity flags + preHookExitCode <- runPrehook (pre hooksCfg) verb new_wd if preHookExitCode /= ExitSuccess then exitWith preHookExitCode else do fixedFlags <- fixRemoteRepos old_wd flags phDir <- getPosthookDir new_wd cmd fixedFlags extra let parsedFlags = commandParseOptions cmd fixedFlags commandCommand cmd (new_wd, old_wd) parsedFlags extra - postHookExitCode <- withHookOpts (postHook ^ verbosity) runPosthook flags phDir + postHookExitCode <- runPosthook (post hooksCfg) verb phDir exitWith postHookExitCode setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO () @@ -204,10 +202,13 @@ nthOf n (_:hs) = nthOf (n-1) hs nthOf _ [] = "UNDOCUMENTED" -getOptionsOptions :: [OptDescr DarcsFlag] -> String -getOptionsOptions = intercalate "\n" . concatMap goo - where - goo (Option _ os _ _) = map ("--"++) os +optionList :: [OptDescr DarcsFlag] -> [String] +optionList = concatMap names + where + names (Option sos los _ desc) = + map (short desc) sos ++ map (long desc) los + short d o = '-' : o : ";" ++ d + long d o = "--" ++ o ++ ";" ++ d runRawSupercommand :: DarcsCommand pf -> [String] -> IO () runRawSupercommand super [] = @@ -219,7 +220,7 @@ -- note: we do not apply defaults here (flags,_,getopt_errs) -> case parseFlags stdCmdActions flags of Just Help -> - viewDoc $ text $ getCommandHelp Nothing super + viewDoc $ getCommandHelp Nothing super Just ListOptions -> do putStrLn "--help" mapM_ (putStrLn . wrappedCommandName) (extractCommands $ getSubcommands super) diff --git a/src/Darcs/UI/SelectChanges.hs b/src/Darcs/UI/SelectChanges.hs --- a/src/Darcs/UI/SelectChanges.hs +++ b/src/Darcs/UI/SelectChanges.hs @@ -15,9 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - - module Darcs.UI.SelectChanges ( -- * Working with changes WhichChanges(..) @@ -57,16 +54,16 @@ import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) ) import Control.Monad ( liftM, unless, when, (>=>) ) import Control.Monad.Identity ( Identity (..) ) import Control.Monad.Reader - ( Reader, ReaderT, asks - , runReader, runReaderT + ( ReaderT + , asks + , runReaderT ) import Control.Monad.State ( StateT, execStateT, gets - , modify, runStateT + , modify, runStateT, state ) import Control.Monad.Trans ( liftIO ) import Data.List ( intercalate, union ) @@ -74,41 +71,43 @@ import System.Exit ( exitSuccess ) import Darcs.Patch - ( Patchy, PrimPatch, IsRepoType, RepoPatch, PrimOf + ( IsRepoType, RepoPatch, PrimOf , commuteFLorComplain, invert , listTouchedFiles, fromPrims ) import qualified Darcs.Patch ( thing, things, summary ) -import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch.Choices ( PatchChoices, Slot (..), LabelledPatch - , patchChoicesLps, forceFirsts + , mkPatchChoices, forceFirsts , forceFirst, forceLast, forceMatchingFirst , forceMatchingLast, getChoices , makeEverythingLater, makeEverythingSooner - , makeUncertain, patchChoices - , patchChoicesLpsSub, patchSlot' + , forceMiddle, patchChoices + , patchSlot , refineChoices, selectAllMiddles , separateFirstFromMiddleLast - , substitute, label, lpPatch + , substitute, label, unLabel + , labelPatches ) +import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Invert ( Invert ) -import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread ) +import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch ) import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia ) -import Darcs.Patch.Set ( PatchSet(..), newset2RL ) -import Darcs.Patch.Show ( ShowPatch ) -import Darcs.Patch.Split ( Splitter (..) ) -import qualified Darcs.Patch.TouchesFiles as TouchesFiles +import Darcs.Patch.Set ( PatchSet(..), patchSet2RL ) +import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) +import Darcs.Patch.Split ( Splitter(applySplitter,canonizeSplit) ) +import Darcs.Patch.TouchesFiles ( selectNotTouching, deselectNotTouching ) import Darcs.Patch.Type ( PatchType (..) ) import Darcs.Patch.Witnesses.Eq ( unsafeCompare ) import Darcs.Patch.Witnesses.Ordered ( (:>) (..), (:||:) (..), FL (..) , RL (..), filterFL, lengthFL, mapFL - , mapFL_FL, reverseFL, spanFL, spanFL_M - , (+<+), (+>+), reverseRL + , mapFL_FL, spanFL, spanFL_M + , (+>+), (+<<+), (+>>+) ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal (..), Sealed2 (..) @@ -118,7 +117,7 @@ ( FZipper (..), left, right , rightmost, toEnd, toStart ) -import Darcs.Repository ( Repository, readRepo, readTentativeRepo ) +import Darcs.Repository ( Repository, repoLocation, readRepo, readTentativeRepo ) import Darcs.UI.External ( editText ) import Darcs.UI.Options.All ( Verbosity(..), Summary(..) @@ -127,7 +126,8 @@ ( printFriendly, printPatch , printPatchPager, showFriendly ) import Darcs.Util.English ( Noun (..), englishNum, capitalize ) -import Darcs.Util.Printer ( prefix, putDocLn ) +import Darcs.Util.Printer ( prefix, putDocLn, putDocLnWith, greenText ) +import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Prompt ( PromptConfig (..), askUser, promptChar ) import Darcs.Util.Tree ( Tree ) @@ -137,32 +137,42 @@ -- of the repository), and we either want an initial segment or a -- final segment of the poset of patches. -- --- @First@: ask for an initial +-- 'First': ask for an initial -- segment, first patches first (default for all pull-like commands) -- --- @FirstReversed@: ask for an initial segment, last patches first +-- 'FirstReversed': ask for an initial segment, last patches first -- (used to ask about dependencies in record, and for pull-like -- commands with the @--reverse@ flag). -- --- @LastReversed@: ask for a final segment, last patches first. (default +-- 'LastReversed': ask for a final segment, last patches first. (default -- for unpull-like commands, except for selecting *primitive* patches in -- rollback) -- --- @Last@: ask for a final segment, first patches first. (used for selecting +-- 'Last': ask for a final segment, first patches first. (used for selecting -- primitive patches in rollback, and for unpull-like commands with the -- @--reverse@ flag +-- +-- IOW: First = initial segment +-- Last = final segment +-- Reversed = start with the newest patch instead of oldest +-- As usual, terminology is not, ahem, very intuitive. data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show) --- | A @WhichChanges@ is backwards if the order in which patches are presented --- is the opposite of the order of dependencies for that operation. +-- | A 'WhichChanges' is 'backward' if the segment of patches we ask for +-- is at the opposite end of where we start to present them. backward :: WhichChanges -> Bool backward w = w == Last || w == FirstReversed +-- | A 'WhichChanges' is reversed if the order in which patches are presented +-- is latest (or newest) patch first. +reversed :: WhichChanges -> Bool +reversed w = w == LastReversed || w == FirstReversed + -- | The type of the function we use to filter patches when @--match@ is -- given. data MatchCriterion p = MatchCriterion { mcHasNonrange :: Bool - , mcFunction :: WhichChanges -> Sealed2 p -> Bool + , mcFunction :: forall wA wB. WhichChanges -> LabelledPatch p wA wB -> Bool } data PatchSelectionOptions = PatchSelectionOptions @@ -187,8 +197,7 @@ } -- | A 'PatchSelectionContext' for selecting 'Prim' patches. -selectionContextPrim :: PrimPatch prim - => WhichChanges +selectionContextPrim :: WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter prim) @@ -207,8 +216,11 @@ } -- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches) -selectionContext :: (IsRepoType rt, RepoPatch p) => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter (PatchInfoAnd rt p)) - -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd rt p) +selectionContext :: (IsRepoType rt, RepoPatch p) + => WhichChanges -> String -> PatchSelectionOptions + -> Maybe (Splitter (PatchInfoAnd rt p)) + -> Maybe [FilePath] + -> PatchSelectionContext (PatchInfoAnd rt p) selectionContext whch jn o spl fs = PSC { opts = o , splitter = spl @@ -240,15 +252,12 @@ } -- | The dynamic parameters for interactive selection of patches. -data InteractiveSelectionContext p wX wY = ISC { total :: Int - -- ^ total number of patches - , current :: Int - -- ^ number of already-seen patches - , lps :: FZipper (LabelledPatch p) wX wY - -- ^ the patches we offer - , choices :: PatchChoices p wX wY - -- ^ the user's choices - } +data InteractiveSelectionContext p wX wY = + ISC { total :: Int -- ^ total number of patches + , current :: Int -- ^ number of already-seen patches + , lps :: FZipper (LabelledPatch p) wX wY -- ^ the patches we offer + , choices :: PatchChoices p wX wY -- ^ the user's choices + } type PatchSelectionM p a = ReaderT (PatchSelectionContext p) a @@ -256,9 +265,6 @@ StateT (InteractiveSelectionContext p wX wY) (PatchSelectionM p IO) a -type PatchSelection p wX wY = - PatchSelectionM p IO ((FL p :> FL p) wX wY) - -- Common match criteria -- | For commands without @--match@, 'triv' matches all patches @@ -276,56 +282,92 @@ , mcFunction = isWantedMcFunction } where - isWantedMcFunction x = unseal2 $ iw x - iw First = unseal2 (matchAPatch mflags) . extract - iw Last = unseal2 (matchAPatch mflags) . extract - iw LastReversed = unseal2 (matchAPatch mflags) . extract . invert - iw FirstReversed = unseal2 (matchAPatch mflags) . extract . invert - -liftR :: Monad m => Reader r a -> ReaderT r m a -liftR = asks . runReader + isWantedMcFunction w = unseal2 (matchAPatch mflags) . extract_reverse w . unLabel + -- TODO inverting should not be necessary here, at least I would expect + -- + -- prop> matchAPatch (invert x) == matchAPatch x + extract_reverse w = if reversed w then extract . invert else extract --- | runs a 'PatchSelection' action in the given 'PatchSelectionContext'. -runSelection :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) +-- | Run a 'PatchSelection' action in the given 'PatchSelectionContext'. +runSelection :: forall p wX wY . ( Invert p, Commute p, Apply p, PatchInspect p, ShowPatch p + , ShowContextPatch p, ApplyState p ~ Tree ) => FL p wX wY -> PatchSelectionContext p -> IO ((FL p :> FL p) wX wY) -runSelection ps psc = runReaderT patchSelection psc - where - patchSelection = do - case whichChanges psc of - First -> normal ps - Last -> normal ps - FirstReversed -> reversed ps - LastReversed -> reversed ps - normal fl = sc1 fl - reversed fl = do let ifl = invert fl - choices_ <- sc1 ifl - return $ invertC choices_ +runSelection ps psc = runReaderT (selection ps) psc where + selection + | reversed whch = fmap invert . doit . invert + | otherwise = doit + -- efficiency note: we should first filterUnwanted to apply matchers, + -- as this often requires to read only metadata; then filterNotTouching + -- applies path restrictions which needs to read patch contents + doit = + fmap (canonizeAfterSplitter . selectedPatches) . + selectChanges . filterNotTouching . filterUnwanted . patchChoices -sc1 :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) => - FL p wX wY - -> PatchSelection p wX wY -sc1 fl = do ps <- liftR (patchesToConsider fl) - patchChoices_ <- realSelectChanges ps - whch <- asks whichChanges - let sps = selectedPatches whch patchChoices_ - liftR (canonizeAfterSplitter sps) + -- configuration + whch = whichChanges psc + fs = files psc + os = opts psc + crit = matchCriterion psc + mspl = splitter psc --- | inverses the choices that have been made -invertC :: (Patchy p) => (FL p :> FL p) wX wY -> (FL p :> FL p) wY wX -invertC (a :> b) = invert b :> invert a + -- after selecting with a splitter, the results may not be canonical + canonizeAfterSplitter :: (FL p :> FL p) wA wB -> (FL p :> FL p) wA wB + canonizeAfterSplitter (x :> y) = + let canonizeIfNeeded = maybe id canonizeSplit mspl + in canonizeIfNeeded x :> canonizeIfNeeded y --- | Shows the patch that is actually being selected the way the user --- should see it. -repr :: (Patchy p) => WhichChanges -> Sealed2 p -> Sealed2 p -repr First (Sealed2 p) = Sealed2 p -repr LastReversed (Sealed2 p) = Sealed2 (invert p) -repr Last (Sealed2 p) = Sealed2 p -repr FirstReversed (Sealed2 p) = Sealed2 (invert p) + -- retrieve the results of patch selection + selectedPatches :: PatchChoices p wA wB -> (FL p :> FL p) wA wB + selectedPatches pc + | backward whch = + case getChoices pc of + fc :> mc :> lc -> mapFL_FL unLabel (fc +>+ mc) :> mapFL_FL unLabel lc + | otherwise = + case separateFirstFromMiddleLast pc of + xs :> ys -> mapFL_FL unLabel xs :> mapFL_FL unLabel ys + selectChanges :: PatchChoices p wA wB + -> PatchSelectionM p IO (PatchChoices p wA wB) + selectChanges + | interactive os = refineChoices textSelect + | otherwise = return . promote + + promote + | backward whch = makeEverythingLater + | otherwise = makeEverythingSooner + demote + | backward whch = makeEverythingSooner + | otherwise = makeEverythingLater + + filterNotTouching + | backward whch = selectNotTouching fs + | otherwise = deselectNotTouching fs + + -- when using @--match@, remove unmatched patches + -- not depended upon by matched patches + filterUnwanted :: PatchChoices p wA wB -> PatchChoices p wA wB + filterUnwanted + | mcHasNonrange crit = + case selectDeps os of + NoDeps -> deselectUnwanted + _ -> demote . selectWanted + | otherwise = id + + selectWanted + | backward whch = forceMatchingLast iswanted_ + | otherwise = forceMatchingFirst iswanted_ + deselectUnwanted + | backward whch = forceMatchingFirst (not . iswanted_) + | otherwise = forceMatchingLast (not . iswanted_) + iswanted_ = mcFunction crit whch + + {- end of runSelection -} + -- | The equivalent of 'runSelection' for the @darcs log@ command -viewChanges :: (Patchy p, ShowPatch p, ApplyState p ~ Tree) => PatchSelectionOptions -> [Sealed2 p] -> IO () +viewChanges :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) + => PatchSelectionOptions -> [Sealed2 p] -> IO () viewChanges ps_opts = textView ps_opts Nothing 0 [] -- | The type of the answers to a "shall I [wiggle] that [foo]?" question @@ -352,8 +394,8 @@ keysFor = concatMap (map kp) -- | The function for selecting a patch to amend record. Read at your own risks. -withSelectedPatchFromRepo :: - forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +withSelectedPatchFromRepo + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => String -- name of calling command (always "amend" as of now) -> Repository rt p wR wU wT -> PatchSelectionOptions @@ -361,7 +403,7 @@ -> IO () withSelectedPatchFromRepo jn repository o job = do patchSet <- readRepo repository - sp <- wspfr jn (matchAPatchread $ matchFlags o) (newset2RL patchSet) NilFL + sp <- wspfr jn (matchAPatch $ matchFlags o) (patchSet2RL patchSet) NilFL case sp of Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected') Nothing -> @@ -369,7 +411,10 @@ data SkippedReason = SkippedAutomatically | SkippedManually -data WithSkipped p wX wY = WithSkipped { _skippedReason :: SkippedReason, skippedPatch :: p wX wY } +data WithSkipped p wX wY = WithSkipped + { _skippedReason :: SkippedReason + , skippedPatch :: p wX wY + } -- | This ensures that the selected patch commutes freely with the skipped -- patches, including pending and also that the skipped sequences has an @@ -416,7 +461,8 @@ nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped) previousPatch :: RL (PatchInfoAnd rt p) wX wQ -> FL (WithSkipped (PatchInfoAnd rt p)) wQ wU - -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wU)) + -> IO (Maybe (FlippedSeal + (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wU)) previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL previousPatch remaining' (WithSkipped sk prev :>: skipped'') = case sk of @@ -437,111 +483,9 @@ defaultPrintFriendly = printFriendly Nothing NormalVerbosity NoSummary NoContext --- After selecting with a splitter, the results may not be canonical -canonizeAfterSplitter :: (FL p :> FL p) wX wY -> Reader (PatchSelectionContext p) ((FL p :> FL p) wX wY) -canonizeAfterSplitter (x :> y) = - do mspl <- asks splitter - let canonizeIfNeeded = maybe id canonizeSplit mspl - return $ canonizeIfNeeded x :> canonizeIfNeeded y - -realSelectChanges :: forall p wX wY. - (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) - => PatchChoices p wX wY - -> PatchSelectionM p IO (PatchChoices p wX wY) -realSelectChanges autoChoices = - do - o <- asks opts - whch <- asks whichChanges - if not $ interactive o - then return $ promote whch autoChoices - else refineChoices textSelect autoChoices - where forward whch = not $ backward whch - promote whch = - if forward whch - then makeEverythingSooner - else makeEverythingLater - --- | When using @--match@, remove unmatched patches not depended upon by matched --- patches. -deselectUnwanted :: forall p wX wY . Patchy p => - PatchChoices p wX wY -> - Reader (PatchSelectionContext p) (PatchChoices p wX wY) -deselectUnwanted pc = - do - o <- asks opts - mc <- asks matchCriterion - whichch <- asks whichChanges - let iswanted_ = mcFunction mc whichch . seal2 . lpPatch - select = if forward whichch - then forceMatchingFirst iswanted_ - else forceMatchingLast iswanted_ - deselect = if forward whichch - then forceMatchingLast (not . iswanted_) - else forceMatchingFirst (not . iswanted_) - return $ - if mcHasNonrange mc - then if selectDeps o == NoDeps - then deselect pc - else demote whichch $ select pc - else pc - where - forward whichch = not $ backward whichch - demote whichch = - if forward whichch - then makeEverythingLater - else makeEverythingSooner - --- | Selects the patches matching the match criterion, and puts them first or last --- according to whch, while respecting any dependencies. -patchesToConsider :: forall p wX wY - . (Patchy p, PatchInspect p, ApplyState p ~ Tree) - => FL p wX wY - -> Reader (PatchSelectionContext p) (PatchChoices p wX wY) -patchesToConsider ps = - do - fs <- asks files - crit <- asks matchCriterion - whch <- asks whichChanges - let deselectNotTouching = - case whch of - First -> TouchesFiles.deselectNotTouching - Last -> TouchesFiles.selectNotTouching - FirstReversed -> TouchesFiles.selectNotTouching - LastReversed -> TouchesFiles.deselectNotTouching - everything = patchChoices ps - -- first filter patches by matchers - -- this often requires to read only metadata - notUnwanted <- if not (mcHasNonrange crit) - then return everything - else deselectUnwanted everything - -- if there are path restrictions, we need to read patch contents - -- of what remains - return $ if isJust fs then deselectNotTouching fs notUnwanted - else notUnwanted - --- | Returns the results of a patch selection user interaction -selectedPatches :: Patchy p => WhichChanges -> PatchChoices p wY wZ - -> (FL p :> FL p) wY wZ -selectedPatches Last pc = - case getChoices pc of - fc :> mc :> lc -> mapFL_FL lpPatch (fc +>+ mc) :> mapFL_FL lpPatch lc - -selectedPatches First pc = - case separateFirstFromMiddleLast pc of - xs :> ys -> mapFL_FL lpPatch xs :> mapFL_FL lpPatch ys - -selectedPatches LastReversed pc = - case separateFirstFromMiddleLast pc of - xs :> ys -> mapFL_FL lpPatch xs :> mapFL_FL lpPatch ys - -selectedPatches FirstReversed pc = - case getChoices pc of - fc :> mc :> lc -> mapFL_FL lpPatch (fc +>+ mc) :> mapFL_FL lpPatch lc - -- | Runs a function on the underlying @PatchChoices@ object -liftChoices :: forall p a wX wY . Patchy p => - StateT (PatchChoices p wX wY) Identity a - -> InteractiveSelectionM p wX wY a +liftChoices :: StateT (PatchChoices p wX wY) Identity a + -> InteractiveSelectionM p wX wY a liftChoices act = do ch <- gets choices let (result, _) = runIdentity $ runStateT act ch @@ -549,12 +493,14 @@ return result -- | @justDone n@ notes that @n@ patches have just been processed -justDone :: Patchy p => Int -> InteractiveSelectionM p wX wY () +justDone :: Int -> InteractiveSelectionM p wX wY () justDone n = modify $ \isc -> isc{ current = current isc + n} -- | The actual interactive selection process. -textSelect :: forall p wX wY . (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) - => FL (LabelledPatch p) wX wY -> PatchChoices p wX wY +textSelect :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p + , PatchInspect p, ApplyState p ~ Tree ) + => FL (LabelledPatch p) wX wY + -> PatchChoices p wX wY -> PatchSelectionM p IO (PatchChoices p wX wY) textSelect lps' pcs = do userSelection <- execStateT (skipMundane >> @@ -570,7 +516,8 @@ unless (rightmost z) $ textSelect' -textSelect' :: (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) +textSelect' :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p + , PatchInspect p, ApplyState p ~ Tree ) => InteractiveSelectionM p wX wY () textSelect' = do z <- gets lps @@ -602,7 +549,8 @@ optionsQuit :: String -> Bool -> String -> [KeyPress] optionsQuit jn allowsa someThings = - [ KeyPress 'd' (jn++" selected "++someThings++", skipping all the remaining "++someThings) + [ KeyPress 'd' (jn++" selected "++someThings++ + ", skipping all the remaining "++someThings) | allowsa ] ++ [ KeyPress 'a' (jn++" all the remaining "++someThings) @@ -632,8 +580,9 @@ , KeyPress 'd' "confirm this operation" , KeyPress 'n' ("cancel " ++ jn) ]]) -options :: forall p wX wY . (Patchy p, ShowPatch p) => Bool -> - InteractiveSelectionM p wX wY ([[KeyPress]],[[KeyPress]]) +options :: (ShowPatch p) + => Bool + -> InteractiveSelectionM p wX wY ([[KeyPress]],[[KeyPress]]) options single = do split <- asks splitter jn <- asks jobname @@ -654,33 +603,28 @@ -- | Returns a @Sealed2@ version of the patch we are asking the user -- about. -currentPatch :: forall p wX wY . Patchy p => - InteractiveSelectionM p wX wY - (Maybe (Sealed2 (LabelledPatch p))) +currentPatch :: InteractiveSelectionM p wX wY (Maybe (Sealed2 (LabelledPatch p))) currentPatch = do - (FZipper _ lps_todo) :: FZipper (LabelledPatch p) wX wY <- gets lps + FZipper _ lps_todo <- gets lps case lps_todo of NilFL -> return Nothing (lp:>:_) -> return $ Just (Sealed2 lp) -- | Returns the patches we have yet to ask the user about. -todo :: forall p wX wY . Patchy p - => InteractiveSelectionM p wX wY - (FlippedSeal (FL (LabelledPatch p)) wY) +todo :: InteractiveSelectionM p wX wY (FlippedSeal (FL (LabelledPatch p)) wY) todo = do (FZipper _ lps_todo) <- gets lps return (FlippedSeal lps_todo) -- | Modify the underlying @PatchChoices@ by some function -modChoices :: forall p wX wY . Patchy p => - (PatchChoices p wX wY -> PatchChoices p wX wY) +modifyChoices :: (PatchChoices p wX wY -> PatchChoices p wX wY) -> InteractiveSelectionM p wX wY () -modChoices f = modify $ \isc -> isc{choices = f $ choices isc} +modifyChoices f = modify $ \isc -> isc{choices = f $ choices isc} -- | returns @Just f@ if the 'currentPatch' only modifies @f@, -- @Nothing@ otherwise. -currentFile :: forall p wX wY . (Patchy p, PatchInspect p) - => InteractiveSelectionM p wX wY (Maybe FilePath) +currentFile :: (PatchInspect p) + => InteractiveSelectionM p wX wY (Maybe FilePath) currentFile = do c <- currentPatch return $ case c of @@ -692,18 +636,19 @@ -- | @decide True@ selects the current patch, and @decide False@ deselects -- it. -decide :: forall p wX wY wT wU . Patchy p => Bool - -> LabelledPatch p wT wU - -> InteractiveSelectionM p wX wY () +decide :: Commute p + => Bool + -> LabelledPatch p wT wU + -> InteractiveSelectionM p wX wY () decide takeOrDrop lp = do whch <- asks whichChanges if backward whch == takeOrDrop -- we go backward xor we are dropping - then modChoices $ forceLast (label lp) - else modChoices $ forceFirst (label lp) + then modifyChoices $ forceLast (label lp) + else modifyChoices $ forceFirst (label lp) -- | like 'decide', but for all patches touching @file@ -decideWholeFile :: forall p wX wY. (Patchy p, PatchInspect p) => - FilePath -> Bool -> InteractiveSelectionM p wX wY () +decideWholeFile :: (Commute p, PatchInspect p) + => FilePath -> Bool -> InteractiveSelectionM p wX wY () decideWholeFile file takeOrDrop = do FlippedSeal lps_todo <- todo @@ -712,30 +657,29 @@ mapM_ (unseal2 $ decide takeOrDrop) patches_to_skip -- | Undecide the current patch. -postponeNext :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () +postponeNext :: Commute p => InteractiveSelectionM p wX wY () postponeNext = do Just (Sealed2 lp) <- currentPatch - modChoices $ makeUncertain (label lp) + modifyChoices $ forceMiddle (label lp) -- | Focus the next patch. -skipOne :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () +skipOne :: InteractiveSelectionM p wX wY () skipOne = modify so where so x = x{lps = right (lps x), current = current x +1} -- | Focus the previous patch. -backOne :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () +backOne :: InteractiveSelectionM p wX wY () backOne = modify so where so isc = isc{lps = left (lps isc), current = max (current isc-1) 0} -- | Split the current patch (presumably a hunk), and add the replace it -- with its parts. -splitCurrent :: forall p wX wY . Patchy p - => Splitter p +splitCurrent :: Splitter p -> InteractiveSelectionM p wX wY () splitCurrent s = do FZipper lps_done (lp:>:lps_todo) <- gets lps - case applySplitter s (lpPatch lp) of + case applySplitter s (unLabel lp) of Nothing -> return () Just (text, parse) -> do @@ -743,8 +687,7 @@ case parse newText of Nothing -> return () Just ps -> do - lps_new <- liftIO . return . snd - $ patchChoicesLpsSub (Just (label lp)) ps + lps_new <- liftIO $ return $ labelPatches (Just (label lp)) ps modify $ \isc -> isc { total = total isc + lengthFL lps_new - 1 , lps = FZipper lps_done (lps_new +>+ lps_todo) @@ -753,51 +696,50 @@ (choices isc) } +-- | Shows the patch that is actually being selected the way the user +-- should see it. +repr :: Invert p => WhichChanges -> LabelledPatch p wX wY -> Sealed2 p +repr w p + | reversed w = Sealed2 (invert (unLabel p)) + | otherwise = Sealed2 (unLabel p) + -- | Returns a list of the currently selected patches, in -- their original context, i.e., not commuted past unselected -- patches. -selected :: forall p wX wY. Patchy p => - InteractiveSelectionM p wX wY [Sealed2 p] +selected :: (Commute p, Invert p) => InteractiveSelectionM p wX wY [Sealed2 p] selected = do - whichch <- asks whichChanges - c <- gets choices - (first_chs :> _ :> last_chs) <- return $ getChoices c - return $ if backward whichch - then - mapFL (repr whichch . Sealed2 . lpPatch) last_chs - else - mapFL (repr whichch . Sealed2 . lpPatch) first_chs + w <- asks whichChanges + chs <- gets choices + (first_chs :> _ :> last_chs) <- return $ getChoices chs + return $ if backward w then mapFL (repr w) last_chs else mapFL (repr w) first_chs -- | Prints the list of the selected patches. See 'selected'. -printSelected :: (Patchy p, ShowPatch p) => +printSelected :: (Invert p, Commute p, ShowPatch p) => InteractiveSelectionM p wX wY () printSelected = do someThings <- things o <- asks opts s <- selected liftIO $ do - putStrLn $ "---- Already selected "++someThings++" ----" - mapM_ (putDocLn . unseal2 (showFriendly (verbosity o) (summary o))) s - putStrLn $ "---- end of already selected "++someThings++" ----" + putDocLnWith fancyPrinters $ greenText $ "---- selected "++someThings++" ----" + mapM_ (putDocLnWith fancyPrinters . unseal2 (showFriendly (verbosity o) (summary o))) s + putDocLnWith fancyPrinters $ greenText $ "---- end of selected "++someThings++" ----" -printSummary :: forall p wX wY . ShowPatch p => p wX wY -> IO () +printSummary :: ShowPatch p => p wX wY -> IO () printSummary = putDocLn . prefix " " . Darcs.Patch.summary -- | Skips all remaining patches. -skipAll :: forall p wX wY . Patchy p => - InteractiveSelectionM p wX wY () +skipAll :: InteractiveSelectionM p wX wY () skipAll = modify $ \isc -> isc {lps = toEnd $ lps isc} -backAll :: forall p wX wY . Patchy p => - InteractiveSelectionM p wX wY () +backAll :: InteractiveSelectionM p wX wY () backAll = modify $ \isc -> isc {lps = toStart $ lps isc ,current = 0} isSingleFile :: PatchInspect p => p wX wY -> Bool isSingleFile p = length (listTouchedFiles p) == 1 -askConfirmation :: forall p wX wY . Patchy p => - InteractiveSelectionM p wX wY () +askConfirmation :: InteractiveSelectionM p wX wY () askConfirmation = do jn <- asks jobname liftIO $ when (jn `elem` ["unpull", "unrecord", "obliterate"]) $ do @@ -807,21 +749,21 @@ _ -> exitSuccess -- | The singular form of the noun for items of type @p@. -thing :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String +thing :: (ShowPatch p) => InteractiveSelectionM p wX wY String thing = (Darcs.Patch.thing . helper) `liftM` gets choices where helper :: PatchChoices p wA wB -> p wA wB helper = undefined -- | The plural form of the noun for items of type @p@. -things :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String +things :: (ShowPatch p) => InteractiveSelectionM p wX wY String things = (Darcs.Patch.things . helper) `liftM` gets choices where helper :: PatchChoices p wA wB -> p wA wB helper = undefined -- | The question to ask about one patch. -prompt :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String +prompt :: (ShowPatch p) => InteractiveSelectionM p wX wY String prompt = do jn <- asks jobname aThing <- thing @@ -831,8 +773,8 @@ ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") " -- | Asks the user about one patch, returns their answer. -promptUser :: forall p wX wY . (Patchy p, ShowPatch p) => Bool -> Char - -> InteractiveSelectionM p wX wY Char +promptUser :: (ShowPatch p) + => Bool -> Char -> InteractiveSelectionM p wX wY Char promptUser single def = do thePrompt <- prompt (basicOptions,advancedOptions) <- options single @@ -844,7 +786,8 @@ } -- | Ask the user what to do with the next patch. -textSelectOne :: forall p wX wY. (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) +textSelectOne :: ( Invert p, Commute p, ShowPatch p, ShowContextPatch p, PatchInspect p + , ApplyState p ~ Tree ) => InteractiveSelectionM p wX wY Bool textSelectOne = do c <- currentPatch @@ -855,11 +798,11 @@ jn <- asks jobname spl <- asks splitter whichch <- asks whichChanges - let singleFile = isSingleFile (lpPatch lp) - reprCur = repr whichch (Sealed2 (lpPatch lp)) + let singleFile = isSingleFile (unLabel lp) + reprCur = repr whichch lp (basicOptions,advancedOptions) <- options singleFile - theSlot <- liftChoices $ patchSlot' lp - let the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot + theSlot <- liftChoices $ state $ patchSlot lp + let the_default = getDefault (backward whichch) theSlot yorn <- promptUser singleFile the_default let nextPatch = skipMundane >> showCur case yorn of @@ -888,7 +831,7 @@ 'a' -> do askConfirmation - modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed) + modifyChoices $ selectAllMiddles (backward whichch) skipAll return True 'q' -> liftIO $ @@ -900,15 +843,16 @@ liftIO . putStrLn $ helpFor jn basicOptions advancedOptions return False -lastQuestion :: forall p wX wY . (Patchy p, ShowPatch p, ApplyState p ~ Tree) => - InteractiveSelectionM p wX wY Bool +lastQuestion :: (Commute p, Invert p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) + => InteractiveSelectionM p wX wY Bool lastQuestion = do jn <- asks jobname theThings <-things aThing <- thing let (basicOptions, advancedOptions) = optionsLast jn aThing yorn <- liftIO . promptChar $ - PromptConfig { pPrompt = "Do you want to "++capitalize jn++" these "++theThings++"?" + PromptConfig { pPrompt = "Do you want to "++capitalize jn++ + " these "++theThings++"?" , pBasicCharacters = "yglqk" , pAdvancedCharacters = "dan" , pDefault = Just 'y' @@ -921,11 +865,12 @@ 'l' -> printSelected >> return False 'k' -> backOne >> showCur >> return False _ -> do - liftIO . putStrLn $ helpFor "this confirmation prompt" basicOptions advancedOptions + liftIO . putStrLn $ helpFor "this confirmation prompt" + basicOptions advancedOptions return False -- | Shows the current patch as it should be seen by the user. -showCur :: forall p wX wY . (Patchy p, ShowPatch p, ApplyState p ~ Tree) +showCur :: (Invert p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) => InteractiveSelectionM p wX wY () showCur = do o <- asks opts @@ -935,11 +880,11 @@ case c of Nothing -> return () Just (Sealed2 lp) -> do - let reprCur = repr whichch (Sealed2 (lpPatch lp)) + let reprCur = repr whichch lp liftIO . unseal2 (printFriendly p (verbosity o) (summary o) (withContext o)) $ reprCur -- | The interactive part of @darcs changes@ -textView :: forall p . (Patchy p, ShowPatch p, ApplyState p ~ Tree) +textView :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) => PatchSelectionOptions -> Maybe Int -> Int -> [Sealed2 p] -> [Sealed2 p] -> IO () @@ -1007,7 +952,7 @@ | otherwise = Just $ length ps_done + length ps_todo -- | Skips patches we should not ask the user about -skipMundane :: (Patchy p, ShowPatch p) +skipMundane :: (Commute p, ShowPatch p) => InteractiveSelectionM p wX wY () skipMundane = do (FZipper lps_done lps_todo) <- gets lps @@ -1016,20 +961,21 @@ jn <- asks jobname whichch <- asks whichChanges (skipped :> unskipped) <- liftChoices $ spanFL_M - (patchSlot' >=> return . decided) + (state . patchSlot >=> return . decided) lps_todo let numSkipped = lengthFL skipped when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped let boringThenInteresting = if selectDeps o == AutoDeps - then spanFL (not. mcFunction crit whichch . seal2 . lpPatch) + then spanFL (not. mcFunction crit whichch) unskipped else NilFL :> unskipped case boringThenInteresting of boring :> interesting -> do justDone $ lengthFL boring + numSkipped - modify $ \isc -> isc {lps = FZipper (lps_done +<+ reverseFL skipped +<+ reverseFL boring) interesting} + modify $ \isc -> isc {lps = FZipper (lps_done +<<+ skipped +<<+ boring) + interesting} where show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "." when (verbosity o == Verbose) $ @@ -1037,9 +983,8 @@ _nevermind_ jn = "Will not ask whether to " ++ jn ++ " " _these_ n = show n ++ " already decided " ++ _elem_ n "" _elem_ n = englishNum n (Noun "patch") - showskippedpatch :: (Patchy p, ShowPatch p) => FL (LabelledPatch p) wY wT -> IO () - showskippedpatch = - sequence_ . mapFL (printSummary . lpPatch) + showskippedpatch :: ShowPatch p => FL (LabelledPatch p) wY wT -> IO () + showskippedpatch = sequence_ . mapFL (printSummary . unLabel) decided :: Slot -> Bool decided InMiddle = False @@ -1054,7 +999,7 @@ getDefault False InFirst = 'y' getDefault False InLast = 'n' -askAboutDepends :: forall rt p wR wU wT wY . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) +askAboutDepends :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> PatchSelectionOptions -> [PatchInfo] -> IO [PatchInfo] @@ -1062,49 +1007,23 @@ -- ideally we'd just default the olddeps to yes but still ask about them. -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would -- have to have this support added first. - pps <- readTentativeRepo repository + pps <- readTentativeRepo repository (repoLocation repository) pa <- n2pia `fmap` anonymous (fromPrims pa') -- FIXME: this code is completely unreadable - FlippedSeal ps <- return - ((case pps of - PatchSet _ x -> FlippedSeal (reverseRL x+>+(pa:>:NilFL))) - :: FlippedSeal (FL (PatchInfoAnd rt p)) wY) - let (pc, my_lps) = patchChoicesLps ps - tas = case catMaybes (mapFL (\lp -> if pa `unsafeCompare` lpPatch lp || info (lpPatch lp) `elem` olddeps + FlippedSeal ps <- + return $ case pps of PatchSet _ x -> FlippedSeal (x+>>+(pa:>:NilFL)) + let my_lps = labelPatches Nothing ps + pc = mkPatchChoices my_lps + tas = + case catMaybes (mapFL (\lp -> if pa `unsafeCompare` unLabel lp || info (unLabel lp) `elem` olddeps then Just (label lp) else Nothing) my_lps) of [] -> error "askAboutDepends: []" tgs -> tgs - Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL lpPatch mc + Sealed2 ps' <- return $ + case getChoices (forceFirsts tas pc) of + _ :> mc :> _ -> Sealed2 $ mapFL_FL unLabel mc (deps:>_) <- runSelection ps' $ - selectionContext FirstReversed "depend on" ps_opts { matchFlags = [], interactive = True } Nothing Nothing + selectionContext FirstReversed "depend on" ps_opts + { matchFlags = [], interactive = True } Nothing Nothing return $ olddeps `union` mapFL info deps -{- - where - askdep_allowed = not . patchSelectFlag - opts' = filter askdep_allowed cfg - psOpts = (recordPatchSelOpts cfg) --} - -{- --- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting --- patches such as @PatchName n@. <- ??? -patchSelectFlag :: F.DarcsFlag -> Bool -patchSelectFlag F.All = True -patchSelectFlag (F.PatchName _) = True -- ??? -patchSelectFlag (F.OnePatch _) = True -patchSelectFlag (F.OneHash _) = True -patchSelectFlag (F.SeveralPatch _) = True -patchSelectFlag (F.AfterPatch _) = True -patchSelectFlag (F.UpToPatch _) = True -patchSelectFlag (F.TagName _) = True -patchSelectFlag (F.LastN _) = True -patchSelectFlag (F.OneTag _) = True -patchSelectFlag (F.AfterTag _) = True -patchSelectFlag (F.UpToTag _) = True -patchSelectFlag (F.OnePattern _) = True -patchSelectFlag (F.SeveralPattern _) = True -patchSelectFlag (F.AfterPattern _) = True -patchSelectFlag (F.UpToPattern _) = True -patchSelectFlag _ = False --} diff --git a/src/Darcs/UI/TheCommands.hs b/src/Darcs/UI/TheCommands.hs --- a/src/Darcs/UI/TheCommands.hs +++ b/src/Darcs/UI/TheCommands.hs @@ -15,7 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} module Darcs.UI.TheCommands ( commandControlList ) where import Prelude () diff --git a/src/Darcs/UI/Usage.hs b/src/Darcs/UI/Usage.hs --- a/src/Darcs/UI/Usage.hs +++ b/src/Darcs/UI/Usage.hs @@ -9,39 +9,63 @@ -- --no-recursive don't add contents of subdirectories -- @ -module Darcs.UI.Usage ( usageInfo ) where +{-# LANGUAGE OverloadedStrings #-} +module Darcs.UI.Usage + ( usageInfo + , formatOptions + , getCommandHelp + , getCommandMiniHelp + , usage + , subusage + ) where import Prelude () import Darcs.Prelude import Data.Functor.Compose import System.Console.GetOpt( OptDescr(..), ArgDescr(..) ) -import Darcs.UI.Options ( DarcsOptDescr ) +import Darcs.UI.Options.All ( stdCmdActions ) +import Darcs.UI.Commands + ( CommandControl(..) + , DarcsCommand(..) + , wrappedCommandName + , wrappedCommandDescription + , getSubcommands + , commandAlloptions + ) +import Darcs.UI.Options ( DarcsOptDescr, odesc ) +import Darcs.Util.Printer + ( Doc, text, vsep, ($$), vcat, hsep + , renderString + ) --- | Variant of 'System.Console.GetOpt.usageInfo'. --- Return a string describing the usage of a command, derived from the header --- (first argument) and the options described by the second argument. --- --- Sequences of long switches are presented on separate lines. -usageInfo :: String -- header - -> [DarcsOptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr +formatOptions :: [DarcsOptDescr a] -> [String] +formatOptions optDescrs = table + where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescrs table = zipWith3 paste shortPadded (zipWith (++) (map (unlines' . init) ls) (sameLen $ map last ls)) ds shortPadded = sameLen ss - prePad = replicate (4 + length (head shortPadded)) ' ' + prePad = replicate (3 + length (head shortPadded)) ' ' -- Similar to unlines (additional ',' and padding): unlines' = concatMap (\x -> x ++ ",\n" ++ prePad) -- Unchanged: - paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z + paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z sameLen xs = flushLeft ((maximum . map length) xs) xs flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] +-- | Variant of 'System.Console.GetOpt.usageInfo'. +-- Return a string describing the usage of a command, derived from the header +-- (first argument) and the options described by the second argument. +-- +-- Sequences of long switches are presented on separate lines. +usageInfo :: String -- header + -> [DarcsOptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescrs = unlines (header:formatOptions optDescrs) + -- Mild variant of the standard definition: 'losFmt' is a list rather than a -- comma separated string. fmtOpt :: DarcsOptDescr a -> [(String,[String],String)] @@ -49,22 +73,137 @@ case lines descr of [] -> [(sosFmt,losFmt,"")] (d:ds) -> (sosFmt,losFmt,d) : [ ("",[],d') | d' <- ds ] - where sepBy _ [] = "" - sepBy _ [x] = x - sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs - sosFmt = sepBy ',' (map (fmtShort ad) sos) + where endBy _ [] = "" + endBy ch [x] = x ++ [ch] + endBy ch (x:xs) = x ++ ch:' ':endBy ch xs + sosFmt = endBy ',' (map fmtShort sos) losFmt = map (fmtLong ad) los -------------------------------------------------------------------------------- -- Verbatim copies: these definitions aren't exported by System.Console.GetOpt -------------------------------------------------------------------------------- -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = ['-', so] -fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad -fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" +fmtShort :: Char -> String +fmtShort so = "-" ++ [so] fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _ ) lo = "--" ++ lo fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" +-------------------------------------------------------------------------------- + +usage :: [CommandControl] -> Doc +usage cs = vsep + [ "Usage: darcs COMMAND ..." + , "Commands:" $$ usageHelper cs + , vcat + [ "Use 'darcs COMMAND --help' for help on a single command." + , "Use 'darcs --version' to see the darcs version number." + , "Use 'darcs --exact-version' to see a detailed darcs version." + , "Use 'darcs help patterns' for help on patch matching." + , "Use 'darcs help environment' for help on environment variables." + , "Use 'darcs help manpage' to display help in the manpage format." + , "Use 'darcs help markdown' to display help in the markdown format." + ] + , "Check bug reports at http://bugs.darcs.net/" + ] + +subusage :: DarcsCommand pf -> String +subusage super = renderString $ vsep + [ header + , subcommandsHelp + , vcat $ map text $ formatOptions $ odesc stdCmdActions + , text $ commandHelp super + ] + where + usageHelp = hsep $ map text + [ "Usage:" + , commandProgramName super + , commandName super + , "SUBCOMMAND ..." + ] + header = usageHelp $$ text (commandDescription super) + subcommandsHelp = case getSubcommands super of + [] -> mempty + subcommands -> usageHelper subcommands + +usageHelper :: [CommandControl] -> Doc +usageHelper xs = vsep (groups xs) + where + groups [] = [] + groups (HiddenCommand _:cs) = groups cs + groups (GroupName n:cs) = + mempty : case groups cs of + [] -> [text n] + (g:gs) -> (text n $$ g) : gs + groups (CommandData c:cs) = + case groups cs of + [] -> [cmdHelp c] + (g:gs) -> (cmdHelp c $$ g) : gs + + cmdHelp c = text $ " " ++ + padSpaces maxwidth (wrappedCommandName c) ++ + wrappedCommandDescription c + + padSpaces n s = s ++ replicate (n - length s) ' ' + + maxwidth = maximum $ 15 : (map cwidth xs) + + cwidth (CommandData c) = length (wrappedCommandName c) + 2 + cwidth _ = 0 + +getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String +getCommandMiniHelp msuper cmd = renderString $ vsep + [ getCommandHelpCore msuper cmd + , hsep $ map text + [ "See" + , commandProgramName cmd + , "help" + , maybe "" ((++ " ") . commandName) msuper ++ commandName cmd + , "for details." + ] + ] + +getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc +getCommandHelp msuper cmd = vsep + [ getCommandHelpCore msuper cmd + , subcommandsHelp + , withHeading "Options:" basicOptionsHelp + , withHeading "Advanced options:" advancedOptionsHelp + , text $ commandHelp cmd + ] + where + withHeading _ [] = mempty + withHeading h ls = vcat (text h : map text ls) + + (basic, advanced) = commandAlloptions cmd + -- call formatOptions with combined options so that + -- both get the same formatting + (basicOptionsHelp, advancedOptionsHelp) = + splitAt (length basic) $ formatOptions (basic ++ advanced) + + subcommandsHelp = + case msuper of + Nothing -> + case getSubcommands cmd of + [] -> mempty + subcommands -> usageHelper subcommands + -- we don't want to list subcommands if we're already specifying them + Just _ -> mempty + +getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc +getCommandHelpCore msuper cmd = vcat + [ hsep $ + [ "Usage:" + , text $ commandProgramName cmd + , maybe mempty (text . commandName) msuper + , text $ commandName cmd + , "[OPTION]..." + ] + ++ args_help + , text $ commandDescription cmd + ] + where + args_help = case cmd of + (DarcsCommand {}) -> map text $ commandExtraArgHelp cmd + _ -> [] diff --git a/src/Darcs/Util/AtExit.hs b/src/Darcs/Util/AtExit.hs --- a/src/Darcs/Util/AtExit.hs +++ b/src/Darcs/Util/AtExit.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - -- | -- Module : Darcs.Util.AtExit -- Copyright : 2005 Tomasz Zielonka diff --git a/src/Darcs/Util/Bug.hs b/src/Darcs/Util/Bug.hs deleted file mode 100644 --- a/src/Darcs/Util/Bug.hs +++ /dev/null @@ -1,30 +0,0 @@ --- Reporting bugs in darcs. See also impossible.h. -module Darcs.Util.Bug - ( _bug, _bugDoc, _impossible, _fromJust - ) where - -import Prelude () -import Darcs.Prelude - -import Data.Maybe(fromMaybe) -import Darcs.Util.Printer ( Doc, errorDoc, text, ($$) ) - -type BugStuff = (String, Int, String, String) - -_bug :: BugStuff -> String -> a -_bug bs s = _bugDoc bs (text s) - -_bugDoc :: BugStuff -> Doc -> a -_bugDoc bs s = errorDoc $ - text ("bug at " ++ _bugLoc bs) $$ s $$ - text ("See http://wiki.darcs.net/BugTracker/Reporting " ++ - "for help on bug reporting.") - -_bugLoc :: BugStuff -> String -_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date - -_impossible :: BugStuff -> a -_impossible bs = _bug bs $ "Impossible case at "++_bugLoc bs - -_fromJust :: BugStuff -> Maybe a -> a -_fromJust bs = fromMaybe (_bug bs $ "fromJust error at " ++ _bugLoc bs) diff --git a/src/Darcs/Util/ByteString.hs b/src/Darcs/Util/ByteString.hs --- a/src/Darcs/Util/ByteString.hs +++ b/src/Darcs/Util/ByteString.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-} - +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Darcs.Util.ByteString @@ -15,119 +14,85 @@ -- GZIp and MMap IO for ByteStrings, encoding utilities, and miscellaneous -- functions for Data.ByteString -- - -module Darcs.Util.ByteString ( - - unsafeWithInternals, - unpackPSFromUTF8, - packStringToUTF8, - - -- IO with mmap or gzip - gzReadFilePS, - mmapFilePS, - gzWriteFilePS, - gzWriteFilePSs, - gzReadStdin, - gzWriteHandle, - FileSegment, - readSegment, - - -- gzip handling - isGZFile, - gzDecompress, - - -- list utilities - dropSpace, - breakSpace, - linesPS, - unlinesPS, - hashPS, - breakFirstPS, - breakLastPS, - substrPS, - readIntPS, - isFunky, - fromHex2PS, - fromPS2Hex, - betweenLinesPS, - breakAfterNthNewline, - breakBeforeNthNewline, - intercalate, - - -- encoding and unicode utilities - isAscii, - decodeLocale, - encodeLocale, - decodeString +module Darcs.Util.ByteString + ( + -- * IO with mmap or gzip + gzReadFilePS + , mmapFilePS + , gzWriteFilePS + , gzWriteFilePSs + , gzReadStdin + , gzWriteHandle + , FileSegment + , readSegment + -- * gzip handling + , isGZFile + , gzDecompress + -- * list utilities + , dropSpace + , breakSpace + , linesPS + , unlinesPS + , hashPS + , breakFirstPS + , breakLastPS + , substrPS + , readIntPS + , isFunky + , fromHex2PS + , fromPS2Hex + , betweenLinesPS + , intercalate + -- * encoding and unicode utilities + , isAscii + , decodeLocale + , encodeLocale + , unpackPSFromUTF8 + , packStringToUTF8 + -- * properties + , prop_unlinesPS_linesPS_left_inverse + , prop_linesPS_length + , prop_unlinesPS_length + , propHexConversion + , spec_betweenLinesPS ) where import Prelude () import Darcs.Prelude +import Codec.Binary.Base16 ( b16Enc, b16Dec ) + import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Internal as BI -import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Lazy as BL import Data.ByteString (intercalate) -import Data.ByteString.Internal (fromForeignPtr) -import Control.Exception ( catch, SomeException ) import System.IO ( withFile, IOMode(ReadMode) , hSeek, SeekMode(SeekFromEnd,AbsoluteSeek) , openBinaryFile, hClose, Handle, hGetChar , stdin) +import System.IO.Error ( catchIOError ) import System.IO.Unsafe ( unsafePerformIO ) -import Foreign.Storable ( peek ) -import Foreign.Marshal.Array ( advancePtr ) -import Foreign.C.Types ( CInt(..) ) - import Data.Bits ( rotateL ) -import Data.Char ( ord, isSpace ) +import Data.Char ( ord, isSpace, toLower, toUpper ) import Data.Word ( Word8 ) import Data.Int ( Int32, Int64 ) -import qualified Data.Text as T ( pack, unpack ) -import Data.Text.Encoding ( encodeUtf8, decodeUtf8With ) -import Data.Text.Encoding.Error ( lenientDecode ) +import Data.List ( intersperse ) import Control.Monad ( when ) -#if MIN_VERSION_zlib(0,6,0) import Control.Monad.ST.Lazy ( ST ) -#endif -import Foreign.Ptr ( plusPtr, Ptr ) -import Foreign.ForeignPtr ( withForeignPtr ) - -#ifdef DEBUG_PS -import Foreign.ForeignPtr ( addForeignPtrFinalizer ) -import Foreign.Ptr ( FunPtr ) -#endif - -import qualified Data.ByteString.Lazy as BL import qualified Codec.Compression.GZip as GZ import qualified Codec.Compression.Zlib.Internal as ZI -import Darcs.Util.Encoding ( decode, encode ) +import Darcs.Util.Encoding ( decode, encode, decodeUtf8, encodeUtf8 ) import Darcs.Util.Global ( addCRCWarning ) #if mingw32_HOST_OS #else import System.IO.MMap( mmapFileByteString ) -import System.Posix.Files( fileSize, getSymbolicLinkStatus ) #endif import System.Mem( performGC ) -import qualified Bundled.Posix as Bundled ( getFileStatus, fileSize ) - --- ----------------------------------------------------------------------------- --- obsolete debugging code - --- ----------------------------------------------------------------------------- --- unsafeWithInternals - --- | Do something with the internals of a PackedString. Beware of --- altering the contents! -unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a -unsafeWithInternals ps f - = case BI.toForeignPtr ps of - (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l +import System.Posix.Files( fileSize, getSymbolicLinkStatus ) -- | readIntPS skips any whitespace at the beginning of its argument, and -- reads an Int from the beginning of the PackedString. If there is no @@ -138,33 +103,19 @@ readIntPS :: B.ByteString -> Maybe (Int, B.ByteString) readIntPS = BC.readInt . BC.dropWhile isSpace --- ----------------------------------------------------------------------------- --- Destructor functions (taking PackedStrings apart) - --- | Decodes a 'ByteString' containing UTF-8 to a 'String'. Decoding errors are --- flagged with the U+FFFD character. -unpackPSFromUTF8 :: B.ByteString -> String -unpackPSFromUTF8 = T.unpack . decodeUtf8With lenientDecode - -packStringToUTF8 :: String -> B.ByteString -packStringToUTF8 = encodeUtf8 . T.pack - ------------------------------------------------------------------------ --- A reimplementation of Data.ByteString.Char8.dropSpace, but --- specialised to darcs' need for a 4 way isspace. --- --- TODO: if it is safe to use the expanded definition of isSpaceWord8 --- provided by Data.ByteString.Char8, then all this can go. - -- A locale-independent isspace(3) so patches are interpreted the same everywhere. -- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r') isSpaceWord8 :: Word8 -> Bool isSpaceWord8 = (`elem` [0x20, 0x09, 0x0A, 0x0D]) {-# INLINE isSpaceWord8 #-} +-- | Drop leading white space, where white space is defined as +-- consisting of ' ', '\t', '\n', or '\r'. dropSpace :: B.ByteString -> B.ByteString dropSpace bs = B.dropWhile isSpaceWord8 bs +-- | Split at first occurrence of ' ', '\t', '\n', or '\r'. breakSpace :: B.ByteString -> (B.ByteString, B.ByteString) breakSpace bs = B.break isSpaceWord8 bs @@ -172,50 +123,24 @@ {-# INLINE isFunky #-} isFunky :: B.ByteString -> Bool -isFunky ps = case BI.toForeignPtr ps of - (x,s,l) -> - unsafePerformIO $ withForeignPtr x $ \p-> - (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l) - -foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char - :: Ptr Word8 -> CInt -> IO CInt +isFunky ps = 0 `B.elem` ps || 26 `B.elem` ps ------------------------------------------------------------------------ --- ByteString rewrites break (=='x') to breakByte 'x' --- break ((==) x) = breakChar x --- break (==x) = breakChar x --- - -{- -{-# INLINE breakOnPS #-} -breakOnPS :: Char -> B.ByteString -> (B.ByteString, B.ByteString) -breakOnPS c p = case BC.elemIndex c p of - Nothing -> (p, BC.empty) - Just n -> (B.take n p, B.drop n p) --} - {-# INLINE hashPS #-} hashPS :: B.ByteString -> Int32 -hashPS ps = - case BI.toForeignPtr ps of - (x,s,l) -> - unsafePerformIO $ withForeignPtr x $ \p-> - hash (p `plusPtr` s) l +hashPS = B.foldl' hashByte 0 -hash :: Ptr Word8 -> Int -> IO Int32 -hash = f (0 :: Int32) - where f h _ 0 = return h - f h p n = do x <- peek p - let !h' = fromIntegral x + rotateL h 8 - f h' (p `advancePtr` 1) (n-1) +{-# INLINE hashByte #-} +hashByte :: Int32 -> Word8 -> Int32 +hashByte h x = fromIntegral x + rotateL h 8 {-# INLINE substrPS #-} substrPS :: B.ByteString -> B.ByteString -> Maybe Int substrPS tok str | B.null tok = Just 0 | B.length tok > B.length str = Nothing - | otherwise = do n <- BC.elemIndex (BC.head tok) str + | otherwise = do n <- B.elemIndex (B.head tok) str let ttok = B.tail tok reststr = B.drop (n+1) str if ttok == B.take (B.length ttok) reststr @@ -238,49 +163,31 @@ Nothing -> Nothing Just n -> Just (B.take n p, B.drop (n+1) p) --- TODO: rename +------------------------------------------------------------------------ +-- linesPS and unlinesPS + {-# INLINE linesPS #-} linesPS :: B.ByteString -> [B.ByteString] linesPS ps | B.null ps = [B.empty] | otherwise = BC.split '\n' ps -{- QuickCheck property: - -import Test.QuickCheck -import qualified Data.ByteString.Char8 as BC -import Data.Char -instance Arbitrary BC.ByteString where - arbitrary = fmap BC.pack arbitrary -instance Arbitrary Char where - arbitrary = chr `fmap` choose (32,127) -deepCheck = check (defaultConfig { configMaxTest = 10000}) -testLines = deepCheck (\x -> (linesPS x == linesPSOld x)) -linesPSOld ps = case BC.elemIndex '\n' ps of - Nothing -> [ps] - Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -} - -{-| This function acts exactly like the "Prelude" unlines function, or like -"Data.ByteString.Char8" 'unlines', but with one important difference: it will -produce a string which may not end with a newline! That is: +{-# INLINE unlinesPS #-} +unlinesPS :: [B.ByteString] -> B.ByteString +unlinesPS [] = B.empty +unlinesPS x = B.concat $ intersperse (BC.singleton '\n') x -> unlinesPS ["foo", "bar"] +-- properties of linesPS and unlinesPS -evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for -'linesPS' as well. +prop_unlinesPS_linesPS_left_inverse :: B.ByteString -> Bool +prop_unlinesPS_linesPS_left_inverse x = unlinesPS (linesPS x) == x -TODO: rename this function. -} -unlinesPS :: [B.ByteString] -> B.ByteString -unlinesPS [] = BC.empty -unlinesPS x = BC.init $ BC.unlines x -{-# INLINE unlinesPS #-} -{- QuickCheck property: +prop_linesPS_length :: B.ByteString -> Bool +prop_linesPS_length x = length (linesPS x) == length (BC.elemIndices '\n' x) + 1 -testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x)) -unlinesPSOld ss = BC.concat $ intersperse_newlines ss - where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s) - intersperse_newlines s = s - newline = BC.pack "\n" -} +prop_unlinesPS_length :: [B.ByteString] -> Bool +prop_unlinesPS_length xs = + B.length (unlinesPS xs) == if null xs then 0 else sum (map B.length xs) + length xs - 1 -- ----------------------------------------------------------------------------- -- gzReadFilePS @@ -293,17 +200,12 @@ gzDecompress mbufsize = -- This is what the code would be without the bad CRC recovery logic: -- return . BL.toChunks . GZ.decompressWith decompressParams -#if MIN_VERSION_zlib(0,6,0) decompressWarn (ZI.decompressST ZI.gzipFormat decompressParams) -#else - toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams -#endif where decompressParams = case mbufsize of Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize } Nothing -> GZ.defaultDecompressParams -#if MIN_VERSION_zlib(0,6,0) decompressWarn :: (forall s . ZI.DecompressStream (ST s)) -> BL.ByteString -> ([B.ByteString], Bool) decompressWarn = ZI.foldDecompressStreamWithInput (\x ~(xs, b) -> (x:xs, b)) @@ -312,37 +214,18 @@ else error "trailing data at end of compressed stream" ) handleBad -#else - toListWarn :: ZI.DecompressStream -> ([B.ByteString], Bool) - toListWarn = foldDecompressStream (\x ~(xs, b) -> (x:xs, b)) ([], False) handleBad - -- cut and paste from Zlib since it's not currently exported (interface not yet certain) - foldDecompressStream :: (B.ByteString -> a -> a) -> a - -> (ZI.DecompressError -> String -> a) - -> ZI.DecompressStream -> a - foldDecompressStream chunk end err = fold - where - fold ZI.StreamEnd = end - fold (ZI.StreamChunk bs stream) = chunk bs (fold stream) - fold (ZI.StreamError code msg) = err code msg -#endif - -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be -- produced. Trap bad CRC messages, run the specified action to report that it happened, -- but continue on the assumption that the data is valid. -#if MIN_VERSION_zlib(0,6,0) handleBad (ZI.DataFormatError "incorrect data check") = ([], True) handleBad e = error (show e) -#else - handleBad ZI.DataError "incorrect data check" = ([], True) - handleBad _ msg = error msg -#endif isGZFile :: FilePath -> IO (Maybe Int) isGZFile f = do h <- openBinaryFile f ReadMode header <- B.hGet h 2 - if header /= BC.pack "\31\139" + if header /= B.pack [31,139] then do hClose h return Nothing else do hSeek h SeekFromEnd (-4) @@ -394,7 +277,7 @@ rest <- B.hGetContents stdin let allStdin = B.concat [header,rest] return $ - if header /= BC.pack "\31\139" + if header /= B.pack [31,139] then allStdin else let decompress = fst . gzDecompress Nothing compressed = BL.fromChunks [allStdin] @@ -409,12 +292,12 @@ readSegment :: FileSegment -> IO BL.ByteString readSegment (f,range) = do bs <- tryToRead - `catch` (\(_::SomeException) -> do - size <- Bundled.fileSize `fmap` Bundled.getFileStatus f + `catchIOError` (\_ -> do + size <- fileSize `fmap` getSymbolicLinkStatus f if size == 0 - then return BC.empty + then return B.empty else performGC >> tryToRead) - return $ BL8.fromChunks [bs] + return $ BL.fromChunks [bs] where tryToRead = case range of @@ -435,8 +318,7 @@ -- be written to swap. If you read many small files, mmapFilePS will be -- less memory-efficient than readFilePS, since each mmapFilePS takes up a -- separate page of memory. Also, you can run into bus errors if the file --- is modified. NOTE: as with 'readFilePS', the string representation in --- the file is assumed to be ISO-8859-1. +-- is modified. mmapFilePS :: FilePath -> IO B.ByteString #if mingw32_HOST_OS @@ -444,7 +326,7 @@ #else mmapFilePS f = mmapFileByteString f Nothing - `catch` (\(_ :: SomeException) -> do + `catchIOError` (\_ -> do size <- fileSize `fmap` getSymbolicLinkStatus f if size == 0 then return B.empty @@ -454,97 +336,85 @@ -- ------------------------------------------------------------------------- -- fromPS2Hex -foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex - :: Ptr Word8 -> Ptr Word8 -> CInt -> IO () - fromPS2Hex :: B.ByteString -> B.ByteString -fromPS2Hex ps = case BI.toForeignPtr ps of - (x,s,l) -> - BI.unsafeCreate (2*l) $ \p -> withForeignPtr x $ \f -> - conv_to_hex p (f `plusPtr` s) $ fromIntegral l +fromPS2Hex = BC.map toLower . b16Enc -- ------------------------------------------------------------------------- -- fromHex2PS -foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex - :: Ptr Word8 -> Ptr Word8 -> CInt -> IO () - fromHex2PS :: B.ByteString -> B.ByteString -fromHex2PS ps = case BI.toForeignPtr ps of - (x,s,l) -> - BI.unsafeCreate (l `div` 2) $ \p -> withForeignPtr x $ \f -> - conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2) +fromHex2PS s = + case b16Dec $ BC.map toUpper s of + Right (result, remaining) + | B.null remaining -> result + _ -> error "fromHex2PS: input is not hex encoded" +propHexConversion :: B.ByteString -> Bool +propHexConversion x = fromHex2PS (fromPS2Hex x) == x + -- ------------------------------------------------------------------------- -- betweenLinesPS --- | betweenLinesPS returns the B.ByteString between the two lines given, +-- | Return the B.ByteString between the two lines given, -- or Nothing if they do not appear. - betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString -> Maybe B.ByteString -betweenLinesPS start end ps - = case break (start ==) (linesPS ps) of - (_, _:rest@(bs1:_)) -> - case BI.toForeignPtr bs1 of - (ps1,s1,_) -> - case break (end ==) rest of - (_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ fromForeignPtr ps1 s1 (s2 - s1) - _ -> Nothing - _ -> Nothing - --- ------------------------------------------------------------------------- --- breakAfterNthNewline - -breakAfterNthNewline :: Int -> B.ByteString - -> Maybe (B.ByteString, B.ByteString) -breakAfterNthNewline 0 the_ps | B.null the_ps = Just (B.empty, B.empty) - | otherwise = Just (B.empty, the_ps) -breakAfterNthNewline n the_ps = - go n (B.elemIndices (BI.c2w '\n') the_ps) - where go 0 [] = Just (the_ps, B.empty) - go _ [] = Nothing - go 1 (i:_) = Just $ B.splitAt (i+1) the_ps - go !m (_:is) = go (m-1) is - --- ------------------------------------------------------------------------- --- breakBeforeNthNewline +betweenLinesPS start end ps = + case B.breakSubstring start_line ps of + (before_start, at_start) + | not (B.null at_start) + , B.null before_start || BC.last before_start == '\n' -> + case B.breakSubstring end_line (B.drop (B.length start_line) at_start) of + (before_end, at_end) + | not (B.null at_end) + , B.null before_end || BC.last before_end == '\n' -> Just before_end + | otherwise -> Nothing + | otherwise -> Nothing + where + start_line = BC.snoc start '\n' + end_line = BC.snoc end '\n' -breakBeforeNthNewline :: Int -> B.ByteString -> (B.ByteString, B.ByteString) -breakBeforeNthNewline 0 the_ps - | B.null the_ps = (B.empty, B.empty) -breakBeforeNthNewline n the_ps = - go n (B.elemIndices (BI.c2w '\n') the_ps) - where go _ [] = (the_ps, B.empty) - go 0 (i:_) = B.splitAt i the_ps - go !m (_:is) = go (m-1) is +-- | Simpler but less efficient variant of 'betweenLinesPS'. +spec_betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString + -> Maybe B.ByteString +spec_betweenLinesPS start end ps = + case break (start ==) (linesPS ps) of + (_, _:after_start) -> + case break (end ==) after_start of + (before_end, _:_) -> + Just $ BC.unlines before_end + _ -> Nothing + _ -> Nothing -- | Test if a ByteString is made of ascii characters isAscii :: B.ByteString -> Bool isAscii = B.all (< 128) --- | Decode a ByteString to a String according to the current locale --- unsafePerformIO in the locale function is ratified by the fact that GHC 6.12 --- and above also supply locale conversion with functions with a pure type. --- Unrecognized byte sequences in the input are skipped. +-- * Encoding functions + +-- Use of 'unsafePerformIO' is ratified by the fact that these +-- really are pure functions. + +-- | Decode a 'ByteString' containing UTF-8 to a 'String'. Decoding errors +-- are flagged with the U+FFFD character. +unpackPSFromUTF8 :: B.ByteString -> String +unpackPSFromUTF8 = unsafePerformIO . decodeUtf8 + +-- | Encode a 'String' to a 'ByteString' using UTF-8. +packStringToUTF8 :: String -> B.ByteString +packStringToUTF8 = unsafePerformIO . encodeUtf8 + +-- | Decode a 'ByteString' to a 'String' according to the current locale, +-- using lone surrogates for un-decodable bytes. decodeLocale :: B.ByteString -> String decodeLocale = unsafePerformIO . decode --- | Encode a String to a ByteString with char8 encoding (i.e., the values of the --- characters become the values of the bytes; if a character value is greater --- than 255, its byte becomes the character value modulo 256) -encodeChar8 :: String -> B.ByteString -encodeChar8 = B.pack . map (fromIntegral . ord) - --- | Encode a String to a ByteString according to the current locale +-- | Encode a 'String' to a 'ByteString' according to the current locale, +-- converting lone surrogates back to the original byte. If that +-- fails (because the locale does not support the full unicode range) +-- then encode using utf-8, assuming that the un-ecodable characters +-- come from patch meta data. +-- +-- See also 'Darcs.UI.Commands.setEnvCautiously'. encodeLocale :: String -> B.ByteString -encodeLocale = unsafePerformIO . encode - --- | Take a 'String' that represents byte values and re-decode it acording to --- the current locale. --- Note: we globally enforce char8 as the default encoding, see "Main" and --- "Darcs.Utils". This means we get command line args and environment variables --- as 'String's with char8 encoding, too. So we need this to convert such --- strings back to the user's encoding. -decodeString :: String -> IO String -decodeString = decode . encodeChar8 +encodeLocale s = unsafePerformIO $ encode s `catchIOError` (\_ -> encodeUtf8 s) diff --git a/src/Darcs/Util/CommandLine.hs b/src/Darcs/Util/CommandLine.hs --- a/src/Darcs/Util/CommandLine.hs +++ b/src/Darcs/Util/CommandLine.hs @@ -28,28 +28,7 @@ -- the commandline can end with "%<" specifying that the command -- expects input on stdin. -- --- Some tests for the parser. --- --- > formatTable = [('s',""), --- > ('a',"")] --- > --- > testParser :: (Show a, Eq a) => Parser a -> String -> a -> a --- > testParser p s ok = case parse p "" s of --- > Left e -> error $ "Parser failed with: " ++ (show e) --- > Right res -> if res == ok --- > then res --- > else error $ "Parser failed: got " --- > ++ (show res) ++ ", expected " --- > ++ (show ok) --- > --- > testCases = [("a b",(["a","b"], False)), --- > ("a b %<",(["a","b"], True)), --- > ("a b %< ",(["a","b"], True)), --- > ("\"arg0 contains spaces \\\"quotes\\\"\" b", --- > (["arg0 contains spaces \"quotes\"","b"],False)), --- > ("a %s %<",(["a",""], True))] --- > --- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases +-- See Darcs.Test.Misc.CommandLine for tests. module Darcs.Util.CommandLine ( parseCmd diff --git a/src/Darcs/Util/Crypt/SHA1.hs b/src/Darcs/Util/Crypt/SHA1.hs deleted file mode 100644 --- a/src/Darcs/Util/Crypt/SHA1.hs +++ /dev/null @@ -1,225 +0,0 @@ --- Copyright (C) 2001, 2004 Ian Lynagh --- --- This 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. - --- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -{-# LANGUAGE CPP #-} - --- | --- Module : Darcs.Util.Crypt.SHA1 --- Copyright : 2001, 2004 Ian Lynagh --- License : GPL --- Maintainer : darcs-devel@darcs.net --- Stability : experimental --- Portability : portable - -module Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1(..), showAsHex, sha1Xor, zero ) where - -import Prelude () -import Darcs.Prelude - -import Darcs.Util.ByteString (unsafeWithInternals) -import qualified Data.ByteString as B (ByteString, pack, length, concat) -import Data.Binary ( Binary(..) ) -import Data.Char (intToDigit) -import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR) -import Data.Word (Word8, Word32) -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Marshal.Array (advancePtr) -import Foreign.Storable (peek, poke) -import System.IO.Unsafe (unsafePerformIO) - -data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32 - deriving (Eq,Ord) -data XYZ = XYZ !Word32 !Word32 !Word32 - -instance Show SHA1 where - show (SHA1 a b c d e) = concatMap showAsHex [a, b, c, d, e] - -instance Binary SHA1 where - put (SHA1 a b c d e) = put a >> put b >> put c >> put d >> put e - get = do a <- get ; b <- get ; c <- get ; d <- get ; e <- get ; return (SHA1 a b c d e) - -sha1Xor :: SHA1 -> SHA1 -> SHA1 -sha1Xor (SHA1 a1 b1 c1 d1 e1) (SHA1 a2 b2 c2 d2 e2) = - SHA1 (a1 `xor` a2) (b1 `xor` b2) (c1 `xor` c2) (d1 `xor` d2) (e1 `xor` e2) - -zero :: SHA1 -zero = SHA1 0 0 0 0 0 - -sha1PS:: B.ByteString -> SHA1 -sha1PS s = abcde' - where s1_2 = sha1Step12PadLength s - abcde = sha1Step3Init - abcde' = unsafePerformIO - $ unsafeWithInternals s1_2 (\ptr len -> - do let ptr' = castPtr ptr -#ifndef BIGENDIAN - fiddleEndianness ptr' len -#endif - sha1Step4Main abcde ptr' len) - -fiddleEndianness :: Ptr Word32 -> Int -> IO () -fiddleEndianness p 0 = p `seq` return () -fiddleEndianness p n - = do x <- peek p - poke p $ shiftL x 24 - .|. shiftL (x .&. 0xff00) 8 - .|. (shiftR x 8 .&. 0xff00) - .|. shiftR x 24 - fiddleEndianness (p `advancePtr` 1) (n - 4) - --- sha1Step12PadLength assumes the length is at most 2^61. --- This seems reasonable as the Int used to represent it is normally 32bit, --- but obviously could go wrong with large inputs on 64bit machines. --- The B.ByteString library should probably move to Word64s if this is an --- issue, though. - -sha1Step12PadLength :: B.ByteString -> B.ByteString -sha1Step12PadLength s - = let len = B.length s - num_nuls = (55 - len) `mod` 64 - padding = 128:replicate num_nuls 0 - len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8) - in B.concat [s, B.pack padding, B.pack len_w8s] - -sizeSplit :: Int -> Integer -> [Word8] -sizeSplit 0 _ = [] -sizeSplit p n = fromIntegral d:sizeSplit (p-1) n' - where (n', d) = divMod n 256 - -sha1Step3Init :: SHA1 -sha1Step3Init = SHA1 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 - -sha1Step4Main :: SHA1 -> Ptr Word32 -> Int -> IO SHA1 -sha1Step4Main abcde _ 0 = return $! abcde -sha1Step4Main (SHA1 a0@a b0@b c0@c d0@d e0@e) s len - = do - (e, b) <- doit f1 0x5a827999 (x 0) a b c d e - (d, a) <- doit f1 0x5a827999 (x 1) e a b c d - (c, e) <- doit f1 0x5a827999 (x 2) d e a b c - (b, d) <- doit f1 0x5a827999 (x 3) c d e a b - (a, c) <- doit f1 0x5a827999 (x 4) b c d e a - (e, b) <- doit f1 0x5a827999 (x 5) a b c d e - (d, a) <- doit f1 0x5a827999 (x 6) e a b c d - (c, e) <- doit f1 0x5a827999 (x 7) d e a b c - (b, d) <- doit f1 0x5a827999 (x 8) c d e a b - (a, c) <- doit f1 0x5a827999 (x 9) b c d e a - (e, b) <- doit f1 0x5a827999 (x 10) a b c d e - (d, a) <- doit f1 0x5a827999 (x 11) e a b c d - (c, e) <- doit f1 0x5a827999 (x 12) d e a b c - (b, d) <- doit f1 0x5a827999 (x 13) c d e a b - (a, c) <- doit f1 0x5a827999 (x 14) b c d e a - (e, b) <- doit f1 0x5a827999 (x 15) a b c d e - (d, a) <- doit f1 0x5a827999 (m 16) e a b c d - (c, e) <- doit f1 0x5a827999 (m 17) d e a b c - (b, d) <- doit f1 0x5a827999 (m 18) c d e a b - (a, c) <- doit f1 0x5a827999 (m 19) b c d e a - (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e - (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d - (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c - (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b - (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a - (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e - (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d - (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c - (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b - (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a - (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e - (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d - (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c - (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b - (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a - (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e - (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d - (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c - (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b - (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a - (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e - (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d - (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c - (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b - (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a - (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e - (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d - (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c - (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b - (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a - (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e - (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d - (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c - (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b - (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a - (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e - (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d - (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c - (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b - (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a - (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e - (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d - (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c - (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b - (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a - (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e - (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d - (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c - (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b - (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a - (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e - (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d - (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c - (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b - (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a - (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e - (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d - (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c - (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b - (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a - let abcde' = SHA1 (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e) - sha1Step4Main abcde' (s `advancePtr` 16) (len - 64) - where {-# INLINE f1 #-} - f1 (XYZ x y z) = (x .&. y) .|. (complement x .&. z) - {-# INLINE f2 #-} - f2 (XYZ x y z) = x `xor` y `xor` z - {-# INLINE f3 #-} - f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) - {-# INLINE x #-} - x n = peek (s `advancePtr` n) - {-# INLINE m #-} - m n = do let base = s `advancePtr` (n .&. 15) - x0 <- peek base - x1 <- peek (s `advancePtr` ((n - 14) .&. 15)) - x2 <- peek (s `advancePtr` ((n - 8) .&. 15)) - x3 <- peek (s `advancePtr` ((n - 3) .&. 15)) - let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1 - poke base res - return res - {-# INLINE doit #-} - doit f k i a b c d e = a `seq` c `seq` - do i' <- i - return (rotateL a 5 + f (XYZ b c d) + e + i' + k, - rotateL b 30) - -showAsHex :: Word32 -> String -showAsHex n = showIt 8 n "" - where - showIt :: Int -> Word32 -> String -> String - showIt 0 _ r = r - showIt i x r = case quotRem x 16 of - (y, z) -> let c = intToDigit (fromIntegral z) - in c `seq` showIt (i-1) y (c:r) diff --git a/src/Darcs/Util/Crypt/SHA256.hs b/src/Darcs/Util/Crypt/SHA256.hs deleted file mode 100644 --- a/src/Darcs/Util/Crypt/SHA256.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Darcs.Util.Crypt.SHA256 ( sha256sum ) where - -import Prelude () -import Darcs.Prelude - -import Crypto.Hash.SHA256 ( hash ) -import Data.ByteString ( ByteString ) -import Data.ByteString.Base16 ( encode ) -import Data.ByteString.Char8 ( unpack ) - -sha256sum :: ByteString -> String -sha256sum = unpack . encode . hash diff --git a/src/Darcs/Util/DateMatcher.hs b/src/Darcs/Util/DateMatcher.hs --- a/src/Darcs/Util/DateMatcher.hs +++ b/src/Darcs/Util/DateMatcher.hs @@ -31,6 +31,9 @@ -- for debugging only , DateMatcher(..) , getMatchers + -- for testing (GHCi, etc) + , testDate + , testDateAt ) where import Prelude () @@ -47,7 +50,7 @@ ( parseDate, englishDateTime, englishInterval, englishLast , iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz , MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime - , unsetTime + , unsetTime, readUTCDate ) -- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@ @@ -179,6 +182,12 @@ tillEof p = do { x <- p; eof; return x } parseDateWith p = parse (tillEof p) "" d + +--- The following functions are for toying around in GHCi +--- +--- > testDate "2008/05/22 10:34" +--- > testDateAt "2006-03-22 09:36" "2008/05/22 10:34" + -- | 'tryMatchers' @ms@ returns the first successful match in @ms@ -- It is an error if there are no matches tryMatchers :: [DateMatcher] -> CalendarTime -> Bool @@ -190,3 +199,32 @@ now :: IO CalendarTime now = getClockTime >>= toCalendarTime + +-- | 'testDate' @d@ shows the possible interpretations +-- for the date string @d@ and how they match against +-- the current date +testDate :: String -> IO () +testDate d = do cnow <- now + testDateAtCal cnow d + +-- | 'testDate' @iso d@ shows the possible interpretations +-- for the date string @d@ and how they match against +-- the date represented by the ISO 8601 string @iso@ +testDateAt :: String -> String -> IO () +testDateAt iso = testDateAtCal (readUTCDate iso) + +-- | helper function for 'testDate' and 'testDateAt' +testDateAtCal :: CalendarTime -> String -> IO () +testDateAtCal c d = + do ms <- getMatchers d + putStr . unlines . map (showMatcher c) $ ms + +-- | 'showMatcher' @c dm@ tells us if @dm@ applies to +-- 'CalendarTime' @c@; or if @dm@ just represents the +-- failure to parse a date, in which case @c@ is moot. +showMatcher :: CalendarTime -> DateMatcher -> String +showMatcher cnow (DM n p m) = + "==== " ++ n ++ " ====\n" ++ + (case p of + Left err -> shows err "" + Right x -> show x ++ "\n" ++ show (m x cnow)) diff --git a/src/Darcs/Util/DateTime.hs b/src/Darcs/Util/DateTime.hs --- a/src/Darcs/Util/DateTime.hs +++ b/src/Darcs/Util/DateTime.hs @@ -2,7 +2,6 @@ -- -- BSD3 -{-# LANGUAGE CPP #-} module Darcs.Util.DateTime ( getCurrentTime, toSeconds , formatDateTime, fromClockTime, parseDateTime, startOfTime diff --git a/src/Darcs/Util/Diff/Myers.hs b/src/Darcs/Util/Diff/Myers.hs --- a/src/Darcs/Util/Diff/Myers.hs +++ b/src/Darcs/Util/Diff/Myers.hs @@ -16,8 +16,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - -- | -- Module : Darcs.Util.Diff.Myers -- Copyright : 2003 David Roundy @@ -72,8 +70,6 @@ import Data.Array.Base import Data.Array.Unboxed import qualified Data.Map as Map ( lookup, empty, insertWith ) - -#include "impossible.h" -- | create a list of changes between a and b, each change has the form -- (starta, lima, startb, limb) which means that a[starta, lima) diff --git a/src/Darcs/Util/Diff/Patience.hs b/src/Darcs/Util/Diff/Patience.hs --- a/src/Darcs/Util/Diff/Patience.hs +++ b/src/Darcs/Util/Diff/Patience.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- Copyright (C) 2002,2008-2009 David Roundy -- -- This program is free software; you can redistribute it and/or modify @@ -34,8 +32,6 @@ ( Map, lookup, insertWith, empty, elems ) import qualified Data.Hashable as H ( hash ) import Darcs.Util.Diff.Myers (initP, aLen, PArray, getSlice) - -#include "impossible.h" empty :: HunkMap empty = HunkMapInfo 0 M.empty diff --git a/src/Darcs/Util/Download.hs b/src/Darcs/Util/Download.hs --- a/src/Darcs/Util/Download.hs +++ b/src/Darcs/Util/Download.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- using isEmptyChan {-# LANGUAGE CPP #-} -- | @@ -27,12 +26,13 @@ import Control.Arrow ( (&&&) ) import Control.Concurrent ( forkIO ) -import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, - Chan ) +import Control.Concurrent.STM.TChan + ( isEmptyTChan, newTChanIO, readTChan, writeTChan, TChan ) import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar ) import Control.Monad ( unless, when ) import Control.Monad.State ( evalStateT, get, modify, put, StateT ) +import Control.Monad.STM ( atomically ) import Control.Monad.Trans ( liftIO ) import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) import Data.Map ( Map ) @@ -55,8 +55,6 @@ import qualified Darcs.Util.Download.HTTP as HTTP #endif -#include "impossible.h" - {-# NOINLINE maxPipelineLengthRef #-} maxPipelineLengthRef :: IORef Int maxPipelineLengthRef = unsafePerformIO $ do @@ -76,15 +74,15 @@ urlNotifications = unsafePerformIO $ newMVar Map.empty {-# NOINLINE urlChan #-} -urlChan :: Chan UrlRequest +urlChan :: TChan UrlRequest urlChan = unsafePerformIO $ do - ch <- newChan + ch <- newTChanIO _ <- forkIO (urlThread ch) return ch type UrlM a = StateT UrlState IO a -urlThread :: Chan UrlRequest -> IO () +urlThread :: TChan UrlRequest -> IO () urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk) @@ -93,7 +91,7 @@ urlThread' :: UrlM () urlThread' = do - empty <- liftIO $ isEmptyChan ch + empty <- liftIO $ atomically $ isEmptyTChan ch (l, w) <- (pipeLength &&& waitToStart) `fmap` get -- If we've got UrlRequests waiting on the chan, or there's nothing -- waiting to start and nothing already downloading, we just block @@ -108,10 +106,10 @@ readAllRequests :: IO [UrlRequest] readAllRequests = do - r <- readChan ch + r <- atomically $ readTChan ch debugMessage $ "URL.urlThread (" ++ url r ++ "\n"++ "-> " ++ file r ++ ")" - empty <- isEmptyChan ch + empty <- atomically $ isEmptyTChan ch reqs <- if not empty then readAllRequests else return [] @@ -205,7 +203,7 @@ v <- newEmptyMVar old_mv <- modifyMVar urlNotifications (return . swap . Map.insertLookupWithKey (\_k _n old -> old) u v) case old_mv of - Nothing -> writeChan urlChan $ UrlRequest u f c p -- ok, new URL + Nothing -> atomically $ writeTChan urlChan $ UrlRequest u f c p -- ok, new URL Just _ -> debugMessage $ "URL.copyUrlWithPriority already in progress, skip (" ++ u ++ "\n" ++ "-> " ++ f ++ ")" createDownloadFileName :: FilePath -> UrlState -> FilePath diff --git a/src/Darcs/Util/Encoding.hs b/src/Darcs/Util/Encoding.hs --- a/src/Darcs/Util/Encoding.hs +++ b/src/Darcs/Util/Encoding.hs @@ -23,27 +23,47 @@ -- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. {-# LANGUAGE CPP #-} module Darcs.Util.Encoding - ( encode,decode + ( encode, decode + , encodeUtf8, decodeUtf8 ) where import Prelude () import Darcs.Prelude -import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import GHC.IO.Encoding ( TextEncoding, mkTextEncoding ) +import GHC.Foreign ( withCStringLen, peekCStringLen ) #ifdef WIN32 -import qualified Darcs.Util.Encoding.Win32 as Backend ( encode, decode ) +import Darcs.Util.Encoding.Win32 ( encode, decode ) #else -import qualified Darcs.Util.Encoding.IConv as Backend ( encode, decode ) + +import GHC.IO.Encoding ( getFileSystemEncoding ) + +-- | Encode a 'String' into a 'B.ByteString' according to the user's locale +-- with the ghc specific //ROUNDTRIP feature added. This means the argument +-- is allowed to contain non-Unicode 'Char's as produced by 'decode'. +encode :: String -> IO B.ByteString +encode s = getFileSystemEncoding >>= textEncode s + +-- | Decode a 'B.ByteString' into a 'String' according to the user's locale +-- with the ghc specific //ROUNDTRIP feature added. This means the result +-- may contain 'Char's that are not valid Unicode in case decoding with the +-- user's locale fails. +decode :: B.ByteString -> IO String +decode bs = getFileSystemEncoding >>= textDecode bs + #endif --- functions redefined to add haddock (there might well be a better way!) +encodeUtf8 :: String -> IO B.ByteString +encodeUtf8 s = mkTextEncoding "UTF-8//TRANSLIT" >>= textEncode s --- | Encode a Unicode 'String' into a 'ByteString' suitable for the current --- console. -encode :: String -> IO ByteString -encode = Backend.encode +decodeUtf8 :: B.ByteString -> IO String +decodeUtf8 bs = mkTextEncoding "UTF-8//TRANSLIT" >>= textDecode bs --- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'. -decode :: ByteString -> IO String -decode = Backend.decode +textEncode :: String -> TextEncoding -> IO B.ByteString +textEncode s enc = withCStringLen enc s B.packCStringLen + +textDecode :: B.ByteString -> TextEncoding -> IO String +textDecode bs enc = B.useAsCStringLen bs (peekCStringLen enc) + diff --git a/src/Darcs/Util/Encoding/IConv.hsc b/src/Darcs/Util/Encoding/IConv.hsc deleted file mode 100644 --- a/src/Darcs/Util/Encoding/IConv.hsc +++ /dev/null @@ -1,185 +0,0 @@ --- Copyright 2007-2009, Judah Jacobson. --- All Rights Reserved. - --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: - --- - Redistribution of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. - --- - Redistribution 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. - --- THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR OR THE 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. -{-# LANGUAGE ForeignFunctionInterface #-} -module Darcs.Util.Encoding.IConv - ( encode, decode - ) where - -import Foreign.C - ( CString, CSize(..), CInt(..) - , peekCAString, withCAString - , Errno(..), getErrno, throwErrno, eINVAL, e2BIG - ) -import Foreign - ( Ptr, castPtr, nullPtr, plusPtr - , peek, maybePeek - , with, maybeWith - , ForeignPtr, withForeignPtr, newForeignPtr - , FunPtr - , #type nl_item - , Word8 - ) -import Control.Exception ( bracket ) -import Data.ByteString ( ByteString, useAsCStringLen, append ) -import Data.ByteString.Internal ( createAndTrim' ) -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8 -import Data.Maybe ( fromMaybe ) - -#include -#include -#include "h_iconv.h" - -getLocaleCodeset :: IO String -getLocaleCodeset = bracket (setLocale (Just "")) setLocale (const getCodeset) - -encode :: String -> IO ByteString -encode str = getLocaleCodeset >>= \codeset -> openEncoder codeset >>= ($ str) - -decode :: ByteString -> IO String -decode str = getLocaleCodeset >>= \codeset -> openDecoder codeset >>= ($ str) - -openEncoder :: String -> IO (String -> IO ByteString) -openEncoder codeset = do - encodeT <- iconvOpen codeset "UTF-8" - return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString - -openDecoder :: String -> IO (ByteString -> IO String) -openDecoder codeset = do - decodeT <- iconvOpen "UTF-8" codeset - return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT - -dropUTF8Char :: ByteString -> ByteString -dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons - -replacement :: Word8 -replacement = toEnum (fromEnum '?') - --- handle errors by dropping unuseable chars. -simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString -simpleIConv dropper t bs = do - (cs,result) <- iconv t bs - case result of - Invalid rest -> continueOnError cs rest - Incomplete rest -> continueOnError cs rest - _ -> return cs - where - continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`)) - $ simpleIConv dropper t (dropper rest) - ---------------------- --- Setting the locale - -foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString - -setLocale :: Maybe String -> IO (Maybe String) -setLocale oldLocale = (maybeWith withCAString) oldLocale $ \loc_p -> do - c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString - ------------------ --- Getting the encoding - -type NLItem = #type nl_item - -foreign import ccall nl_langinfo :: NLItem -> IO CString - -getCodeset :: IO String -getCodeset = do - str <- nl_langinfo (#const CODESET) >>= peekCAString - -- check for codesets which may be returned by Solaris, but not understood - -- by GNU iconv. - if str `elem` ["","646"] - then return "ISO-8859-1" - else return str - ----------------- --- Iconv - --- TODO: This may not work on platforms where iconv_t is not a pointer. -type IConvT = ForeignPtr () -type IConvTPtr = Ptr () - -foreign import ccall "darcs_iconv_open" iconv_open - :: CString -> CString -> IO IConvTPtr - -iconvOpen :: String -> String -> IO IConvT -iconvOpen destName srcName = withCAString destName $ \dest -> - withCAString srcName $ \src -> do - res <- iconv_open dest src - if res == nullPtr `plusPtr` (-1) - then throwErrno $ "iconvOpen " - ++ show (srcName,destName) - -- list the two it couldn't convert between? - else newForeignPtr iconv_close res - --- really this returns a CInt, but it's easiest to just ignore that, I think. -foreign import ccall "& darcs_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ()) - -foreign import ccall "darcs_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize - -> Ptr CString -> Ptr CSize -> IO CSize - -data Result = Successful - | Invalid ByteString - | Incomplete ByteString - deriving Show - -iconv :: IConvT -> ByteString -> IO (ByteString,Result) -iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) -> - with inPtr $ \inBuff -> - with (toEnum inBuffLen) $ \inBytesLeft -> do - out <- loop inBuffLen (castPtr inBuff) inBytesLeft - return out - where - -- TODO: maybe a better algorithm for increasing the buffer size? - -- and also maybe a different starting buffer size? - biggerBuffer = (+1) - loop outSize inBuff inBytesLeft = do - (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft - inLeft <- fmap fromEnum $ peek inBytesLeft - let rest = B.drop (B.length inStr - inLeft) inStr - case errno of - Nothing -> return (bs,Successful) - Just err - | err == e2BIG -> do -- output buffer too small - (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft - -- TODO: is this efficient enough? - return (bs `append` bs', result) - | err == eINVAL -> return (bs,Incomplete rest) - | otherwise -> return (bs, Invalid rest) - -partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno) -partialIconv cd outSize inBuff inBytesLeft = - withForeignPtr cd $ \cd_p -> - createAndTrim' outSize $ \outPtr -> - with outPtr $ \outBuff -> - with (toEnum outSize) $ \outBytesLeft -> do - -- ignore the return value; checking the errno is more reliable. - _ <- c_iconv cd_p inBuff inBytesLeft (castPtr outBuff) outBytesLeft - outLeft <- fmap fromEnum $ peek outBytesLeft - inLeft <- peek inBytesLeft - errno <- if inLeft > 0 - then fmap Just getErrno - else return Nothing - return (0,outSize - outLeft,errno) - diff --git a/src/Darcs/Util/Encoding/Win32.hs b/src/Darcs/Util/Encoding/Win32.hs --- a/src/Darcs/Util/Encoding/Win32.hs +++ b/src/Darcs/Util/Encoding/Win32.hs @@ -39,9 +39,12 @@ ( CodePage, nullPtr, getConsoleCP, getACP , LPCSTR, LPWSTR, LPCWSTR, LPBOOL, DWORD ) +-- | Encode a Unicode 'String' into a 'ByteString' suitable for the current +-- console. encode :: String -> IO B.ByteString encode str = getCodePage >>= flip unicodeToCodePage str +-- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'. decode :: B.ByteString -> IO String decode str = getCodePage >>= flip codePageToUnicode str diff --git a/src/Darcs/Util/Environment.hs b/src/Darcs/Util/Environment.hs deleted file mode 100644 --- a/src/Darcs/Util/Environment.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Darcs.Util.Environment - ( - maybeGetEnv - ) where - -import Prelude () -import Darcs.Prelude - -import System.Environment ( getEnv ) - -import Darcs.Util.Exception ( catchall ) - -maybeGetEnv :: String - -> IO (Maybe String) -maybeGetEnv s = fmap Just (getEnv s) `catchall` return Nothing -- err can only be isDoesNotExist diff --git a/src/Darcs/Util/External.hs b/src/Darcs/Util/External.hs --- a/src/Darcs/Util/External.hs +++ b/src/Darcs/Util/External.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} module Darcs.Util.External ( cloneTree , cloneFile diff --git a/src/Darcs/Util/File.hs b/src/Darcs/Util/File.hs --- a/src/Darcs/Util/File.hs +++ b/src/Darcs/Util/File.hs @@ -24,12 +24,11 @@ import System.Directory ( removeFile, getHomeDirectory, getAppUserDataDirectory, doesDirectoryExist, createDirectory, getDirectoryContents ) -import System.IO.Error ( isDoesNotExistError ) -import System.Posix.Files( getSymbolicLinkStatus, FileStatus, isDirectory +import System.IO.Error ( isDoesNotExistError, catchIOError ) +import System.Posix.Files( getSymbolicLinkStatus, FileStatus, isDirectory ) #ifndef WIN32 - , setFileMode, ownerModes +import System.Posix.Files( setFileMode, ownerModes ) #endif - ) import System.FilePath.Posix ( () ) import Darcs.Util.Exception ( catchall ) @@ -47,10 +46,9 @@ (\oldwd -> setCurrentDirectory oldwd `catchall` return ()) (const m) -getFileStatus :: FilePath - -> IO (Maybe FileStatus) +getFileStatus :: FilePath -> IO (Maybe FileStatus) getFileStatus f = - Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing + Just `fmap` getSymbolicLinkStatus f `catchIOError` (\_-> return Nothing) doesDirectoryReallyExist :: FilePath -> IO Bool doesDirectoryReallyExist f = diff --git a/src/Darcs/Util/Global.hs b/src/Darcs/Util/Global.hs --- a/src/Darcs/Util/Global.hs +++ b/src/Darcs/Util/Global.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - -- | -- Module : Darcs.Util.Global -- Copyright : 2005 Tomasz Zielonka diff --git a/src/Darcs/Util/Hash.hs b/src/Darcs/Util/Hash.hs --- a/src/Darcs/Util/Hash.hs +++ b/src/Darcs/Util/Hash.hs @@ -1,63 +1,269 @@ --- Copyright (C) 2009-2011 Petr Rockai --- --- BSD3 -{-# LANGUAGE DeriveDataTypeable #-} -module Darcs.Util.Hash( Hash(..) - , encodeBase16, decodeBase16, sha256, rawHash - , match ) where +-- Copyright (C) 2009-2011 Petr Rockai BSD3 +-- Copyright (C) 2001, 2004 Ian Lynagh -import qualified Crypto.Hash.SHA256 as SHA256 ( hash ) -import qualified Data.ByteString as BS +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- TODO switch to cryptonite + +module Darcs.Util.Hash + ( Hash(..) + , encodeBase16, decodeBase16, sha256, sha256sum, rawHash + , match + -- SHA1 related (patch metadata hash) + , sha1PS, SHA1, showAsHex, sha1Xor, sha1zero, sha1short + ) where + +import qualified Crypto.Hash.SHA256 as SHA256 ( hashlazy, hash ) +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Internal as BI ( toForeignPtr ) import qualified Codec.Binary.Base16 as B16 import Data.Maybe( isJust, fromJust ) -import Data.Char( toLower, toUpper ) +import Data.Char( toLower, toUpper, intToDigit ) +import Data.Binary ( Binary(..) ) +import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR) +import Data.Word (Word8, Word32) import Data.Data( Data ) import Data.Typeable( Typeable ) +import Foreign.ForeignPtr ( withForeignPtr ) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Storable (peek, poke) +import System.IO.Unsafe (unsafePerformIO) -data Hash = SHA256 !BS.ByteString - | SHA1 !BS.ByteString + +data Hash = SHA256 !B.ByteString | NoHash deriving (Show, Eq, Ord, Read, Typeable, Data) -base16 :: BS.ByteString -> BS.ByteString -debase16 :: BS.ByteString -> Maybe BS.ByteString +base16 :: B.ByteString -> B.ByteString +debase16 :: B.ByteString -> Maybe B.ByteString -base16 = BS8.map toLower . B16.b16Enc -debase16 bs = case B16.b16Dec $ BS8.map toUpper bs of +base16 = BC.map toLower . B16.b16Enc +debase16 bs = case B16.b16Dec $ BC.map toUpper bs of Right (s, _) -> Just s Left _ -> Nothing -- | Produce a base16 (ascii-hex) encoded string from a hash. This can be -- turned back into a Hash (see "decodeBase16". This is a loss-less process. -encodeBase16 :: Hash -> BS.ByteString +encodeBase16 :: Hash -> B.ByteString encodeBase16 (SHA256 bs) = base16 bs -encodeBase16 (SHA1 bs) = base16 bs -encodeBase16 NoHash = BS.empty +encodeBase16 NoHash = B.empty -- | Take a base16-encoded string and decode it as a "Hash". If the string is -- malformed, yields NoHash. -decodeBase16 :: BS.ByteString -> Hash -decodeBase16 bs | BS.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs) - | BS.length bs == 40 && isJust (debase16 bs) = SHA1 (fromJust $ debase16 bs) +decodeBase16 :: B.ByteString -> Hash +decodeBase16 bs | B.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs) | otherwise = NoHash --- | Compute a sha256 of a (lazy) ByteString. However, although this works --- correctly for any bytestring, it is only efficient if the bytestring only --- has a sigle chunk. +-- | Compute a sha256 of a (lazy) ByteString. sha256 :: BL.ByteString -> Hash -sha256 bits = SHA256 $ SHA256.hash $ BS.concat $ BL.toChunks bits +sha256 bits = SHA256 $ SHA256.hashlazy bits -rawHash :: Hash -> BS.ByteString +-- | Same as previous but general purpose. +sha256sum :: B.ByteString -> String +sha256sum = BC.unpack . base16 . SHA256.hash + +rawHash :: Hash -> B.ByteString rawHash NoHash = error "Cannot obtain raw hash from NoHash." -rawHash (SHA1 s) = s rawHash (SHA256 s) = s match :: Hash -> Hash -> Bool NoHash `match` _ = False _ `match` NoHash = False x `match` y = x == y + +data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32 + deriving (Eq,Ord) +data XYZ = XYZ !Word32 !Word32 !Word32 + +instance Show SHA1 where + show (SHA1 a b c d e) = concatMap showAsHex [a, b, c, d, e] + +instance Binary SHA1 where + put (SHA1 a b c d e) = put a >> put b >> put c >> put d >> put e + get = do a <- get ; b <- get ; c <- get ; d <- get ; e <- get ; return (SHA1 a b c d e) + +sha1Xor :: SHA1 -> SHA1 -> SHA1 +sha1Xor (SHA1 a1 b1 c1 d1 e1) (SHA1 a2 b2 c2 d2 e2) = + SHA1 (a1 `xor` a2) (b1 `xor` b2) (c1 `xor` c2) (d1 `xor` d2) (e1 `xor` e2) + +sha1zero :: SHA1 +sha1zero = SHA1 0 0 0 0 0 + +sha1short :: SHA1 -> Word32 +sha1short (SHA1 a _ _ _ _) = a + +-- | Do something with the internals of a PackedString. Beware of +-- altering the contents! +unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a +unsafeWithInternals ps f + = case BI.toForeignPtr ps of + (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l + +sha1PS:: B.ByteString -> SHA1 +sha1PS s = abcde' + where s1_2 = sha1Step12PadLength s + abcde = sha1Step3Init + abcde' = unsafePerformIO + $ unsafeWithInternals s1_2 (\ptr len -> + do let ptr' = castPtr ptr +#ifndef BIGENDIAN + fiddleEndianness ptr' len +#endif + sha1Step4Main abcde ptr' len) + +fiddleEndianness :: Ptr Word32 -> Int -> IO () +fiddleEndianness p 0 = p `seq` return () +fiddleEndianness p n + = do x <- peek p + poke p $ shiftL x 24 + .|. shiftL (x .&. 0xff00) 8 + .|. (shiftR x 8 .&. 0xff00) + .|. shiftR x 24 + fiddleEndianness (p `advancePtr` 1) (n - 4) + +-- sha1Step12PadLength assumes the length is at most 2^61. +-- This seems reasonable as the Int used to represent it is normally 32bit, +-- but obviously could go wrong with large inputs on 64bit machines. +-- The B.ByteString library should probably move to Word64s if this is an +-- issue, though. + +sha1Step12PadLength :: B.ByteString -> B.ByteString +sha1Step12PadLength s + = let len = B.length s + num_nuls = (55 - len) `mod` 64 + padding = 128:replicate num_nuls 0 + len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8) + in B.concat [s, B.pack padding, B.pack len_w8s] + +sizeSplit :: Int -> Integer -> [Word8] +sizeSplit 0 _ = [] +sizeSplit p n = fromIntegral d:sizeSplit (p-1) n' + where (n', d) = divMod n 256 + +sha1Step3Init :: SHA1 +sha1Step3Init = SHA1 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 + +sha1Step4Main :: SHA1 -> Ptr Word32 -> Int -> IO SHA1 +sha1Step4Main abcde _ 0 = return $! abcde +sha1Step4Main (SHA1 a0@a b0@b c0@c d0@d e0@e) s len + = do + (e, b) <- doit f1 0x5a827999 (x 0) a b c d e + (d, a) <- doit f1 0x5a827999 (x 1) e a b c d + (c, e) <- doit f1 0x5a827999 (x 2) d e a b c + (b, d) <- doit f1 0x5a827999 (x 3) c d e a b + (a, c) <- doit f1 0x5a827999 (x 4) b c d e a + (e, b) <- doit f1 0x5a827999 (x 5) a b c d e + (d, a) <- doit f1 0x5a827999 (x 6) e a b c d + (c, e) <- doit f1 0x5a827999 (x 7) d e a b c + (b, d) <- doit f1 0x5a827999 (x 8) c d e a b + (a, c) <- doit f1 0x5a827999 (x 9) b c d e a + (e, b) <- doit f1 0x5a827999 (x 10) a b c d e + (d, a) <- doit f1 0x5a827999 (x 11) e a b c d + (c, e) <- doit f1 0x5a827999 (x 12) d e a b c + (b, d) <- doit f1 0x5a827999 (x 13) c d e a b + (a, c) <- doit f1 0x5a827999 (x 14) b c d e a + (e, b) <- doit f1 0x5a827999 (x 15) a b c d e + (d, a) <- doit f1 0x5a827999 (m 16) e a b c d + (c, e) <- doit f1 0x5a827999 (m 17) d e a b c + (b, d) <- doit f1 0x5a827999 (m 18) c d e a b + (a, c) <- doit f1 0x5a827999 (m 19) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a + let abcde' = SHA1 (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e) + sha1Step4Main abcde' (s `advancePtr` 16) (len - 64) + where {-# INLINE f1 #-} + f1 (XYZ x y z) = (x .&. y) .|. (complement x .&. z) + {-# INLINE f2 #-} + f2 (XYZ x y z) = x `xor` y `xor` z + {-# INLINE f3 #-} + f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) + {-# INLINE x #-} + x n = peek (s `advancePtr` n) + {-# INLINE m #-} + m n = do let base = s `advancePtr` (n .&. 15) + x0 <- peek base + x1 <- peek (s `advancePtr` ((n - 14) .&. 15)) + x2 <- peek (s `advancePtr` ((n - 8) .&. 15)) + x3 <- peek (s `advancePtr` ((n - 3) .&. 15)) + let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1 + poke base res + return res + {-# INLINE doit #-} + doit f k i a b c d e = a `seq` c `seq` + do i' <- i + return (rotateL a 5 + f (XYZ b c d) + e + i' + k, + rotateL b 30) + +showAsHex :: Word32 -> String +showAsHex n = showIt 8 n "" + where + showIt :: Int -> Word32 -> String -> String + showIt 0 _ r = r + showIt i x r = case quotRem x 16 of + (y, z) -> let c = intToDigit (fromIntegral z) + in c `seq` showIt (i-1) y (c:r) diff --git a/src/Darcs/Util/Index.hs b/src/Darcs/Util/Index.hs --- a/src/Darcs/Util/Index.hs +++ b/src/Darcs/Util/Index.hs @@ -68,55 +68,64 @@ where import Prelude hiding ( lookup, readFile, writeFile, filter, (<$>) ) -import Darcs.Util.ByteString ( readSegment ) +import Darcs.Util.ByteString ( readSegment, decodeLocale ) +import Darcs.Util.File ( getFileStatus ) +import Darcs.Util.Hash( sha256, rawHash ) import Darcs.Util.Tree -import Darcs.Util.Path hiding ( getCurrentDirectory ) -import Data.Int( Int64, Int32 ) - -import Bundled.Posix( getFileStatusBS, modificationTime, - getFileStatus, fileSize, fileExists, isDirectory ) -import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) ) -import System.IO( ) -import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist ) -#if mingw32_HOST_OS -import System.Directory( renameFile ) -import System.FilePath( (<.>) ) -#else -import System.Directory( removeFile ) -#endif -import System.FilePath( () ) -import System.Posix.Types ( FileID ) - +import Darcs.Util.Path + ( AnchoredPath(..) + , anchorPath + , anchoredRoot + , unsafeMakeName + , appendPath + , flatten + ) import Control.Monad( when ) import Control.Exception( catch, SomeException ) import Control.Applicative( (<$>) ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy , nullForeignPtr, c2w ) -import Data.IORef( ) -import Data.Maybe( fromJust, isJust, fromMaybe ) import Data.Bits( Bits ) #ifdef BIGENDIAN import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR ) #endif +import Data.Int( Int64, Int32 ) +import Data.IORef( ) +import Data.Maybe( fromJust, isJust, fromMaybe ) import Foreign.Storable import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr ) import Foreign.Ptr( Ptr, plusPtr ) -import Darcs.Util.Hash( sha256, rawHash ) +import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) ) +import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist ) +#if mingw32_HOST_OS +import System.Directory( renameFile ) +import System.FilePath( (<.>) ) +#else +import System.Directory( removeFile ) +#endif + #ifdef WIN32 import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..), fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS, gENERIC_NONE, oPEN_EXISTING, closeHandle ) #else -import System.PosixCompat ( fileID, getSymbolicLinkStatus ) +import qualified System.Posix.Files as F ( getSymbolicLinkStatus, fileID ) #endif +import System.FilePath ( () ) +import qualified System.Posix.Files as F + ( modificationTime, fileSize, isDirectory + , FileStatus + ) +import System.Posix.Types ( FileID, EpochTime, FileOffset ) + -------------------------- -- Indexed trees -- @@ -131,7 +140,7 @@ -- recursive Tree object, which is rather expensive... As a bonus, we can also -- efficiently implement subtree queries this way (cf. 'readIndex'). data Item = Item { iBase :: !(Ptr ()) - , iHashAndDescriptor :: !BS.ByteString + , iHashAndDescriptor :: !B.ByteString } deriving Show size_magic :: Int @@ -154,17 +163,19 @@ itemAllocSize :: AnchoredPath -> Int itemAllocSize apath = - align 4 $ size_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + BS.length (flatten apath) + align 4 $ size_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + B.length (flatten apath) itemSize, itemNext :: Item -> Int -itemSize i = size_size + size_aux + size_fileid + size_dsclen + (BS.length $ iHashAndDescriptor i) +itemSize i = size_size + size_aux + size_fileid + size_dsclen + (B.length $ iHashAndDescriptor i) itemNext i = align 4 (itemSize i + 1) -iPath, iHash, iDescriptor :: Item -> BS.ByteString +iHash, iDescriptor :: Item -> B.ByteString iDescriptor = unsafeDrop size_hash . iHashAndDescriptor -iPath = unsafeDrop 1 . iDescriptor -iHash = BS.take size_hash . iHashAndDescriptor +iHash = B.take size_hash . iHashAndDescriptor +iPath :: Item -> FilePath +iPath = decodeLocale . unsafeDrop 1 . iDescriptor + iSize, iAux :: Item -> Ptr Int64 iSize i = plusPtr (iBase i) off_size iAux i = plusPtr (iBase i) off_aux @@ -183,15 +194,29 @@ xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO () xlatePoke64 ptr v = poke ptr (xlate64 v) +type FileStatus = Maybe F.FileStatus + +modificationTime :: FileStatus -> EpochTime +modificationTime = maybe 0 F.modificationTime + +fileSize :: FileStatus -> FileOffset +fileSize = maybe 0 F.fileSize + +fileExists :: FileStatus -> Bool +fileExists = maybe False (const True) + +isDirectory :: FileStatus -> Bool +isDirectory = maybe False F.isDirectory + -- | Lay out the basic index item structure in memory. The memory location is -- given by a ForeignPointer () and an offset. The path and type given are -- written out, and a corresponding Item is given back. The remaining bits of -- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item createItem typ apath fp off = - do let dsc = BS.concat [ BSC.singleton $ if typ == TreeType then 'D' else 'F' + do let dsc = B.concat [ BC.singleton $ if typ == TreeType then 'D' else 'F' , flatten apath - , BS.singleton 0 ] + , B.singleton 0 ] (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc withForeignPtr fp $ \p -> withForeignPtr dsc_fp $ \dsc_p -> @@ -221,7 +246,7 @@ -- when updating directory entries). updateItem :: Item -> Int64 -> Hash -> IO () updateItem item _ NoHash = - fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item) + fail $ "Index.update NoHash: " ++ iPath item updateItem item size hash = do xlatePoke64 (iSize item) size unsafePokeBS (iHash item) (rawHash hash) @@ -241,9 +266,7 @@ -- the index file. mmapIndex will grow the index if it is smaller than this. mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int) mmapIndex indexpath req_size = do - exist <- doesFileExist indexpath - act_size <- fromIntegral `fmap` if exist then fileSize `fmap` getFileStatus indexpath - else return 0 + act_size <- fromIntegral . fileSize <$> getFileStatus indexpath let size = case req_size > 0 of True -> req_size False | act_size >= size_magic -> act_size - size_magic @@ -293,19 +316,19 @@ return res' readDir :: Index -> State -> Item -> IO Result -readDir index state item = - do following <- fromIntegral <$> xlatePeek64 (iAux item) - st <- getFileStatusBS (iPath item) +readDir index state item = do + following <- fromIntegral <$> xlatePeek64 (iAux item) + st <- getFileStatus (iPath item) let exists = fileExists st && isDirectory st fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) - fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) + fileid' <- fromMaybe fileid <$> (getFileID' $ iPath item) when (fileid == 0) $ updateFileID item fileid' - let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC - namelength = (BS.length $ iDescriptor item) - (dirlength state) + let name it dirlen = unsafeMakeName $ (B.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC + namelength = (B.length $ iDescriptor item) - (dirlength state) myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname - , dirlength = if myname == Name (BSC.singleton '.') + , dirlength = if myname == unsafeMakeName (BC.singleton '.') then dirlength state else dirlength state + namelength } @@ -325,7 +348,7 @@ let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf nullleaf = null inferiors && oldhash == nullsha - nullsha = SHA256 (BS.replicate 32 0) + nullsha = SHA256 (B.replicate 32 0) tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ] treehash = if we_changed then hashtree index tree' else oldhash tree = tree' { treeHash = treehash } @@ -338,15 +361,15 @@ , resitem = item } readFile :: Index -> State -> Item -> IO Result -readFile index state item = - do st <- getFileStatusBS (iPath item) +readFile index state item = do + st <- getFileStatus (iPath item) mtime <- fromIntegral <$> (xlatePeek64 $ iAux item) size <- xlatePeek64 $ iSize item fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) - fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) + fileid' <- fromMaybe fileid <$> (getFileID' $ iPath item) let mtime' = modificationTime st size' = fromIntegral $ fileSize st - readblob = readSegment (basedir index BSC.unpack (iPath item), Nothing) + readblob = readSegment (basedir index (iPath item), Nothing) exists = fileExists st && not (isDirectory st) we_changed = mtime /= mtime' || size /= size' hash = iHash' item @@ -394,12 +417,12 @@ readDirFileIDs index state item = do fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) following <- fromIntegral <$> xlatePeek64 (iAux item) - let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC - namelength = (BS.length $ iDescriptor item) - (dirlength state) + let name it dirlen = unsafeMakeName $ (B.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC + namelength = (B.length $ iDescriptor item) - (dirlength state) myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname - , dirlength = if myname == Name (BSC.singleton '.') + , dirlength = if myname == unsafeMakeName (BC.singleton '.') then dirlength state else dirlength state + namelength } subs off | off < following = do @@ -417,7 +440,7 @@ readFileFileID :: Index -> State -> Item -> IO ResultF readFileFileID _ state item = do fileid' <- fromIntegral <$> (xlatePeek64 $ iFileID item) - let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) + let name it dirlen = unsafeMakeName $ (B.drop (dirlen + 1) $ iDescriptor it) myname = name item (dirlength state) return $ ResultF { nextF = start state + itemNext item , resitemF = item @@ -448,11 +471,11 @@ formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO () formatIndex mmap_ptr old reference = do _ <- create (SubTree reference) (AnchoredPath []) size_magic - unsafePokeBS magic (BSC.pack "HSI5") + unsafePokeBS magic (BC.pack "HSI5") where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4 create (File _) path' off = do i <- createItem BlobType path' mmap_ptr off - let flatpath = BSC.unpack $ flatten path' + let flatpath = anchorPath "" path' case find old path' of Nothing -> return () -- TODO calling getFileStatus here is both slightly @@ -503,12 +526,13 @@ -- | Check that a given file is an index file with a format we can handle. You -- should remove and re-create the index whenever this is not true. indexFormatValid :: FilePath -> IO Bool -indexFormatValid path' = - do magic <- mmapFileByteString path' (Just (0, size_magic)) - return $ case BSC.unpack magic of - "HSI5" -> True - _ -> False - `catch` \(_::SomeException) -> return False +indexFormatValid path' = do + v <- do magic <- mmapFileByteString path' (Just (0, size_magic)) + return $ case BC.unpack magic of + "HSI5" -> True + _ -> False + `catch` \(_::SomeException) -> return False + return v instance FilterTree IndexM IO where filter _ EmptyIndex = EmptyIndex @@ -530,13 +554,13 @@ closeHandle h return fhnumber #else - then (Just . fileID) <$> getSymbolicLinkStatus fp + then (Just . F.fileID) <$> F.getSymbolicLinkStatus fp #endif else return Nothing -- Wow, unsafe. -unsafePokeBS :: BSC.ByteString -> BSC.ByteString -> IO () +unsafePokeBS :: BC.ByteString -> BC.ByteString -> IO () unsafePokeBS to from = do let (fp_to, off_to, len_to) = toForeignPtr to (fp_from, off_from, len_from) = toForeignPtr from diff --git a/src/Darcs/Util/IsoDate.hs b/src/Darcs/Util/IsoDate.hs --- a/src/Darcs/Util/IsoDate.hs +++ b/src/Darcs/Util/IsoDate.hs @@ -26,7 +26,7 @@ -- Portability : portable module Darcs.Util.IsoDate - ( getIsoDateTime, readUTCDate + ( getIsoDateTime, readUTCDate, readUTCDateOldFashioned , parseDate, getLocalTz , englishDateTime, englishInterval, englishLast , iso8601Interval, iso8601Duration @@ -34,6 +34,7 @@ , MCalendarTime(..), subtractFromMCal, addToMCal , toMCalendarTime, unsafeToCalendarTime , unsetTime, TimeInterval + , showIsoDateTime ) where import Prelude ( (^) ) @@ -45,7 +46,7 @@ import Data.Char ( toUpper, isDigit ) import Data.Maybe ( fromMaybe ) import Control.Monad ( liftM, liftM2 ) -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Char8 as BC type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime) @@ -77,25 +78,36 @@ Left e -> error $ "bad date: "++d++" - "++show e Right ct -> resetCalendar $ unsafeToCalendarTime ct +-- | Similar to 'readUTCDate', except we /ignore/ timezone info +-- in the input string. This is incorrect and ugly. The only reason +-- it still exists is so we can generate file names for old-fashioned +-- repositories in the same way that old darcs versions expected them. +-- You should not use this function except for the above stated purpose. +readUTCDateOldFashioned :: String -> CalendarTime +readUTCDateOldFashioned d = + case parseDate 0 d of + Left e -> error $ "bad date: "++d++" - "++show e + Right ct -> (unsafeToCalendarTime ct) { ctTZ = 0 } + -- | Parse a date string, assuming a default timezone if -- the date string does not specify one. The date formats -- understood are those of 'showIsoDateTime' and 'dateTime' parseDate :: Int -> String -> Either ParseError MCalendarTime parseDate tz d = - if length d >= 14 && B.all isDigit bd + if length d >= 14 && BC.all isDigit bd then Right $ toMCalendarTime $ - CalendarTime (readI $ B.take 4 bd) - (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd) - (readI $ B.take 2 $ B.drop 6 bd) -- Day - (readI $ B.take 2 $ B.drop 8 bd) -- Hour - (readI $ B.take 2 $ B.drop 10 bd) -- Minute - (readI $ B.take 2 $ B.drop 12 bd) -- Second + CalendarTime (readI $ BC.take 4 bd) + (toEnum $ (+ (-1)) $ readI $ BC.take 2 $ BC.drop 4 bd) + (readI $ BC.take 2 $ BC.drop 6 bd) -- Day + (readI $ BC.take 2 $ BC.drop 8 bd) -- Hour + (readI $ BC.take 2 $ BC.drop 10 bd) -- Minute + (readI $ BC.take 2 $ BC.drop 12 bd) -- Second 0 Sunday 0 -- Picosecond, weekday and day of year unknown "GMT" 0 False else let dt = do { x <- dateTime tz; eof; return x } in parse dt "" d - where bd = B.pack (take 14 d) - readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s) + where bd = BC.pack (take 14 d) + readI s = fst $ fromMaybe (error "parseDate: invalid date") (BC.readInt s) -- | Display a 'CalendarTime' in the ISO 8601 format without any -- separators, e.g. 20080825142503 diff --git a/src/Darcs/Util/Lock.hs b/src/Darcs/Util/Lock.hs --- a/src/Darcs/Util/Lock.hs +++ b/src/Darcs/Util/Lock.hs @@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - module Darcs.Util.Lock ( withLock , withLockCanFail @@ -28,15 +26,14 @@ , withPermDir , withDelayedDir , withNamedTemp - , writeToFile - , appendToFile , writeBinFile - , writeLocaleFile + , writeTextFile , writeDocBinFile , appendBinFile + , appendTextFile , appendDocBinFile , readBinFile - , readLocaleFile + , readTextFile , readDocBinFile , writeAtomicFilePS , gzWriteAtomicFilePS @@ -46,23 +43,31 @@ , removeFileMayNotExist , canonFilename , maybeRelink - , worldReadableTemp , tempdirLoc , environmentHelpTmpdir , environmentHelpKeepTmpdir , addToErrorLoc + , withNewDirectory ) where +import Prelude () +import Darcs.Prelude + import Data.List ( inits ) import Data.Maybe ( isJust, listToMaybe ) import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( withBinaryFile, openBinaryTempFile, - hClose, hPutStr, Handle, - IOMode(WriteMode, AppendMode), hFlush, stdout ) +import System.IO + ( withFile, withBinaryFile, openBinaryTempFile + , hClose, Handle, hPutStr, hSetEncoding + , IOMode(WriteMode, AppendMode), hFlush, stdout + ) import System.IO.Error ( isAlreadyExistsError + , alreadyExistsErrorType , annotateIOError + , mkIOError ) +import System.IO.Temp ( withTempDirectory ) import Control.Exception ( IOException , bracket @@ -71,17 +76,28 @@ , try , SomeException ) -import System.Directory ( removeFile, removeDirectory, - doesFileExist, doesDirectoryExist, - getDirectoryContents, createDirectory, - getTemporaryDirectory, - ) +import System.Directory + ( removeFile + , removeDirectory + , doesFileExist + , doesDirectoryExist + , getDirectoryContents + , createDirectory + , getTemporaryDirectory + , renameDirectory + ) import System.FilePath.Posix ( splitDirectories ) +import qualified System.FilePath as NativeFilePath ( takeDirectory ) +import System.Environment ( lookupEnv ) + import Control.Concurrent ( threadDelay ) import Control.Monad ( unless, when, liftM ) +import System.Posix.Files ( fileMode, getFileStatus, setFileMode ) + +import GHC.IO.Encoding ( getFileSystemEncoding ) + import Darcs.Util.URL ( isRelative ) -import Darcs.Util.Environment ( maybeGetEnv ) import Darcs.Util.Exception ( firstJustIO , catchall @@ -91,12 +107,11 @@ import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath, getCurrentDirectory, setCurrentDirectory ) -import Darcs.Util.ByteString ( gzWriteFilePSs, decodeLocale, encodeLocale ) +import Darcs.Util.ByteString ( gzWriteFilePSs ) import qualified Data.ByteString as B (null, readFile, hPut, ByteString) -import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.Util.SignalHandler ( withSignalsBlocked ) -import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs, RenderMode(..) ) +import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs ) import Darcs.Util.AtExit ( atexit ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Workaround ( renameFile ) @@ -107,9 +122,8 @@ , atomicCreate , sloppyAtomicCreate ) -import System.Posix.Files ( fileMode, getFileStatus, setFileMode ) +import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Prompt ( askUser ) -#include "impossible.h" withLock :: String -> IO a -> IO a withLock s job = bracket (getlock s 30) releaseLock (\_ -> job) @@ -173,7 +187,7 @@ -- -- The temp file operations are rather similar to the locking operations, in -- that they both should always try to clean up, so exitWith causes trouble. -withTemp :: (String -> IO a) -> IO a +withTemp :: (FilePath -> IO a) -> IO a withTemp = bracket get_empty_file removeFileMayNotExist where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs" hClose h @@ -184,20 +198,20 @@ -- both of them (to my knowledge) are not susceptible to race conditions on -- the temporary file (as long as you never delete the temporary file; that -- would reintroduce a race condition). -withOpenTemp :: ((Handle, String) -> IO a) -> IO a +withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a withOpenTemp = bracket get_empty_file cleanup where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ()) removeFileMayNotExist f get_empty_file = invert `fmap` openBinaryTempFile "." "darcs" invert (a,b) = (b,a) -withStdoutTemp :: (String -> IO a) -> IO a +withStdoutTemp :: (FilePath -> IO a) -> IO a withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist tempdirLoc :: IO FilePath tempdirLoc = liftM fromJust $ - firstJustIO [ liftM (Just . head . words) (readBinFile (darcsdir++"/prefs/tmpdir")) >>= chkdir, - maybeGetEnv "DARCS_TMPDIR" >>= chkdir, + firstJustIO [ liftM (Just . head . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir, + lookupEnv "DARCS_TMPDIR" >>= chkdir, getTemporaryDirectory >>= chkdir . Just, getCurrentDirectorySansDarcs, return $ Just "." -- always returns a Just @@ -227,7 +241,7 @@ -- If an absolute path is given this dir will be created if it doesn't exist. -- If it is specified as a temporary dir, it is deleted after finishing the job. withDir :: WithDirKind -- specifies if and when directory will be deleted - -> String -- path parameter + -> FilePath -- path parameter -> (AbsolutePath -> IO a) -> IO a withDir _ "" _ = bug "withDir called with empty directory name" withDir kind absoluteOrRelativeName job = do @@ -253,7 +267,7 @@ `catch` (\e -> if isAlreadyExistsError e then createDir name (n+1) else throwIO e) - keepTempDir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR" + keepTempDir = isJust `fmap` lookupEnv "DARCS_KEEP_TMPDIR" environmentHelpKeepTmpdir :: ([String], [String]) environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[ @@ -265,11 +279,11 @@ -- |'withPermDir' is like 'withTempDir', except that it doesn't -- delete the directory afterwards. -withPermDir :: String -> (AbsolutePath -> IO a) -> IO a +withPermDir :: FilePath -> (AbsolutePath -> IO a) -> IO a withPermDir = withDir Perm --- |'withTempDir' creates an empty directory and then removes it when it --- is no longer needed. withTempDir creates a temporary directory. The +-- |'withTempDir' creates a temporary directory, runs the action and then +-- removes the directory. The -- location of that directory is determined by the contents of -- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if -- that doesn't exist then whatever your operating system considers to be a @@ -283,10 +297,10 @@ -- This should not fail, but if it does indeed fail, we go ahead and use the -- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set -- temporary directory is not removed, this can be useful for debugging. -withTempDir :: String -> (AbsolutePath -> IO a) -> IO a +withTempDir :: FilePath -> (AbsolutePath -> IO a) -> IO a withTempDir = withDir Temp -withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a +withDelayedDir :: FilePath -> (AbsolutePath -> IO a) -> IO a withDelayedDir = withDir Delayed rmRecursive :: FilePath -> IO () @@ -302,50 +316,62 @@ do c <- getDirectoryContents d return $ filter (/=".") $ filter (/="..") c -worldReadableTemp :: String -> IO String +worldReadableTemp :: FilePath -> IO FilePath worldReadableTemp f = wrt 0 - where wrt :: Int -> IO String + where wrt :: Int -> IO FilePath 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 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 = worldReadableTemp n +withNamedTemp :: FilePath -> (FilePath -> IO a) -> IO a +withNamedTemp n f = do + debugMessage $ "withNamedTemp: " ++ show n + bracket (worldReadableTemp n) removeFileMayNotExist f -readBinFile :: FilePathLike p => p -> IO String -readBinFile = fmap BC.unpack . B.readFile . toFilePath +readBinFile :: FilePathLike p => p -> IO B.ByteString +readBinFile = B.readFile . toFilePath --- | Reads a file. Differs from readBinFile in that it interprets the file in --- the current locale instead of as ISO-8859-1. -readLocaleFile :: FilePathLike p => p -> IO String -readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f) +-- NOTE using 'seq' on the last element of the result causes the content to be +-- fully evaluated, so the file is read strictly; this is more efficient than +-- counting the number of characters; and in the (few) places where we use this +-- function we need the lines anyway. +readTextFile :: FilePathLike p => p -> IO [String] +readTextFile f = do + result <- lines <$> readFile (toFilePath f) + case result of + [] -> return result + xs -> last xs `seq` return result readDocBinFile :: FilePathLike p => p -> IO Doc readDocBinFile fp = do ps <- B.readFile $ toFilePath fp return $ if B.null ps then empty else packedString ps -appendBinFile :: FilePathLike p => p -> String -> IO () -appendBinFile f s = appendToFile f $ \h -> hPutStr h s +appendBinFile :: FilePathLike p => p -> B.ByteString -> IO () +appendBinFile f s = appendToFile Binary f $ \h -> B.hPut h s +appendTextFile :: FilePathLike p => p -> String -> IO () +appendTextFile f s = appendToFile Text f $ \h -> hPutStr h s + appendDocBinFile :: FilePathLike p => p -> Doc -> IO () -appendDocBinFile f d = appendToFile f $ \h -> hPutDoc Standard h d +appendDocBinFile f d = appendToFile Binary f $ \h -> hPutDoc h d -writeBinFile :: FilePathLike p => p -> String -> IO () -writeBinFile f s = writeToFile f $ \h -> hPutStr h s +data FileType = Text | Binary --- | Writes a file. Differs from writeBinFile in that it writes the string --- encoded with the current locale instead of what GHC thinks is right. -writeLocaleFile :: FilePathLike p => p -> String -> IO () -writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s) +writeBinFile :: FilePathLike p => p -> B.ByteString -> IO () +writeBinFile f s = writeToFile Binary f $ \h -> B.hPut h s +writeTextFile :: FilePathLike p => p -> String -> IO () +writeTextFile f s = writeToFile Text f $ \h -> do + getFileSystemEncoding >>= hSetEncoding h + hPutStr h s + writeDocBinFile :: FilePathLike p => p -> Doc -> IO () -writeDocBinFile f d = writeToFile f $ \h -> hPutDoc Standard h d +writeDocBinFile f d = writeToFile Binary f $ \h -> hPutDoc h d writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () -writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps +writeAtomicFilePS f ps = writeToFile Binary f $ \h -> B.hPut h ps gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps] @@ -361,24 +387,43 @@ renameFile newf (toFilePath f) gzWriteDocFile :: FilePathLike p => p -> Doc -> IO () -gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs Standard d +gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d -writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () -writeToFile f job = +writeToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO () +writeToFile t f job = withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do - withBinaryFile newf WriteMode job + (case t of + Text -> withFile + Binary -> withBinaryFile) newf WriteMode job already_exists <- doesFileExist (toFilePath f) when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) setFileMode newf mode `catchall` return () renameFile newf (toFilePath f) -appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () -appendToFile f job = withSignalsBlocked $ - withBinaryFile (toFilePath f) AppendMode job +appendToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO () +appendToFile t f job = withSignalsBlocked $ + (case t of + Binary -> withBinaryFile + Text -> withFile) (toFilePath f) AppendMode job addToErrorLoc :: IOException -> String -> IOException addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing + +-- | Do an action in a newly created directory of the given name. The directory +-- is first created with a different temporary name (but under the same parent +-- directory), and becomes renamed to the final name when the action returns +-- without an exception. This operation raises an alreadyExists exception if a +-- file system object of the given name already exists. +withNewDirectory :: FilePath -> IO () -> IO () +withNewDirectory name action = do + exists1 <- doesFileExist name -- TODO when depending on directory >= 1.2.7 + exists2 <- doesDirectoryExist name -- just use doesPathExist + when (exists1 || exists2) $ + throwIO (mkIOError alreadyExistsErrorType name Nothing Nothing) + withTempDirectory (NativeFilePath.takeDirectory name) "darcs_new" $ \path -> do + withCurrentDirectory path action + renameDirectory path name diff --git a/src/Darcs/Util/Path.hs b/src/Darcs/Util/Path.hs --- a/src/Darcs/Util/Path.hs +++ b/src/Darcs/Util/Path.hs @@ -28,8 +28,6 @@ , fn2fp , fn2ps , ps2fn - , niceps2fn - , fn2niceps , breakOnDir , normPath , ownName @@ -37,6 +35,8 @@ , movedirfilename , encodeWhite , decodeWhite + , encodeWhiteName + , decodeWhiteName , isParentOrEqOf -- * AbsolutePath , AbsolutePath @@ -76,7 +76,9 @@ -- * AnchoredPaths: relative paths within a Tree. All paths are -- anchored at a certain root (this is usually the Tree root). They are -- represented by a list of Names (these are just strict bytestrings). - , Name(..) + , Name + , unsafeMakeName + , eqAnycase , AnchoredPath(..) , anchoredRoot , appendPath @@ -84,7 +86,7 @@ , isPrefix , parent, parents, catPaths, flatten, makeName, appendToName -- * Unsafe AnchoredPath functions. - , floatBS, floatPath, replacePrefixPath ) where + , floatPath, replacePrefixPath ) where import Prelude () import Darcs.Prelude @@ -96,7 +98,7 @@ , intersect , inits ) -import Data.Char ( isSpace, chr, ord ) +import Data.Char ( isSpace, chr, ord, toLower ) import Control.Exception ( tryJust, bracket_ ) import Control.Monad ( when ) import System.IO.Error ( isDoesNotExistError ) @@ -109,17 +111,14 @@ import System.FilePath( (), splitDirectories, normalise, dropTrailingPathSeparator ) import System.Posix.Files ( isDirectory, getSymbolicLinkStatus ) -import Darcs.Util.ByteString ( packStringToUTF8, unpackPSFromUTF8 ) +import Darcs.Util.ByteString ( encodeLocale, decodeLocale ) import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString as B import Data.Binary import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath ) -#include "impossible.h" - - -- | FileName is an abstract type intended to facilitate the input and output of -- unicode filenames. newtype FileName = FN FilePath deriving ( Eq, Ord ) @@ -140,21 +139,13 @@ fn2fp :: FileName -> FilePath fn2fp (FN fp) = fp -{-# INLINE niceps2fn #-} -niceps2fn :: B.ByteString -> FileName -niceps2fn = FN . decodeWhite . BC.unpack - -{-# INLINE fn2niceps #-} -fn2niceps :: FileName -> B.ByteString -fn2niceps (FN fp) = BC.pack $ encodeWhite fp - {-# INLINE fn2ps #-} fn2ps :: FileName -> B.ByteString -fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp +fn2ps (FN fp) = encodeLocale $ encodeWhite fp {-# INLINE ps2fn #-} ps2fn :: B.ByteString -> FileName -ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps +ps2fn ps = FN $ decodeWhite $ decodeLocale ps {-# INLINE sp2fn #-} sp2fn :: SubPath -> FileName @@ -190,6 +181,12 @@ _ -> error "malformed filename" go (c:cs) acc modified = go cs (c:acc) modified +encodeWhiteName :: Name -> B.ByteString +encodeWhiteName = encodeLocale . encodeWhite . decodeLocale . unName + +decodeWhiteName :: B.ByteString -> Name +decodeWhiteName = Name . encodeLocale . decodeWhite . decodeLocale + ownName :: FileName -> FileName ownName (FN f) = case breakLast '/' f of Nothing -> FN f Just (_,f') -> FN f' @@ -568,7 +565,7 @@ -- AnchoredPath utilities -- -newtype Name = Name BC.ByteString deriving (Eq, Show, Ord) +newtype Name = Name { unName :: B.ByteString } deriving (Eq, Show, Ord) -- | This is a type of "sane" file paths. These are always canonic in the sense -- that there are no stray slashes, no ".." components and similar. They are @@ -586,7 +583,7 @@ appendPath :: AnchoredPath -> Name -> AnchoredPath appendPath (AnchoredPath p) n = case n of - (Name s) | s == BC.empty -> AnchoredPath p + (Name s) | B.null s -> AnchoredPath p | s == BC.pack "." -> AnchoredPath p | otherwise -> AnchoredPath $ p ++ [n] @@ -608,14 +605,9 @@ -- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative -- 'FilePath'. anchorPath :: FilePath -> AnchoredPath -> FilePath -anchorPath dir p = dir BC.unpack (flatten p) +anchorPath dir p = dir decodeLocale (flatten p) {-# INLINE anchorPath #-} --- | Unsafe. Only ever use on bytestrings that came from flatten on a --- pre-existing AnchoredPath. -floatBS :: BC.ByteString -> AnchoredPath -floatBS = AnchoredPath . map Name . takeWhile (not . BC.null) . BC.split '/' - flatten :: AnchoredPath -> BC.ByteString flatten (AnchoredPath []) = BC.singleton '.' flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/') @@ -624,7 +616,7 @@ makeName :: String -> Name makeName ".." = error ".. is not a valid AnchoredPath component name" makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name" - | otherwise = Name $ BC.pack n + | otherwise = Name $ encodeLocale n -- | Take a relative FilePath and turn it into an AnchoredPath. The operation -- is (relatively) unsafe. Basically, by using floatPath, you are testifying @@ -637,7 +629,7 @@ floatPath :: FilePath -> AnchoredPath floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator where make ["."] = AnchoredPath [] - make x = AnchoredPath $ map (Name . BC.pack) x + make x = AnchoredPath $ map (Name . encodeLocale) x anchoredRoot :: AnchoredPath @@ -653,11 +645,17 @@ | otherwise = AnchoredPath [] replacePrefixPath _ _ _ = AnchoredPath [] --- | Append a ByteString to the last Name of an AnchoredPath. +-- | Append a String to the last Name of an AnchoredPath. appendToName :: AnchoredPath -> String -> AnchoredPath appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname]) - where suffix = BC.pack s + where suffix = encodeLocale s finalname | suffix `elem` (BC.tails lastname) = lastname | otherwise = BC.append lastname suffix lastname = case last p of Name name -> name + +unsafeMakeName :: B.ByteString -> Name +unsafeMakeName = Name + +eqAnycase :: Name -> Name -> Bool +eqAnycase (Name a) (Name b) = BC.map toLower a == BC.map toLower b diff --git a/src/Darcs/Util/Printer.hs b/src/Darcs/Util/Printer.hs --- a/src/Darcs/Util/Printer.hs +++ b/src/Darcs/Util/Printer.hs @@ -52,9 +52,10 @@ , insertBeforeLastline , prefixLines , invisiblePS, userchunkPS - -- * Rendering - , RenderMode(..) - , renderString, renderStringWith, renderPS, renderPSWith + -- * Rendering to 'String' + , renderString, renderStringWith + -- * Rendering to 'ByteString' + , renderPS, renderPSWith , renderPSs, renderPSsWith -- * Printers , Printers @@ -70,14 +71,14 @@ , blueText, redText, greenText, magentaText, cyanText , colorText , lineColor - -- * IO + -- * IO, uses 'Data.ByteString.hPut' for output , hPutDoc, hPutDocLn, putDoc, putDocLn , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith , hPutDocCompr , debugDocLn , ePutDocLn , errorDoc - -- * Unsafe constructors + -- * TODO: It is unclear what is unsafe about these constructors , unsafeText, unsafeBoth, unsafeBothText, unsafeChar , unsafePackedString ) where @@ -85,17 +86,12 @@ import Prelude () import Darcs.Prelude -import Control.Exception ( throwIO, ErrorCall(..) ) import Data.String ( IsString(..) ) -import Data.List (intersperse) -import Data.Monoid ( (<>) ) -import GHC.Stack ( currentCallStack ) -import System.IO (Handle, stdout, stderr, hPutStr) -import System.IO.Unsafe ( unsafePerformIO ) -import qualified Data.ByteString as B (ByteString, hPut, concat) -import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton) +import System.IO ( Handle, stdout, stderr ) +import qualified Data.ByteString as B ( ByteString, hPut, concat ) +import qualified Data.ByteString.Char8 as BC ( singleton ) -import Darcs.Util.ByteString ( linesPS, encodeLocale, gzWriteHandle ) +import Darcs.Util.ByteString ( linesPS, decodeLocale, encodeLocale, gzWriteHandle ) import Darcs.Util.Global ( debugMessage ) -- | A 'Printable' is either a String, a packed string, or a chunk of @@ -146,74 +142,71 @@ -- | Fail with a stack trace and the given 'Doc' as error message. errorDoc :: Doc -> a -errorDoc x = unsafePerformIO $ do - stack <- currentCallStack - throwIO $ ErrorCall $ renderString Encode $ x $$ vcat (map text stack) +errorDoc x = error $ renderString x --- | 'putDocWith' puts a doc on stdout using the given printer. +-- | 'putDocWith' puts a 'Doc' on stdout using the given printer. putDocWith :: Printers -> Doc -> IO () -putDocWith prs = hPutDocWith prs Encode stdout +putDocWith prs = hPutDocWith prs stdout --- | 'putDocLnWith' puts a doc, followed by a newline on stdout using +-- | 'putDocLnWith' puts a 'Doc', followed by a newline on stdout using -- the given printer. putDocLnWith :: Printers -> Doc -> IO () -putDocLnWith prs = hPutDocLnWith prs Encode stdout +putDocLnWith prs = hPutDocLnWith prs stdout --- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'. +-- | 'putDoc' puts a 'Doc' on stdout using the simple printer 'simplePrinters'. putDoc :: Doc -> IO () -putDoc = hPutDoc Encode stdout +putDoc = hPutDoc stdout --- | 'putDocLn' puts a doc, followed by a newline on stdout using +-- | 'putDocLn' puts a 'Doc', followed by a newline on stdout using -- 'simplePrinters' putDocLn :: Doc -> IO () -putDocLn = hPutDocLn Encode stdout +putDocLn = hPutDocLn stdout --- | 'eputDocLn' puts a doc, followed by a newline to stderr using +-- | 'eputDocLn' puts a 'Doc', followed by a newline to stderr using -- 'simplePrinters'. Like putDocLn, it encodes with the user's locale. -- This function is the recommended way to output messages that should -- be visible to users on the console, but cannot (or should not) be -- silenced even when --quiet is in effect. ePutDocLn :: Doc -> IO () -ePutDocLn = hPutDocLn Encode stderr +ePutDocLn = hPutDocLn stderr --- | 'hputDocWith' puts a doc on the given handle using the given printer. -hPutDocWith :: Printers -> RenderMode -> Handle -> Doc -> IO () -hPutDocWith prs target h d = hPrintPrintables target h (renderWith (prs h) d) +-- | 'hputDocWith' puts a 'Doc' on the given handle using the given printer. +hPutDocWith :: Printers -> Handle -> Doc -> IO () +hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d) --- | 'hputDocLnWith' puts a doc, followed by a newline on the given +-- | 'hputDocLnWith' puts a 'Doc', followed by a newline on the given -- handle using the given printer. -hPutDocLnWith :: Printers -> RenderMode -> Handle -> Doc -> IO () -hPutDocLnWith prs target h d = hPutDocWith prs target h (d newline) +hPutDocLnWith :: Printers -> Handle -> Doc -> IO () +hPutDocLnWith prs h d = hPutDocWith prs h (d newline) --- |'hputDoc' puts a doc on the given handle using 'simplePrinters' -hPutDoc :: RenderMode -> Handle -> Doc -> IO () +-- |'hputDoc' puts a 'Doc' on the given handle using 'simplePrinters' +hPutDoc :: Handle -> Doc -> IO () hPutDoc = hPutDocWith simplePrinters --- | 'hputDocLn' puts a doc, followed by a newline on the given handle using +-- | 'hputDocLn' puts a 'Doc', followed by a newline on the given handle using -- 'simplePrinters'. -hPutDocLn :: RenderMode -> Handle -> Doc -> IO () +hPutDocLn :: Handle -> Doc -> IO () hPutDocLn = hPutDocLnWith simplePrinters -- | like 'hPutDoc' but with compress data before writing -hPutDocCompr :: RenderMode -> Handle -> Doc -> IO () -hPutDocCompr target h = gzWriteHandle h . renderPSs target +hPutDocCompr :: Handle -> Doc -> IO () +hPutDocCompr h = gzWriteHandle h . renderPSs -- | Write a 'Doc' to stderr if debugging is turned on. debugDocLn :: Doc -> IO () -debugDocLn = debugMessage . renderString Standard +debugDocLn = debugMessage . renderString -- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle @h@ -hPrintPrintables :: RenderMode -> Handle -> [Printable] -> IO () -hPrintPrintables target h = mapM_ (hPrintPrintable target h) +-- It uses binary output of 'ByteString's. If these not available, +-- converts according to locale. +hPrintPrintables :: Handle -> [Printable] -> IO () +hPrintPrintables h = mapM_ (hPrintPrintable h) -- | @'hPrintPrintable' h@ prints a 'Printable' to the handle @h@. -hPrintPrintable :: RenderMode -> Handle -> Printable -> IO () -hPrintPrintable Standard h (S ps) = hPutStr h ps -hPrintPrintable Encode h (S ps) = B.hPut h (encodeLocale ps) -hPrintPrintable Standard h (PS ps) = B.hPut h ps -hPrintPrintable Encode h (PS ps) = B.hPut h ps -hPrintPrintable Standard h (Both _ ps) = B.hPut h ps -hPrintPrintable Encode h (Both _ ps) = B.hPut h ps +hPrintPrintable :: Handle -> Printable -> IO () +hPrintPrintable h (S ps) = B.hPut h (encodeLocale ps) +hPrintPrintable h (PS ps) = B.hPut h ps +hPrintPrintable h (Both _ ps) = B.hPut h ps -- | A 'Doc' is a bit of enriched text. 'Doc's are concatenated using -- '<>' from class 'Monoid', which is right-associative. @@ -224,22 +217,7 @@ instance IsString Doc where fromString = text --- TODO this is a rather ad-hoc hack that further complicates --- some already confusing code. We should find a more general --- solution. See the discussion on issue1639. --- | Used when rendering a 'Doc' to indicate if the result --- should be encoded to the current locale or left alone. --- In practice this only affects output when a relevant --- DARCS_DONT_ESCAPE_XXX option is set (see Darcs.Util.Printer.Color) --- If in doubt, choose 'Standard'. -data RenderMode = - Encode -- ^Encode Strings with the current locale. - -- At present ByteStrings are assumed to be in - -- UTF8 and are left alone, so will be mis-encoded - -- in non-UTF8 locales. - | Standard -- ^Don't encode. - --- | The State associated with a doc. Contains a set of printers for each +-- | The State associated with a 'Doc'. Contains a set of printers for each -- hanlde, and the current prefix of the document. data St = St { printers :: !Printers', currentPrefix :: !([Printable] -> [Printable]) } @@ -259,54 +237,50 @@ data Color = Blue | Red | Green | Cyan | Magenta -- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows --- for empty Documents. The simplest 'Documents' are built from 'String's --- using 'text'. +-- to handle the special case of an empty 'Document' in a non-uniform manner. +-- The simplest 'Documents' are built from 'String's using 'text'. data Document = Document ([Printable] -> [Printable]) | Empty -- | renders a 'Doc' into a 'String' with control codes for the --- special features of the doc. -renderString :: RenderMode -> Doc -> String +-- special features of the 'Doc'. +renderString :: Doc -> String renderString = renderStringWith simplePrinters' -- | renders a 'Doc' into a 'String' using a given set of printers. -renderStringWith :: Printers' -> RenderMode -> Doc -> String -renderStringWith prs target d = concatMap (toString target) $ renderWith prs d - where toString Standard (S s) = s - toString Encode (S s) = BC.unpack . encodeLocale $ s - toString Standard (PS ps) = BC.unpack ps - toString Encode (PS ps) = BC.unpack ps - toString Standard (Both s _) = s - toString Encode (Both s _) = BC.unpack . encodeLocale $ s +-- If content is only available as 'ByteString', decode according to +-- the current locale. +renderStringWith :: Printers' -> Doc -> String +renderStringWith prs d = concatMap (toString) $ renderWith prs d + where toString (S s) = s + toString (PS ps) = decodeLocale ps + toString (Both s _) = s -- | renders a 'Doc' into 'B.ByteString' with control codes for the -- special features of the Doc. See also 'readerString'. -renderPS :: RenderMode -> Doc -> B.ByteString +renderPS :: Doc -> B.ByteString renderPS = renderPSWith simplePrinters' -- | renders a 'Doc' into a list of 'PackedStrings', one for each line. -renderPSs :: RenderMode -> Doc -> [B.ByteString] +renderPSs :: Doc -> [B.ByteString] renderPSs = renderPSsWith simplePrinters' --- | renders a doc into a 'B.ByteString' using a given set of printers. -renderPSWith :: Printers' -> RenderMode -> Doc -> B.ByteString -renderPSWith prs target d = B.concat $ renderPSsWith prs target d +-- | renders a 'Doc' into a 'B.ByteString' using a given set of printers. +renderPSWith :: Printers' -> Doc -> B.ByteString +renderPSWith prs d = B.concat $ renderPSsWith prs d -- | renders a 'Doc' into a list of 'PackedStrings', one for each --- chunk of text that was added to the doc, using the given set of +-- chunk of text that was added to the 'Doc', using the given set of -- printers. -renderPSsWith :: Printers' -> RenderMode -> Doc -> [B.ByteString] -renderPSsWith prs target d = map (toPS target) $ renderWith prs d - where toPS Standard (S s) = BC.pack s - toPS Encode (S s) = encodeLocale s - toPS Standard (PS ps) = ps - toPS Encode (PS ps) = ps - toPS Standard (Both _ ps) = ps - toPS Encode (Both _ ps) = ps +renderPSsWith :: Printers' -> Doc -> [B.ByteString] +renderPSsWith prs d = map toPS $ renderWith prs d + where toPS (S s) = encodeLocale s + toPS (PS ps) = ps + toPS (Both _ ps) = ps -- | renders a 'Doc' into a list of 'Printables' using a set of -- printers. Each item of the list corresponds to a string that was --- added to the doc. +-- added to the 'Doc'. renderWith :: Printers' -> Doc -> [Printable] renderWith ps (Doc d) = case d (initState ps) of Empty -> [] @@ -327,21 +301,16 @@ -- of the Doc abstraction prefixLines :: Doc -> Doc -> Doc prefixLines prefixer prefixee = - vcat $ map (prefixer <+>) $ map packedString $ linesPS $ - -- this will just get round-tripped back into a Doc, - renderPS Standard prefixee + vcat $ map (prefixer <+>) $ map packedString $ linesPS $ renderPS prefixee -- TODO try to find another way to do this, it's rather a violation -- of the Doc abstraction insertBeforeLastline :: Doc -> Doc -> Doc insertBeforeLastline a b = - -- as this will just get round-tripped back into a Doc, - -- we use 'Standard' as the Target type so the encoding - -- is left alone - case reverse $ map packedString $ linesPS $ renderPS Standard a of - (ll:ls) -> vcat (reverse ls) $$ b $$ ll - [] -> error "empty Doc given as first argument of Printer.insert_before_last_line" - + case reverse $ map packedString $ linesPS $ renderPS a of + (ll:ls) -> vcat (reverse ls) $$ b $$ ll + [] -> + error "empty Doc given as first argument of Printer.insert_before_last_line" lineColor :: Color -> Doc -> Doc lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of @@ -350,7 +319,7 @@ hiddenPrefix :: String -> Doc -> Doc hiddenPrefix s (Doc d) = Doc $ \st -> let pr = printers st - p = S (renderStringWith pr Standard $ hiddenText s) + p = S (renderStringWith pr $ hiddenText s) st' = st { currentPrefix = currentPrefix st . (p:) } in case d st' of Document d'' -> Document $ (p:) . d'' @@ -364,7 +333,7 @@ -- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the -- Doc as both a String and a 'B.ByteString'. unsafeBothText :: String -> Doc -unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s)) +unsafeBothText s = Doc $ simplePrinter (Both s (encodeLocale s)) -- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable' packedString :: B.ByteString -> Doc @@ -478,6 +447,7 @@ infixr 6 `append` infixr 6 <+> +infixr 5 `vplus` infixr 5 $$ -- | The empty 'Doc' @@ -487,6 +457,9 @@ doc :: ([Printable] -> [Printable]) -> Doc doc f = Doc $ const $ Document f +instance Semigroup Doc where + (<>) = append + -- | 'mappend' ('<>') is concatenation, 'mempty' is the 'empty' 'Doc' instance Monoid Doc where mempty = empty @@ -511,7 +484,7 @@ Empty -> s Document bf -> bf s) --- | @a '<+>' b@ is @a@ followed by a space, then @b@ +-- | @a '<+>' b@ is @a@ followed by @b@ with a space in between if both are non-empty (<+>) :: Doc -> Doc -> Doc Doc a <+> Doc b = Doc $ \st -> case a st of @@ -533,15 +506,25 @@ where pf = currentPrefix st sf = lineColorS $ printers st +-- | @vplus a b@ is @a@ above @b@ with an empty line in between if both are non-empty +vplus :: Doc -> Doc -> Doc +Doc a `vplus` Doc b = + Doc $ \st -> case a st of + Empty -> b st + Document af -> + Document (\s -> af $ case b st of + Empty -> s + Document bf -> sf (newlineP:newlineP:pf (bf s))) + where pf = currentPrefix st + sf = lineColorS $ printers st + -- | Pile 'Doc's vertically vcat :: [Doc] -> Doc -vcat [] = empty -vcat ds = foldr1 ($$) ds +vcat = foldr ($$) empty -- | Pile 'Doc's vertically, with a blank line in between vsep :: [Doc] -> Doc -vsep [] = empty -vsep ds = foldr1 ($$) $ intersperse (text "") ds +vsep = foldr vplus empty -- | Concatenate 'Doc's horizontally hcat :: [Doc] -> Doc diff --git a/src/Darcs/Util/Printer/Color.hs b/src/Darcs/Util/Printer/Color.hs --- a/src/Darcs/Util/Printer/Color.hs +++ b/src/Darcs/Util/Printer/Color.hs @@ -8,18 +8,16 @@ import Darcs.Prelude import Darcs.Util.Printer - ( Printer, Printers, Printers'(..), Printable(..), Color(..), RenderMode(..) + ( Printer, Printers, Printers'(..), Printable(..), Color(..) , invisiblePrinter, (<>), (), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat , unsafeText, unsafePackedString , renderStringWith, prefix ) -import Control.Monad ( liftM ) -import Control.Exception ( catch, IOException ) import Debug.Trace ( trace ) import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr ) import Data.Bits ( bit, xor ) -import System.Environment ( getEnv ) +import System.Environment ( lookupEnv ) import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd) import qualified Data.ByteString as B (null, init) import System.IO.Unsafe ( unsafePerformIO ) @@ -35,20 +33,19 @@ cr = unsafeBothText "\r" errorDoc :: Doc -> a -errorDoc = error . showDoc Encode +errorDoc = error . showDoc traceDoc :: Doc -> a -> a -traceDoc d = trace (showDoc Encode d) +traceDoc d = trace (showDoc d) assertDoc :: Maybe Doc -> a -> a assertDoc Nothing x = x assertDoc (Just e) _ = errorDoc e -showDoc :: RenderMode -> Doc -> String +showDoc :: Doc -> String showDoc = renderStringWith (fancyPrinters stderr) --- policy --- | the 'Policy' type is a record containing the variables which control +-- | The 'Policy' type is a record containing the variables which control -- how 'Doc's will be rendered on some output. data Policy = Policy { poColor :: Bool -- ^ overall use of color , poEscape :: Bool -- ^ overall use of escaping @@ -74,8 +71,8 @@ envDontEscapeAnything <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING" envDontEscapeIsprint <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT" - envUseIsprint <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility - envDontEscape8bit <- getEnvBool "DARCS_DONT_ESCAPE_8BIT" + envUseIsprint <- getEnvBool "DARCS_USE_ISPRINT" + envEscape8bit <- getEnvBool "DARCS_ESCAPE_8BIT" envDontEscapeExtra <- getEnvString "DARCS_DONT_ESCAPE_EXTRA" envEscapeExtra <- getEnvString "DARCS_ESCAPE_EXTRA" @@ -95,7 +92,7 @@ poEscape = not envDontEscapeAnything, poLineColor= doColor && envDoColorLines, poIsprint = envDontEscapeIsprint || envUseIsprint, - po8bit = envDontEscape8bit, + po8bit = not envEscape8bit, poNoEscX = envDontEscapeExtra, poEscX = envEscapeExtra, poTrailing = not envDontEscapeTrailingSpace, @@ -105,9 +102,8 @@ poSpace = False } where - getEnvBool s = (/= "0") `liftM` safeGetEnv s - safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0" - getEnvString s = getEnv s `catch` \(_ :: IOException) -> return "" + getEnvBool s = maybe False (/= "0") <$> lookupEnv s + getEnvString s = maybe "" id <$> lookupEnv s {- @@ -336,47 +332,47 @@ environmentHelpEscape :: ([String], [String]) environmentHelpEscape = (["DARCS_DONT_ESCAPE_ANYTHING", - "DARCS_DONT_ESCAPE_ISPRINT", - "DARCS_DONT_ESCAPE_8BIT", "DARCS_DONT_ESCAPE_EXTRA", - "DARCS_ESCAPE_EXTRA"],[ + "DARCS_ESCAPE_EXTRA", + "DARCS_DONT_ESCAPE_ISPRINT", + "DARCS_ESCAPE_8BIT"],[ "Darcs needs to escape certain characters when printing patch contents to", - "a terminal. Characters like backspace can otherwise hide patch content", - "from the user, and other character sequences can even in some cases", - "redirect commands to the shell if the terminal allows it.", + "a terminal, depending on the encoding specified in your locale setting.", "", - "By default darcs will only allow printable 7-bit ASCII", - "characters (including space), and the two control characters tab and", - "newline. All other octets are printed in quoted form (as `^`", - "or `\\`).", + "By default, darcs assumes that your locale encoding is ASCII compatible.", + "This includes UTF-8 and some 8-bit encodings like ISO/IEC-8859 (including", + "its variants). Since ASCII contains control characters like backspace", + "(which could hide patch content from the user when printed literally to", + "the terminal), and even ones that may introduce security risks such as", + "redirecting commands to the shell, darcs needs to escape such characters.", + "They are printed as `^` or `\\`. Darcs also uses", + "special markup for line endings that are preceeded by white space, since", + "the white space would otherwise not be recognizable.", "", - "Darcs has some limited support for locales. If the system's locale is a ", - "single-byte character encoding, like the Latin encodings, you can set the", - "environment variable DARCS_DONT_ESCAPE_ISPRINT to 1 and darcs will display", - "all the printables in the current system locale instead of just the ASCII", - "ones. NOTE: This curently does not work on some architectures if darcs", - "is compiled with GHC 6.4 or later. Some non-ASCII control characters might", - "be printed and can possibly spoof the terminal.", + "If you use an encoding that is not ASCII compatible, things are somewhat", + "less smooth. Such encodings include UTF-16 and UTF-32, as well as many of", + "the encodings that became obsolete with unicode. In this case you have two", + "options: you can set DARCS_DONT_ESCAPE_ANYTHING to 1. Then everything that", + "doesn't flip code sets should work, and so will all the bells and whistles", + "in your terminal. This environment variable can also be handy if you pipe", + "the output to a pager or external filter that knows better than darcs how to", + "handle your encoding. Note that all escaping, including the special escaping", + "of any line ending spaces, will be turned off by this setting.", "", - "For multi-byte character encodings things are less smooth. UTF-8 will", - "work if you set DARCS_DONT_ESCAPE_8BIT to 1, but non-printables outside", - "the 7-bit ASCII range are no longer escaped. E.g., the extra control", - "characters from Latin-1 might leave your terminal at the mercy of the", - "patch contents. Space characters outside the 7-bit ASCII range are no", - "longer recognized and will not be properly escaped at line endings.", + "Another possibility is to explicitly tell darcs to not escape or escape", + "certain bytes, using DARCS_DONT_ESCAPE_EXTRA and DARCS_ESCAPE_EXTRA. Their", + "values should be strings consisting of the verbatim bytes in question. The", + "do-escapes take precedence over the dont-escapes. Space characters are still", + "escaped at line endings though. The special environment variable", + "DARCS_DONT_ESCAPE_TRAILING_CR turns off escaping of carriage return last on", + "the line (DOS style).", "", - "As a last resort you can set DARCS_DONT_ESCAPE_ANYTHING to 1. Then", - "everything that doesn't flip code sets should work, and so will all the", - "bells and whistles in your terminal. This environment variable can also", - "be handy if you pipe the output to a pager or external filter that knows", - "better than darcs how to handle your encoding. Note that all escaping,", - "including the special escaping of any line ending spaces, will be turned", - "off by this setting.", + "For historical reasons, darcs also supports DARCS_DONT_ESCAPE_ISPRINT and", + "DARCS_USE_ISPRINT (which are synonyms). These make sense only for 8-bit", + "encodings like ISO-8859 and are no longer needed since nowadays darcs does", + "the right thing here by default.", "", - "There are two environment variables you can set to explicitly tell darcs", - "to not escape or escape octets. They are DARCS_DONT_ESCAPE_EXTRA and", - "DARCS_ESCAPE_EXTRA. Their values should be strings consisting of the", - "verbatim octets in question. The do-escapes take precedence over the", - "dont-escapes. Space characters are still escaped at line endings though.", - "The special environment variable DARCS_DONT_ESCAPE_TRAILING_CR turns off", - "escaping of carriage return last on the line (DOS style)."]) + "Finally, if you are in a highly security sensitive situation (or just", + "paranoid for other reasons), you can set DARCS_ESCAPE_8BIT to 1. This will", + "cause darcs to escape every non-ASCII byte in addition to ASCII control", + "characters."]) diff --git a/src/Darcs/Util/Progress.hs b/src/Darcs/Util/Progress.hs --- a/src/Darcs/Util/Progress.hs +++ b/src/Darcs/Util/Progress.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} - - -- | -- Module : Darcs.Util.Progress -- Copyright : 2008 David Roundy @@ -30,7 +27,7 @@ import Prelude () -import Darcs.Prelude hiding ( lookup ) +import Darcs.Prelude import Prelude hiding (lookup) diff --git a/src/Darcs/Util/Ssh.hs b/src/Darcs/Util/Ssh.hs --- a/src/Darcs/Util/Ssh.hs +++ b/src/Darcs/Util/Ssh.hs @@ -50,7 +50,7 @@ import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.URL ( SshFilePath, sshFilePathOf, sshUhost, sshRepo, sshFile ) -import Darcs.Util.Text ( breakCommand ) +import Darcs.Util.Text ( breakCommand, showCommandLine ) import Darcs.Util.Exception ( prettyException, catchall ) import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) ) import Darcs.Util.Progress ( withoutProgress, debugMessage, debugFail ) @@ -177,9 +177,9 @@ newSshConnection rdarcs sshfp = do (sshcmd,sshargs_) <- getSSH SSH debugMessage $ "Starting new ssh connection to " ++ sshUhost sshfp - let sshargs = sshargs_ ++ [sshUhost sshfp, rdarcs, - "transfer-mode","--repodir",sshRepo sshfp] - debugMessage $ unwords (sshcmd : sshargs) + let sshargs = sshargs_ ++ ["--", sshUhost sshfp, rdarcs, + "transfer-mode", "--repodir", sshRepo sshfp] + debugMessage $ "Exec: " ++ showCommandLine (sshcmd:sshargs) (i,o,e,_) <- runInteractiveProcess sshcmd sshargs Nothing Nothing do hSetBinaryMode i True @@ -245,7 +245,8 @@ -- remote 'darcs transfer-mode' does not work => use scp let u = escape_dollar $ sshFilePathOf src (scpcmd, args) <- getSSH SCP - let scp_args = filter (/="-q") args ++ [u, dest] + let scp_args = filter (/="-q") args ++ ["--", u, dest] + debugMessage $ "Exec: " ++ showCommandLine (scpcmd:scp_args) (r, scp_err) <- readInteractiveProcess scpcmd scp_args unless (r == ExitSuccess) $ throwIO $ ExecException scpcmd scp_args (AsIs,AsIs,AsIs) scp_err diff --git a/src/Darcs/Util/Text.hs b/src/Darcs/Util/Text.hs --- a/src/Darcs/Util/Text.hs +++ b/src/Darcs/Util/Text.hs @@ -13,6 +13,7 @@ , breakCommand , quote , pathlist + , showCommandLine ) where import Prelude () @@ -21,7 +22,7 @@ import Control.Arrow ( first ) import Data.List ( intercalate ) -import Darcs.Util.Printer ( Doc, (<>), renderString, RenderMode(..), quoted, hsep ) +import Darcs.Util.Printer ( Doc, (<>), renderString, quoted, hsep ) sentence :: Doc -> Doc sentence = (<> ".") @@ -56,7 +57,7 @@ -- | Quote a string for screen output. quote :: String -> String -quote = renderString Encode . quoted +quote = renderString . quoted -- | Format a list of 'FilePath's as quoted text. It deliberately refuses to -- use English.andClauses but rather separates the quoted strings only with a @@ -64,3 +65,10 @@ -- another shell command. pathlist :: [FilePath] -> Doc pathlist paths = hsep (map quoted paths) + +-- | Produce a String composed by the elements of [String] each enclosed in +-- double quotes. +showCommandLine :: [String] -> String +showCommandLine strings = showCommandLine' ['"'] strings + where showCommandLine' x xs = + x ++ intercalate (x ++ " " ++ x) xs ++ x diff --git a/src/Darcs/Util/Tree.hs b/src/Darcs/Util/Tree.hs --- a/src/Darcs/Util/Tree.hs +++ b/src/Darcs/Util/Tree.hs @@ -2,7 +2,6 @@ -- -- BSD3 {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-} -{-# LANGUAGE CPP #-} -- | The abstract representation of a Tree and useful abstract utilities to -- handle those. @@ -32,13 +31,15 @@ , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay , addMissingHashes ) where +import Prelude () +import Darcs.Prelude hiding ( filter ) + import Control.Exception( catch, IOException ) -import Prelude hiding( lookup, filter, all, (<$>) ) import Darcs.Util.Path import Darcs.Util.Hash -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as B import qualified Data.Map as M import Data.Maybe( catMaybes, isNothing ) @@ -47,8 +48,6 @@ import Control.Monad( filterM ) import Control.Applicative( (<$>) ) -#include "impossible.h" - -------------------------------- -- Tree, Blob and friends -- @@ -94,7 +93,7 @@ itemType (SubTree _) = TreeType itemType (Stub _ _) = TreeType -emptyTree :: (Monad m) => Tree m +emptyTree :: Tree m emptyTree = Tree { items = M.empty , treeHash = NoHash } @@ -104,14 +103,14 @@ makeBlob :: (Monad m) => BL.ByteString -> Blob m makeBlob str = Blob (return str) (sha256 str) -makeBlobBS :: (Monad m) => BS.ByteString -> Blob m +makeBlobBS :: (Monad m) => B.ByteString -> Blob m makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s) -makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m +makeTree :: [(Name,TreeItem m)] -> Tree m makeTree l = Tree { items = M.fromList l , treeHash = NoHash } -makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m +makeTreeWithHash :: [(Name,TreeItem m)] -> Hash -> Tree m makeTreeWithHash l h = Tree { items = M.fromList l , treeHash = h } @@ -255,7 +254,7 @@ -- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a -- identical to @tree@, but only has those items that are present in both -- @tree@ and @guide@. The @guide@ Tree may not contain any stubs. -restrict :: (FilterTree t m, Monad n) => Tree n -> t m -> t m +restrict :: (FilterTree t m) => Tree n -> t m -> t m restrict guide tree = filter accept tree where accept path item = case (find guide path, item) of @@ -312,7 +311,7 @@ -- not share any identical subtrees. They are derived from the first and second -- parameters respectively and they are always fully expanded. It might be -- advantageous to feed the result into 'zipFiles' or 'zipTrees'. -diffTrees :: forall m. (Functor m, Monad m) => Tree m -> Tree m -> m (Tree m, Tree m) +diffTrees :: forall m. (Monad m) => Tree m -> Tree m -> m (Tree m, Tree m) diffTrees left right = if treeHash left `match` treeHash right then return (emptyTree, emptyTree) @@ -398,7 +397,7 @@ bug $ "descending in modifyTree, case = Nothing, path = " ++ show p_ countmap :: forall a k. M.Map k a -> Int -countmap = M.fold (\_ i -> i + 1) 0 +countmap = M.foldr (\_ i -> i + 1) 0 updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m updateSubtrees fun t = @@ -409,11 +408,11 @@ update (_, Stub _ _) = bug "Stubs not supported in updateTreePostorder" -- | Does /not/ expand the tree. -updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) +updateTree :: (Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) updateTree fun t = partiallyUpdateTree fun (\_ _ -> True) t -- | Does /not/ expand the tree. -partiallyUpdateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) +partiallyUpdateTree :: (Monad m) => (TreeItem m -> m (TreeItem m)) -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m) partiallyUpdateTree fun predi t' = go (AnchoredPath []) t' where go path t = do @@ -433,7 +432,7 @@ -- object, nor it is allowed for the overlay to add new objects to base. This -- means that the overlay Tree should be a subset of the base Tree (although -- any extraneous items will be ignored by the implementation). -overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m +overlay :: (Monad m) => Tree m -> Tree m -> Tree m overlay base over = Tree { items = M.fromList immediate , treeHash = NoHash } where immediate = [ (n, get n) | (n, _) <- listImmediate base ] @@ -448,7 +447,7 @@ (Just x, _) -> x (_, _) -> bug $ "Unexpected case in overlay at get " ++ show n ++ "." -addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) +addMissingHashes :: (Monad m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) addMissingHashes make = updateTree update -- use partiallyUpdateTree here where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x }) update (File blob@(Blob con NoHash)) = diff --git a/src/Darcs/Util/Tree/Hashed.hs b/src/Darcs/Util/Tree/Hashed.hs --- a/src/Darcs/Util/Tree/Hashed.hs +++ b/src/Darcs/Util/Tree/Hashed.hs @@ -36,10 +36,10 @@ import Codec.Compression.GZip( decompress, compress ) import Control.Applicative( (<$>) ) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as BS +import qualified Data.ByteString as B import Data.List( sortBy ) import Data.Maybe( fromJust, isJust ) @@ -48,6 +48,7 @@ import Darcs.Util.Path import Darcs.Util.ByteString ( FileSegment, readSegment ) import Darcs.Util.Hash +import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Tree import Darcs.Util.Tree.Monad @@ -55,18 +56,15 @@ -- Utilities for coping with the darcs directory format. -- -darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString -darcsEncodeWhiteBS = BS8.pack . encodeWhite . BS8.unpack - -decodeDarcsHash :: BS8.ByteString -> Hash -decodeDarcsHash bs = case BS8.split '-' bs of - [s, h] | BS8.length s == 10 -> decodeBase16 h +decodeDarcsHash :: BC.ByteString -> Hash +decodeDarcsHash bs = case BC.split '-' bs of + [s, h] | BC.length s == 10 -> decodeBase16 h _ -> decodeBase16 bs -decodeDarcsSize :: BS8.ByteString -> Maybe Int -decodeDarcsSize bs = case BS8.split '-' bs of - [s, _] | BS8.length s == 10 -> - case reads (BS8.unpack s) of +decodeDarcsSize :: BC.ByteString -> Maybe Int +decodeDarcsSize bs = case BC.split '-' bs of + [s, _] | BC.length s == 10 -> + case reads (BC.unpack s) of [(x, _)] -> Just x _ -> Nothing _ -> Nothing @@ -78,41 +76,41 @@ where prefix Nothing = "" prefix (Just s') = formatSize s' ++ "-" formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n - hash = BS8.unpack (encodeBase16 h) + hash = BC.unpack (encodeBase16 h) ---------------------------------------------- -- Darcs directory format. -- -darcsFormatDir :: Tree m -> Maybe BL8.ByteString -darcsFormatDir t = BL8.fromChunks . concat <$> +darcsFormatDir :: Tree m -> Maybe BLC.ByteString +darcsFormatDir t = BLC.fromChunks . concat <$> mapM string (sortBy cmp $ listImmediate t) - where cmp (Name a, _) (Name b, _) = compare a b - string (Name name, item) = + where cmp (a, _) (b, _) = compare a b + string (name, item) = do header <- case item of - File _ -> Just $ BS8.pack "file:\n" - _ -> Just $ BS8.pack "directory:\n" + File _ -> Just $ BC.pack "file:\n" + _ -> Just $ BC.pack "directory:\n" hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x return [ header - , darcsEncodeWhiteBS name - , BS8.singleton '\n' - , hash, BS8.singleton '\n' ] + , encodeWhiteName name + , BC.singleton '\n' + , hash, BC.singleton '\n' ] -darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)] -darcsParseDir content = parse (BL8.split '\n' content) +darcsParseDir :: BLC.ByteString -> [(ItemType, Name, Maybe Int, Hash)] +darcsParseDir content = parse (BLC.split '\n' content) where parse (t:n:h':r) = (header t, - Name $ BS8.pack $ decodeWhite (BL8.unpack n), + decodeWhiteName $ B.concat $ BL.toChunks n, decodeDarcsSize hash, decodeDarcsHash hash) : parse r - where hash = BS8.concat $ BL8.toChunks h' + where hash = BC.concat $ BLC.toChunks h' parse _ = [] header x - | x == BL8.pack "file:" = BlobType - | x == BL8.pack "directory:" = TreeType - | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x + | x == BLC.pack "file:" = BlobType + | x == BLC.pack "directory:" = TreeType + | otherwise = error $ "Error parsing darcs hashed dir: " ++ BLC.unpack x ---------------------------------------- -- Utilities. @@ -130,7 +128,7 @@ darcsUpdateDirHashes = updateSubtrees update where update t = t { treeHash = darcsTreeHash t } -darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) +darcsUpdateHashes :: (Monad m) => Tree m -> m (Tree m) darcsUpdateHashes = updateTree update where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } update (File blob@(Blob con _)) = @@ -138,12 +136,12 @@ return $ File (Blob con hash) update stub = return stub -darcsHash :: (Monad m, Functor m) => TreeItem m -> m Hash +darcsHash :: (Monad m) => TreeItem m -> m Hash darcsHash (SubTree t) = return $ darcsTreeHash t darcsHash (File blob) = sha256 <$> readBlob blob darcsHash _ = return NoHash -darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) +darcsAddMissingHashes :: (Monad m) => Tree m -> m (Tree m) darcsAddMissingHashes = addMissingHashes darcsHash ------------------------------------------- @@ -154,11 +152,12 @@ -- and with a given @hash@. readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)] readDarcsHashedDir dir h = do + debugMessage $ "readDarcsHashedDir: " ++ dir ++ " " ++ BC.unpack (encodeBase16 (snd h)) exist <- doesFileExist $ fst (darcsLocation dir h) unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h) compressed <- readSegment $ darcsLocation dir h let content = decompress compressed - return $ if BL8.null compressed + return $ if BLC.null compressed then [] else darcsParseDir content @@ -201,7 +200,7 @@ _ <- mapM (dump . fromJust) dirs return $ darcsTreeHash t where dump bits = - do let name = dir BS8.unpack (encodeBase16 $ sha256 bits) + do let name = dir BC.unpack (encodeBase16 $ sha256 bits) exist <- doesFileExist name unless exist $ BL.writeFile name (compress bits) @@ -209,7 +208,7 @@ -- it is kept untouched and is assumed to have the right content. XXX Corrupt -- files should be probably renamed out of the way automatically or something -- (probably when they are being read though). -fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO () +fsCreateHashedFile :: FilePath -> BLC.ByteString -> TreeIO () fsCreateHashedFile fn content = liftIO $ do exist <- doesFileExist fn @@ -230,16 +229,16 @@ updateFile b@(Blob _ !h) = do content <- liftIO $ readBlob b - let fn = dir BS8.unpack (encodeBase16 h) + let fn = dir BC.unpack (encodeBase16 h) nblob = Blob (decompress <$> rblob) h - rblob = BL.fromChunks . return <$> BS.readFile fn + rblob = BL.fromChunks . return <$> B.readFile fn newcontent = compress content fsCreateHashedFile fn newcontent return nblob updateSub s = do let !hash = treeHash s Just dirdata = darcsFormatDir s - fn = dir BS8.unpack (encodeBase16 hash) + fn = dir BC.unpack (encodeBase16 hash) fsCreateHashedFile fn (compress dirdata) return s diff --git a/src/Darcs/Util/Tree/Monad.hs b/src/Darcs/Util/Tree/Monad.hs --- a/src/Darcs/Util/Tree/Monad.hs +++ b/src/Darcs/Util/Tree/Monad.hs @@ -1,7 +1,7 @@ -- Copyright (C) 2009-2011 Petr Rockai -- -- BSD3 -{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances, FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-} -- | An experimental monadic interface to Tree mutation. The main idea is to -- simulate IO-ish manipulation of real filesystem (that's the state part of @@ -32,7 +32,7 @@ import Data.Int( Int64 ) import Data.Maybe( isNothing, isJust ) -import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Lazy as BL import Control.Monad.RWS.Strict import qualified Data.Map as M @@ -88,18 +88,18 @@ , maxage = 0 , update = u } -flush :: (Functor m, Monad m) => TreeMonad m () +flush :: (Monad m) => TreeMonad m () flush = do changed' <- map fst . M.toList <$> gets changed dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ] modify $ \st -> st { changed = M.empty, changesize = 0 } forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem -runTreeMonad' :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) +runTreeMonad' :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) runTreeMonad' action initial = do (out, final, _) <- runRWST action (AnchoredPath []) initial return (out, tree final) -runTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) +runTreeMonad :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) runTreeMonad action initial = do let action' = do x <- action flush @@ -111,7 +111,7 @@ -- to their effect of writing a modified tree to disk). The actions can do both -- read and write -- reads are passed through to the actual filesystem, but the -- writes are held in memory in a form of modified Tree. -virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) +virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) virtualTreeMonad action t = runTreeMonad' action $ initialState t (\_ -> return NoHash) (\_ x -> return x) @@ -121,7 +121,7 @@ -- | Modifies an item in the current Tree. This action keeps an account of the -- modified data, in changed and changesize, for subsequent flush -- operations. Any modifications (as in "modifyTree") are allowed. -modifyItem :: (Functor m, Monad m) +modifyItem :: (Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () modifyItem path item = do path' <- (`catPaths` path) `fmap` currentDirectory @@ -139,7 +139,7 @@ , maxage = age + 1 , changesize = changesize st + change } -renameChanged :: (Functor m, Monad m) +renameChanged :: (Monad m) => AnchoredPath -> AnchoredPath -> TreeMonad m () renameChanged from to = modify $ \st -> st { changed = rename' $ changed st } where rename' = M.fromList . map renameone . M.toList @@ -152,13 +152,13 @@ -- 'sync' implementation for a particular storage format. The presumed use-case -- is that an existing in-memory Blob is replaced with a one referring to an -- on-disk file. -replaceItem :: (Functor m, Monad m) +replaceItem :: (Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () replaceItem path item = do path' <- (`catPaths` path) `fmap` currentDirectory modify $ \st -> st { tree = modifyTree (tree st) path' item } -flushItem :: forall m. (Monad m, Functor m) => AnchoredPath -> TreeMonad m () +flushItem :: forall m. (Monad m) => AnchoredPath -> TreeMonad m () flushItem path = do current <- gets tree case find current path of @@ -176,7 +176,7 @@ -- | If buffers are becoming large, sync, otherwise do nothing. -flushSome :: (Monad m, Functor m) => TreeMonad m () +flushSome :: (Monad m) => TreeMonad m () flushSome = do x <- gets changesize when (x > megs 100) $ do remaining <- go =<< sortBy age . M.toList <$> gets changed @@ -191,7 +191,7 @@ megs = (* (1024 * 1024)) age (_, (_, a)) (_, (_, b)) = compare a b -instance (Functor m, Monad m) => TreeRO (TreeMonad m) where +instance (Monad m) => TreeRO (TreeMonad m) where expandTo p = do t <- gets tree p' <- (`catPaths` p) `fmap` ask @@ -224,7 +224,7 @@ dir' <- expandTo dir local (const dir') act -instance (Functor m, Monad m) => TreeRW (TreeMonad m) where +instance (Monad m) => TreeRW (TreeMonad m) where writeFile p con = do _ <- expandTo p modifyItem p (Just blob) @@ -264,17 +264,17 @@ let item = find tr from' unless (isNothing item) $ modifyItem to item -findM' :: forall m a. (Monad m, Functor m) +findM' :: forall m a . (Monad m) => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a findM' what t path = fst <$> virtualTreeMonad (look path) t where look :: AnchoredPath -> TreeMonad m a look = expandTo >=> \p' -> flip what p' <$> gets tree -findM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) +findM :: (Monad m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) findM = findM' find -findTreeM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Tree m)) +findTreeM :: (Monad m) => Tree m -> AnchoredPath -> m (Maybe (Tree m)) findTreeM = findM' findTree -findFileM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Blob m)) +findFileM :: (Monad m) => Tree m -> AnchoredPath -> m (Maybe (Blob m)) findFileM = findM' findFile diff --git a/src/Darcs/Util/Tree/Plain.hs b/src/Darcs/Util/Tree/Plain.hs --- a/src/Darcs/Util/Tree/Plain.hs +++ b/src/Darcs/Util/Tree/Plain.hs @@ -26,12 +26,12 @@ ) where import Data.Maybe( catMaybes ) -import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import System.FilePath( () ) import System.Directory( getDirectoryContents , createDirectoryIfMissing ) -import Bundled.Posix( getFileStatus, isDirectory, isRegularFile, FileStatus ) +import System.Posix.Files + ( getSymbolicLinkStatus, isDirectory, isRegularFile, FileStatus ) import Darcs.Util.Path import Darcs.Util.File ( withCurrentDirectory ) @@ -45,7 +45,7 @@ readPlainDir dir = withCurrentDirectory dir $ do items <- getDirectoryContents "." - sequence [ do st <- getFileStatus s + sequence [ do st <- getSymbolicLinkStatus s return (s, st) | s <- items, s `notElem` [ ".", ".." ] ] @@ -53,14 +53,14 @@ readPlainTree dir = do items <- readPlainDir dir let subs = catMaybes [ - let name = Name (BS8.pack name') + let name = makeName name' in case status of _ | isDirectory status -> Just (name, Stub (readPlainTree (dir name')) NoHash) - _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name) NoHash) + _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name') NoHash) _ -> Nothing | (name', status) <- items ] return $ makeTree subs - where readBlob' (Name name) = readSegment (dir BS8.unpack name, Nothing) + where readBlob' name = readSegment (dir name, Nothing) -- | Write out /full/ tree to a plain directory structure. If you instead want -- to make incremental updates, refer to "Darcs.Util.Tree.Monad". diff --git a/src/Darcs/Util/URL.hs b/src/Darcs/Util/URL.hs --- a/src/Darcs/Util/URL.hs +++ b/src/Darcs/Util/URL.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - {- Copyright (C) 2004 David Roundy @@ -63,8 +61,6 @@ import Data.Char ( isSpace ) import qualified System.FilePath as FP ( isRelative, isAbsolute, isValid ) import System.FilePath ( () ) - -#include "impossible.h" isRelative :: String -> Bool isRelative "" = bug "Empty filename in isRelative" diff --git a/src/fpstring.c b/src/fpstring.c deleted file mode 100644 --- a/src/fpstring.c +++ /dev/null @@ -1,69 +0,0 @@ -/* - * Copyright (C) 2003 David Roundy - * Most of the UTF code is Copyright (C) 1999-2001 Free Software Foundation, Inc. - * This file is part of darcs. - * - * Darcs is free software; you can redistribute it and/or modify it under - * the terms of the GNU Library General Public License as published by the - * Free Software Foundation; either version 2 of the License, or (at your - * option) any later version. - * - * You should have received a copy of the GNU Library General Public - * License along with the GNU LIBICONV Library; see the file COPYING.LIB. - * If not, write to the Free Software Foundation, Inc., 51 Franklin Street, - * Fifth Floor, Boston, MA 02110-1301, USA. - * - */ -#include "fpstring.h" - -#include -#include -#include - - -#ifdef _WIN32 -#include -#else -#include -#endif - -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)); - -} - -/* Conversion to and from hex */ - -void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars) -{ - static char hex[] = "0123456789abcdef"; - unsigned char *end; - - for (end = from + num_chars; from < end; from++) { - *dest++ = hex[*from >> 4]; - *dest++ = hex[*from & 0xf]; - } - - return; -} - -#define NYBBLE_TO_INT(c) \ - ((c) - ((c) >= 'a' ? 'a' - 10 : '0')) - -void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars) -{ - unsigned char *end; - unsigned char c; - - end = dest + num_chars; - while (dest < end) { - c = NYBBLE_TO_INT(*from) << 4, from++; - *dest++ = c | NYBBLE_TO_INT(*from), from++; - } - - return; -} - diff --git a/src/fpstring.h b/src/fpstring.h deleted file mode 100644 --- a/src/fpstring.h +++ /dev/null @@ -1,7 +0,0 @@ -#include -#include - -int has_funky_char(const char *s, int len); - -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/h_iconv.c b/src/h_iconv.c deleted file mode 100644 --- a/src/h_iconv.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "h_iconv.h" - -// Wrapper functions, since iconv_open et al are macros in libiconv. -iconv_t darcs_iconv_open(const char *tocode, const char *fromcode) { - return iconv_open(tocode, fromcode); -} - -void darcs_iconv_close(iconv_t cd) { - iconv_close(cd); -} - -size_t darcs_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, - char **outbuf, size_t *outbytesleft) { - // Cast inbuf to (void*) so that it works both on Solaris, which expects - // a (const char**), and on other platforms (e.g. Linux), which expect - // a (char **). - return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft); -} diff --git a/src/h_iconv.h b/src/h_iconv.h deleted file mode 100644 --- a/src/h_iconv.h +++ /dev/null @@ -1,9 +0,0 @@ -#include - -iconv_t darcs_iconv_open(const char *tocode, const char *fromcode); - -void darcs_iconv_close(iconv_t cd); - -size_t darcs_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, - char **outbuf, size_t *outbytesleft); - diff --git a/src/impossible.h b/src/impossible.h deleted file mode 100644 --- a/src/impossible.h +++ /dev/null @@ -1,8 +0,0 @@ -import qualified Darcs.Util.Bug as Bug_ - -#define darcsBug (\imp_funny_name -> imp_funny_name (__FILE__,__LINE__,__TIME__,__DATE__)) - -#define bug (darcsBug Bug_._bug) -#define impossible (darcsBug Bug_._impossible) -#define fromJust (darcsBug Bug_._fromJust) -#define bugDoc (darcsBug Bug_._bugDoc) diff --git a/src/win32/System/Posix/Files.hsc b/src/win32/System/Posix/Files.hsc --- a/src/win32/System/Posix/Files.hsc +++ b/src/win32/System/Posix/Files.hsc @@ -1,15 +1,18 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -module System.Posix.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink - , getFdStatus, getFileStatus, getSymbolicLinkStatus - , modificationTime, setFileMode, fileSize, fileMode - , stdFileMode, linkCount, createLink - , FileStatus - ) where +module System.Posix.Files + ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink + , getFdStatus, getFileStatus, getSymbolicLinkStatus + , modificationTime, setFileMode, fileSize, fileMode + , stdFileMode, FileStatus, fileID + , linkCount, createLink + ) where -import System.PosixCompat.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink - , getFdStatus, getFileStatus, getSymbolicLinkStatus - , modificationTime, setFileMode, fileSize, fileMode - , stdFileMode, FileStatus ) +import System.PosixCompat.Files + ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink + , getFdStatus, getFileStatus, getSymbolicLinkStatus + , modificationTime, setFileMode, fileSize, fileMode + , stdFileMode, FileStatus, fileID + ) import Foreign.C.String( CWString, withCWString ) import Foreign.C.Error( throwErrnoPathIf_ ) diff --git a/src/win32/System/Posix/IO.hsc b/src/win32/System/Posix/IO.hsc --- a/src/win32/System/Posix/IO.hsc +++ b/src/win32/System/Posix/IO.hsc @@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix.IO where -#if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612 +#if mingw32_HOST_OS import Foreign.C.String( withCWString ) #else import Foreign.C.String ( withCString ) diff --git a/tests/add.sh b/tests/add.sh --- a/tests/add.sh +++ b/tests/add.sh @@ -2,9 +2,8 @@ . ./lib rm -rf temp1 -mkdir temp1 +darcs init temp1 cd temp1 -darcs init touch foo bar darcs add foo bar @@ -38,6 +37,17 @@ darcs record -a -m add_foo -A x darcs remove foo darcs record -a -m del_foo -A x +cd .. +rm -rf temp1 + +# issue1162: add nonexistent slash + +rm -rf temp1 +darcs init temp1 +cd temp1 +not darcs add a/ 2> err +cat err +grep 'File a does not exist!' err cd .. rm -rf temp1 diff --git a/tests/apply-hunks.sh b/tests/apply-hunks.sh --- a/tests/apply-hunks.sh +++ b/tests/apply-hunks.sh @@ -3,10 +3,9 @@ # issue701 -rm -rf temp0 temp1 temp2 # step 1 -darcs init temp0 --darcs-2 +darcs init temp0 cd temp0 echo m1 > foo darcs record -lam m1 @@ -59,5 +58,3 @@ echo m2-a1-m4 > foo echo y | darcs mark-conflicts cd .. - -rm -rf temp0 temp1 temp2 diff --git a/tests/apply.sh b/tests/apply.sh --- a/tests/apply.sh +++ b/tests/apply.sh @@ -198,7 +198,6 @@ not grep '^ \* d' log # does not complain about an unrelated patch grep '^ \* y' log # complains about the offending one instead -cd .. rm -rf R S ## Test that apply --skip-conflicts filters the conflicts diff --git a/tests/clone.sh b/tests/clone.sh --- a/tests/clone.sh +++ b/tests/clone.sh @@ -2,7 +2,6 @@ . lib -rm -rf temp1 darcs init temp1 cd temp1 touch t.t @@ -11,11 +10,10 @@ DIR=`pwd` abs_to_context="${DIR}/my_context" cd .. -rm -rf temp2 + darcs clone temp1 --context="${abs_to_context}" temp2 darcs log --context --repo temp2 > repo2_context diff -u "${abs_to_context}" repo2_context -cd .. rm -rf temp1 temp2 # issue1865: cover interaction of clone --context with tags @@ -30,6 +28,7 @@ darcs log --context > my_context abs_to_context="$(pwd)/my_context" cd .. + darcs clone temp1 --context="${abs_to_context}" temp2 darcs log --context --repo temp2 > repo2_context diff -u "${abs_to_context}" repo2_context @@ -69,8 +68,8 @@ cd temp3 darcs log | not grep wobble cd .. -rm -rf temp1 temp2 temp3 +rm -rf temp1 temp2 temp3 # issue885: darcs clone --to-match @@ -81,20 +80,18 @@ firsthash=`darcs log --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"` echo second > b darcs record -lam 'second' - cd .. -darcs init temp2 -cd temp2 -darcs pull -a --match "hash $firsthash" ../temp1 - # pulling that patch works ok -cd .. -darcs clone --to-match "hash $firsthash" temp1 temp3 - # cloning up to that patch does not + +darcs clone --to-match "hash $firsthash" temp1 temp2 +test $(darcs log --count --repodir temp2) -eq 1 + +darcs clone --to-hash $firsthash temp1 temp3 +test $(darcs log --count --repodir temp3) -eq 1 + rm -rf temp1 temp2 temp3 # various tests for clone --tag -rm -rf temp1 temp2 darcs init temp1 cd temp1 echo ALL ignore-times >> _darcs/prefs/defaults @@ -112,8 +109,8 @@ darcs record -am EE echo F > foo darcs record -am FF - cd .. + darcs clone --tag 1.0 --repo-name temp2 temp1 cmp temp2/foo temp1/foo_version_1.0 rm -rf temp1 temp2 temp3 @@ -141,16 +138,19 @@ EOF darcs rec -alm 'Remove line 3' cd .. + darcs init temp2 cd temp2 echo ynyy | darcs pull ../temp1 darcs tag -m Tag darcs push -a ../temp1 cd .. + darcs clone --tag=Tag temp1 temp3 cd temp3 darcs check cd .. + rm -rf temp1 temp2 temp3 # clone --tag : check that pending looks ok @@ -163,6 +163,7 @@ rmdir d darcs rec -am 'rm d' cd .. + darcs clone --tag t temp1 temp2 cd temp2 if [ -f _darcs/patches/pending ]; then @@ -172,8 +173,8 @@ fi fi cd .. -rm -rf temp1 temp2 +rm -rf temp1 temp2 # issue2230 - darcs clone --context checks the validity of the context # file too late. diff --git a/tests/conflict-doppleganger.sh b/tests/conflict-doppleganger.sh --- a/tests/conflict-doppleganger.sh +++ b/tests/conflict-doppleganger.sh @@ -1,7 +1,5 @@ #!/usr/bin/env bash -#pragma repo-format darcs-1,darcs-2 - . lib # Tests for the doppleganger conflict bug. diff --git a/tests/conflict-fight.sh b/tests/conflict-fight.sh --- a/tests/conflict-fight.sh +++ b/tests/conflict-fight.sh @@ -2,12 +2,10 @@ . ./lib -rm -rf temp0 temp1 temp2 - # step 1 mkdir temp0 cd temp0 -darcs init --darcs-2 +darcs init echo temp0 > _darcs/prefs/author echo m1 > foo darcs add foo @@ -73,6 +71,3 @@ cd temp1 darcs pull -av ../temp2 cd .. - -rm -rf temp0 temp1 temp2 - diff --git a/tests/conflict-reporting.sh b/tests/conflict-reporting.sh --- a/tests/conflict-reporting.sh +++ b/tests/conflict-reporting.sh @@ -27,11 +27,8 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-1,darcs-2 - . lib -rm -rf R1 R2 mkdir R1 cd R1 darcs init diff --git a/tests/convert-darcs2.sh b/tests/convert-darcs2.sh new file mode 100644 --- /dev/null +++ b/tests/convert-darcs2.sh @@ -0,0 +1,64 @@ +#!/usr/bin/env bash + +## Tests for convert command based on previously checked results +## to generate new test material for this test, +## see bin/convert-writer.sh +## +## 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. + +. lib + +skip-formats darcs-1 + +runtest() { + opt=$1 + name=$2 + rm -rf temp + mkdir temp + cd temp + + mkdir repo + cd repo + darcs init --darcs-1 + darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$name.dpatch + cd .. + echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 $opt + mkdir empty-darcs2 + cd empty-darcs2 + darcs init --darcs-2 + cd .. + cd repo2 + darcs send --no-minimize -a -o ../$name-darcs2.dpatch ../empty-darcs2 + cd .. + diff -I'1 patch for repository ' -I'patches for repository ' -I'Oct 1' -u $TESTDATA/convert/darcs2/$name.dpatch $name-darcs2.dpatch +} + +for opt in --no-working-dir --with-working-dir; do + runtest $opt simple + runtest $opt twowayconflict + runtest $opt threewayconflict + runtest $opt threewayanddep + runtest $opt threewayandmultideps + runtest $opt resolution + runtest $opt tworesolutions +done diff --git a/tests/convert.sh b/tests/convert.sh deleted file mode 100644 --- a/tests/convert.sh +++ /dev/null @@ -1,62 +0,0 @@ -#!/usr/bin/env bash - -#pragma repo-format darcs-1 - -## Tests for convert command based on previously checked results -## to generate new test material for this test, -## see bin/convert-writer.sh -## -## 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. - -. lib - -grep darcs-1 $HOME/.darcs/defaults || exit 200 - -runtest() { - rm -rf temp - mkdir temp - cd temp - - mkdir repo - cd repo - darcs init --darcs-1 - darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$1.dpatch - cd .. - echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 - mkdir empty-darcs2 - cd empty-darcs2 - darcs init --darcs-2 - cd .. - cd repo2 - darcs send --no-minimize -a -o ../$1-darcs2.dpatch ../empty-darcs2 - cd .. - diff -I'1 patch for repository ' -I'patches for repository ' -I'Oct 1' -u $TESTDATA/convert/darcs2/$1.dpatch $1-darcs2.dpatch -} - -runtest simple -runtest twowayconflict -runtest threewayconflict -runtest threewayanddep -runtest threewayandmultideps -runtest resolution -runtest tworesolutions diff --git a/tests/convert_export.sh b/tests/convert_export.sh --- a/tests/convert_export.sh +++ b/tests/convert_export.sh @@ -34,6 +34,12 @@ echo 'Example content.' > d/f darcs record -lam 'Add d/f and e.' +# one more change, this time with non-ASCII file name, comment, and content +# as well as a space in the file name +# see http://bugs.darcs.net/issue2359 +echo 'Liebe Grüße' > e/'Liebe Grüße' +darcs record -lam 'Add file e/"Liebe Grüße"' + git init gitmirror darcs convert export --write-marks darcs-to-git.marks > fex @@ -49,3 +55,4 @@ git clone gitmirror gitmirror-clone diff e/f gitmirror-clone/e/f +diff e/"Liebe Grüße" gitmirror-clone/e/"Liebe Grüße" diff --git a/tests/data/many-files--darcs-2.tgz b/tests/data/many-files--darcs-2.tgz deleted file mode 100644 Binary files a/tests/data/many-files--darcs-2.tgz and /dev/null differ diff --git a/tests/data/many-files--hashed.tgz b/tests/data/many-files--hashed.tgz deleted file mode 100644 Binary files a/tests/data/many-files--hashed.tgz and /dev/null differ diff --git a/tests/diff.sh b/tests/diff.sh --- a/tests/diff.sh +++ b/tests/diff.sh @@ -1,6 +1,9 @@ #!/usr/bin/env bash . ./lib +export DARCS_TMPDIR=`pwd`/tmp +mkdir tmp + rm -rf temp1 darcs init temp1 cd temp1 diff --git a/tests/directory_confusion.sh b/tests/directory_confusion.sh deleted file mode 100644 --- a/tests/directory_confusion.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -T=temp -rm -rf "$T" -mkdir "$T" -echo "$T" -cd "$T" - -darcs initialize -echo text > afile.txt -darcs add afile.txt -darcs record --author me --all --no-test --name init -mkdir d -darcs add d -mkdir d/e -darcs add d/e -darcs mv afile.txt d/e/afile.txt -echo altered_text > d/e/afile.txt -darcs record --author me --all --no-test --name confusion -test ! -f _darcs/pristine/afile.txt -echo y/d/y | tr / \\012 | darcs unrecord -rm -rf "$T" diff --git a/tests/disable.sh b/tests/disable.sh --- a/tests/disable.sh +++ b/tests/disable.sh @@ -13,7 +13,7 @@ grep disable log rm log # --disable works from defaults - sub_commands="$(darcs $cmd --list-options | grep -v -- -- || true)" + sub_commands="$(darcs $cmd --list-options | grep -v -- -- | cut -f ';' -f 1 || true)" # disabling super commands in the defaults file is broken if test -z "$sub_commands"; then echo "$cmd --disable" > _darcs/prefs/defaults diff --git a/tests/failing-issue1014_identical_patches.sh b/tests/failing-issue1014_identical_patches.sh --- a/tests/failing-issue1014_identical_patches.sh +++ b/tests/failing-issue1014_identical_patches.sh @@ -4,7 +4,7 @@ # Set up a base repo. Our experiment will start from this point mkdir base cd base -darcs init --darcs-2 +darcs init printf "Line1\nLine2\nLine3\n" > foo darcs rec -alm Base cd .. diff --git a/tests/failing-issue1363-mark-conflicts.sh b/tests/failing-issue1363-mark-conflicts.sh deleted file mode 100644 --- a/tests/failing-issue1363-mark-conflicts.sh +++ /dev/null @@ -1,62 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1363 - mark-conflicts should report that there is a -## conflict to mark if apply/push say there are -## -## Copyright (C) 2010 Eric Kow -## Copyright (C) 2009 Thorkil Naur -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R S T # Another script may have left a mess. -darcs init --repo R # Create our test repos. -darcs init --repo S -darcs init --repo T - -cd R - touch f.txt - darcs add f.txt - darcs record -am "Empty f.txt" - echo f.txt contents >> f.txt - darcs record -am "Contents of f.txt" -cd .. - -cd S - echo yn | darcs pull ../R - rm f.txt - darcs record -am 'Remove f.txt in S' -cd .. - -cd T - echo ynn | darcs pull ../R - rm f.txt - darcs record -am 'Remove f.txt in T' - not darcs push -a ../R > log # should fail because of conflict - grep "There are conflicts" log -cd .. - -cd R - darcs pull -a ../S - darcs revert -a - darcs pull -a ../T - echo y | darcs mark-conflicts > log - not grep "No conflicts" log -cd .. diff --git a/tests/failing-issue1401_bug_in_get_extra.sh b/tests/failing-issue1401_bug_in_get_extra.sh --- a/tests/failing-issue1401_bug_in_get_extra.sh +++ b/tests/failing-issue1401_bug_in_get_extra.sh @@ -25,14 +25,8 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-2 - . lib -## This bug only affects darcs-2 repositories. -fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 200 - -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 @@ -40,7 +34,6 @@ 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/ --allow-conflicts #no conflict mark-up +echo y | 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-issue1610_get_extra.sh b/tests/failing-issue1610_get_extra.sh --- a/tests/failing-issue1610_get_extra.sh +++ b/tests/failing-issue1610_get_extra.sh @@ -25,12 +25,9 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-1 - . lib # Load some portability helpers. -# this test is not relevant for darcs 2 repositories -(not grep darcs-2 $HOME/.darcs/defaults) || exit 200 +# this test fails only for darcs 2 repositories rm -rf S1 S2 S3 # Another script may have left a mess. darcs init --repo S1 # Create our test repos. diff --git a/tests/failing-issue2138-whatsnew-s.sh b/tests/failing-issue2138-whatsnew-s.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue2138-whatsnew-s.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash +## Test for issue2138 - whatsnew --summary does not show conflicts +## +## Copyright (C) 2012 Lele Gaifax +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +rm -rf R S + +darcs init --repo R + +cd R +echo 'Example content.' > f +darcs record -lam 'Add f' +cd .. + +darcs get R S + +# Create a deliberate conflict +cd R +echo "Conflict on side R" >> f +darcs record -am 'CR' + +cd ../S +echo "Conflict on side S" >> f +darcs record -am 'CS' + +darcs pull -a ../R + +darcs whatsnew > out +cat out +grep "side R" out | wc -l | grep 1 +grep "side S" out | wc -l | grep 1 + +darcs whatsnew --summary > out +grep "^M!" out | wc -l | grep 1 + +cd .. +rm -rf R S diff --git a/tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh b/tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh deleted file mode 100644 --- a/tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2208 - darcs shouldn't fail to replace if unrecorded changes -## would make the replace succeed -## -## Copyright (C) 2012 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf R - -darcs init --repo R - -cd R - -echo -e 'foo\nbar' > testing - -darcs rec -alm 'Add testing file' - -echo -e 'baz\nbar' > testing - -# Darcs will complain here, since we've not recorded the fact that we've -# removed the occurrence of foo -darcs replace bar foo testing | not grep Skipping - -# We can get around this by recording, then replacing and amending the patch... -darcs rec -am "I don't want to have to record this!" - -darcs replace bar foo testing - -echo y | darcs amend -a - -# Check the workaround succeeded. -darcs changes --last 1 -v | grep 'replace.*bar.*foo' diff --git a/tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh b/tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh deleted file mode 100644 --- a/tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2243 - annotating a file with a blank first gives an "unknown" -## patch. -## -## Copyright (C) 2012 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -darcs init --repo R - -cd R - -echo -e "\nline2" > file - -darcs rec -alm 'Add file' - -darcs annotate file | not grep unknown diff --git a/tests/failing-issue2275_follows-symlinks.sh b/tests/failing-issue2275_follows-symlinks.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue2275_follows-symlinks.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Test for issue2275 - darcs follows symbolic links instead of properly +## ignoring them. +## When substituting a recorded file with a symbolic link, darcs becomes +## confused and associates the filename label to the content of the file +## pointed by the link. +## +## Copyright (C) 2017 Gian Piero Carrubba +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +abort_windows # Skip test on Windows + +darcs init --repo R # Create the test repo. +cd R + +touch g # Change the working tree. +echo 'This line should not appear in g.' > f +darcs record -lam 'Add f and g.' + +rm -f g # Remove g and create a link with the +ln -s f g # same name ponting to f + +darcs diff g | not grep -F '+This line should not appear in g.' + +cd .. diff --git a/tests/failing-issue2443-timestamp_index_keeps_unrecorded_addfile.sh b/tests/failing-issue2443-timestamp_index_keeps_unrecorded_addfile.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue2443-timestamp_index_keeps_unrecorded_addfile.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash +## Test for issue2443 - timestamp index keeps information about files +## added by unrecorded patches +## +## Copyright (C) 2017 Guillaume Hoffmann +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init R # Create our test repos. +cd R +touch a b c # add some files +darcs record -lam "Add a b c" +touch d +darcs record -lam "Add d" # add another file +echo yd | darcs unrecord +not darcs whatsnew # d is not supposed to be tracked diff --git a/tests/failing-issue2480-display-unicode-in-patch-content.sh b/tests/failing-issue2480-display-unicode-in-patch-content.sh deleted file mode 100644 --- a/tests/failing-issue2480-display-unicode-in-patch-content.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -. lib -darcs init R -cd R -touch äöüßÄÖÜ -darcs record -lam'added äöüßÄÖÜ' -#darcs log -s | grep './äöüßÄÖÜ' -DARCS_DONT_ESCAPE_8BIT=1 darcs log -s | grep './äöüßÄÖÜ' diff --git a/tests/failing-issue2548-inconsistent-pending-after-merge.sh b/tests/failing-issue2548-inconsistent-pending-after-merge.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue2548-inconsistent-pending-after-merge.sh @@ -0,0 +1,43 @@ +. lib + +darcs init r1 +cd r1 +touch f +darcs record -lam 'added f as file' +cd .. + +darcs init r2 +cd r2 +mkdir f +darcs record -lam 'added f as dir' + +darcs pull -a ../r1 + +# darcs-1 and darcs-2 resolve the conflict +# differently, we allow both +if cd f && cd ..; then + rmdir f +else + rm f +fi +mv f.\~0\~ f +# darcs whatsnew at this point reports nothing +not grep . ../whatsnew +# so revert should do nothing +darcs revert -a + +# at this point pending should definitely be empty +# and the following should fail (nothing to record) +if not darcs record -lam 'resolve conflict'; then + exit 0; +else + # check that what we record is at least consistent + # i.e. we have either addfile or adddir for f, but not both + darcs log -v --last=1 > ../log + if grep 'addfile ./f' ../log; then + not grep 'adddir ./f' ../log + fi + if grep 'adddir ./f' ../log; then + not grep 'addfile ./f' ../log + fi +fi diff --git a/tests/failing-look_for_replaces1.sh b/tests/failing-look_for_replaces1.sh --- a/tests/failing-look_for_replaces1.sh +++ b/tests/failing-look_for_replaces1.sh @@ -43,7 +43,7 @@ bar bar EOF -echo yyy | darcs amend-record --look-for-replaces +echo y | darcs amend-record --look-for-replaces -a cd .. rm -rf R diff --git a/tests/failing-look_for_replaces2.sh b/tests/failing-look_for_replaces2.sh deleted file mode 100644 --- a/tests/failing-look_for_replaces2.sh +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/env bash -## Failing test for --look-for-replaces combined with --look-for-moves -## -## Copyright (C) 2014 Guillaume Hoffmann -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf R -mkdir R -cd R - -darcs init -cat > file < file < "$filename" +darcs record -lam "comment" +darcs log -s | grep -c "$filename" | grep -w 1 +darcs log -v | grep -c "$filename" | grep -w 2 diff --git a/tests/hashed_inventory.sh b/tests/hashed_inventory.sh --- a/tests/hashed_inventory.sh +++ b/tests/hashed_inventory.sh @@ -31,7 +31,7 @@ mkdir temp1 cd temp1 -darcs init --darcs-1 +darcs init touch foo darcs add foo darcs rec -m t1 -a -A tester diff --git a/tests/hidden_conflict.sh b/tests/hidden_conflict.sh --- a/tests/hidden_conflict.sh +++ b/tests/hidden_conflict.sh @@ -2,10 +2,12 @@ . ./lib -rm -rf temp1 temp2 +# this test fails for darcs-1 repos +skip-formats darcs-1 + mkdir temp1 cd temp1 -darcs init --darcs-2 +darcs init echo first > a darcs add a darcs record -am 'first' @@ -28,5 +30,3 @@ darcs pull -a ../temp2 | grep conflict grep third a cd .. - -rm -rf temp1 temp2 diff --git a/tests/issue1162_add_nonexistent_slash.sh b/tests/issue1162_add_nonexistent_slash.sh deleted file mode 100644 --- a/tests/issue1162_add_nonexistent_slash.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/sh - -. ./lib - -not () { "$@" && exit 1 || :; } - -rm -rf temp -mkdir temp -cd temp -darcs init -not darcs add a/ 2> err -cat err -grep 'File a does not exist!' err -cd .. - -rm -rf temp diff --git a/tests/issue1344_abort_early_cant_send.sh b/tests/issue1344_abort_early_cant_send.sh --- a/tests/issue1344_abort_early_cant_send.sh +++ b/tests/issue1344_abort_early_cant_send.sh @@ -58,14 +58,14 @@ darcs add foo bar darcs record -a -m add_foo_bar -A x -# If --sendmail-command is provided, no warning -darcs send --author=me -a --to=random@random --sendmail-command='true' ../temp2 -# If --dry-run is provided, no warning -darcs send --author=me -a --to=random@random --dry-run ../temp2 -# If -o or -O is provided, no warning +# If --mail and --sendmail-command is provided, no warning +darcs send --mail --author=me -a --to=random@random --sendmail-command='true' ../temp2 +# If --mail and --dry-run is provided, no warning +darcs send --mail --author=me -a --to=random@random --dry-run ../temp2 +# If --mail is not provided, no warning darcs send --author=me -a --to=random@random -O ../temp2 darcs send --author=me -a --to=random@random -o test.patch ../temp2 # Otherwise, fail early -(darcs send --author=me -a --to=random@random ../temp2 || true) | grep "No working sendmail" +(darcs send --mail --author=me -a --to=random@random ../temp2 || true) | grep "No working sendmail" cd .. diff --git a/tests/issue1739-escape-multibyte-chars-correctly.sh b/tests/issue1739-escape-multibyte-chars-correctly.sh --- a/tests/issue1739-escape-multibyte-chars-correctly.sh +++ b/tests/issue1739-escape-multibyte-chars-correctly.sh @@ -50,7 +50,8 @@ # we want escaping, otherwise output of non-ASCII characters is unreliable export DARCS_DONT_ESCAPE_ANYTHING=0 -export DARCS_DONT_ESCAPE_8BIT=0 +# note default changed, DARCS_DONT_ESCAPE_8BIT is no longer recognized +export DARCS_ESCAPE_8BIT=1 export DARCS_DONT_ESCAPE_ISPRINT=0 rm -rf R @@ -61,7 +62,7 @@ echo garbelbolf > aargh darcs add aargh echo -e '\xe2\x80\x9e\x54\x61\x20\x4d\xc3\xa8\x72\x65\xe2\x80\x9d' > message.txt -darcs record --logfile=message.txt -A 'Petra Testa van der Test ' -a > rec.txt +darcs record --logfile=message.txt -a > rec.txt darcs changes > log.txt cat log.txt grep '' log.txt diff --git a/tests/issue1978.sh b/tests/issue1978.sh --- a/tests/issue1978.sh +++ b/tests/issue1978.sh @@ -1,7 +1,5 @@ #!/usr/bin/env bash -#pragma repo-format darcs-2 - . lib mkdir future @@ -17,10 +15,6 @@ cat _darcs/format cd .. -if grep darcs-1 .darcs/defaults; then - exit 200 -fi - # get future repo: should be ok darcs get future temp1 cd temp1 @@ -29,5 +23,3 @@ darcs add toto darcs record -am 'blah' cd .. -rm -rf temp1 future - diff --git a/tests/issue2138-whatsnew-s.sh b/tests/issue2138-whatsnew-s.sh deleted file mode 100644 --- a/tests/issue2138-whatsnew-s.sh +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2138 - whatsnew --summary does not show conflicts -## -## Copyright (C) 2012 Lele Gaifax -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. - -rm -rf R S - -darcs init --repo R - -cd R -echo 'Example content.' > f -darcs record -lam 'Add f' -cd .. - -darcs get R S - -# Create a deliberate conflict -cd R -echo "Conflict on side R" >> f -darcs record -am 'CR' - -cd ../S -echo "Conflict on side S" >> f -darcs record -am 'CS' - -darcs pull -a ../R - -darcs whatsnew > out -cat out -grep "side R" out | wc -l | grep 1 -grep "side S" out | wc -l | grep 1 - -darcs whatsnew --summary > out -grep "^M!" out | wc -l | grep 1 - -cd .. -rm -rf R S diff --git a/tests/issue2160_wrong_line_number_when_appending_empty_line.sh b/tests/issue2160_wrong_line_number_when_appending_empty_line.sh new file mode 100644 --- /dev/null +++ b/tests/issue2160_wrong_line_number_when_appending_empty_line.sh @@ -0,0 +1,19 @@ +# Off-by-one error when reporting patches that append an empty line to a file. +# An affected darcs would report 'hunk ./f 3' in the provided tests. +. lib + +darcs init R +cd R +echo 'first line' > f +darcs record -lam 'first line' +echo '' >> f +darcs whatsnew > wh +darcs record -am 'appended empty line' +darcs log -v --last=1 > log +darcs annotate f > ann + +# these currently all fail: +grep 'hunk ./f 2' wh +grep 'hunk ./f 2' log +not grep unknown ann +grep '#2' ann diff --git a/tests/issue2208-replace-fails-with-resolving-unrecorded-change.sh b/tests/issue2208-replace-fails-with-resolving-unrecorded-change.sh new file mode 100644 --- /dev/null +++ b/tests/issue2208-replace-fails-with-resolving-unrecorded-change.sh @@ -0,0 +1,56 @@ +#!/usr/bin/env bash +## Test for issue2208 - darcs shouldn't fail to replace if unrecorded changes +## would make the replace succeed +## +## Copyright (C) 2012 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R + +darcs init --repo R + +cd R + +echo -e 'foo\nbar' > testing + +darcs rec -alm 'Add testing file' + +echo -e 'baz\nbar' > testing + +# Darcs will complain here, since we've not recorded the fact that we've +# removed the occurrence of foo +darcs replace bar foo testing | not grep Skipping + +cat < ../expected +hunk ./testing 1 +-foo ++baz +replace ./testing [A-Za-z_0-9] bar foo +EOF + +darcs whatsnew > ../actual + +cd .. + +diff actual expected diff --git a/tests/issue2243-unknown-patch-annotating-empty-first-line.sh b/tests/issue2243-unknown-patch-annotating-empty-first-line.sh new file mode 100644 --- /dev/null +++ b/tests/issue2243-unknown-patch-annotating-empty-first-line.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue2243 - annotating a file with a blank first gives an "unknown" +## patch. +## +## Copyright (C) 2012 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +darcs init --repo R + +cd R + +echo -e "\nline2" > file + +darcs rec -alm 'Add file' + +darcs annotate file | not grep unknown diff --git a/tests/issue2262-display_of_meta_data.sh b/tests/issue2262-display_of_meta_data.sh new file mode 100644 --- /dev/null +++ b/tests/issue2262-display_of_meta_data.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +. lib +darcs init R +cd R +touch äöüßÄÖÜ +darcs whatsnew -l | grep './äöüßÄÖÜ' diff --git a/tests/issue2286-metadata-encoding.sh b/tests/issue2286-metadata-encoding.sh --- a/tests/issue2286-metadata-encoding.sh +++ b/tests/issue2286-metadata-encoding.sh @@ -26,9 +26,22 @@ . lib +gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf - +cd metadata-encoding + +darcs log -v + switch_to_utf8_locale +darcs log -v +darcs clone . ../utf8-clone +darcs log -v --repodir ../utf8-clone -gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf - +switch_to_latin9_locale +darcs log -v +darcs clone . ../latin-clone +darcs log -v --repodir ../latin-clone -cd metadata-encoding -darcs changes +LC_ALL=C +darcs log -v +darcs clone . ../c-clone +darcs log -v --repodir ../c-clone diff --git a/tests/issue2382-mv-dir-to-file-confuses-darcs.sh b/tests/issue2382-mv-dir-to-file-confuses-darcs.sh --- a/tests/issue2382-mv-dir-to-file-confuses-darcs.sh +++ b/tests/issue2382-mv-dir-to-file-confuses-darcs.sh @@ -27,7 +27,7 @@ function getRecordedChanges () { darcs rec -am 1 # Ignore patch details and unindent - we should have the same contents as wh -darcs changes --last 1 -v | tail -n+5 | sed -e 's/^\s\+//' > $1 +darcs changes --last 1 -v | tail -n+5 | sed -e 's/^\s\+//' | grep -v '^[{}]$' > $1 darcs unrecord --last 1 -a } diff --git a/tests/issue2480-display-unicode-in-patch-content.sh b/tests/issue2480-display-unicode-in-patch-content.sh new file mode 100644 --- /dev/null +++ b/tests/issue2480-display-unicode-in-patch-content.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +. lib +darcs init R +cd R +echo 'äöüßÄÖÜ' > file +darcs whatsnew -l --no-summary | grep '+äöüßÄÖÜ' +darcs record -lam'added file' +darcs log -v | grep '+äöüßÄÖÜ' diff --git a/tests/issue2512-multiple-authors-clobbered-in-global-conf.sh b/tests/issue2512-multiple-authors-clobbered-in-global-conf.sh new file mode 100644 --- /dev/null +++ b/tests/issue2512-multiple-authors-clobbered-in-global-conf.sh @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +## Test for issue2512 - Multiple authors in global config get overwritten + +. lib +abort_windows # different directory names on Windows + +# helper +function fail { + echo "ERROR: $1" + exit 1 +} + +# add multiple author IDs to global preferences +cat >"$HOME/.darcs/author" <<-EOF + AUTHOR_1, this one will be chosen when prompted for an author + AUTHOR_2, this one should still be there in the end +EOF + +# create a repo +rm -rf repo +mkdir repo +cd repo +darcs init + +# make a change so that we have something to commit +touch changed +darcs add changed + +# darcs will find multiple authors in global preferences, +# so darcs will ask for the author and we pick the first one +darcs record -am 'testing' <<-EOF + 1 +EOF +echo + +# check the configuration after the commit (primary test for this issue) +if ! grep -q 'AUTHOR_2' "$HOME/.darcs/author"; then + fail "'\$HOME/.darcs/author' with multiple authors was clobbered." +fi + +# in addition, confirm that the author was properly added to the repository +if ! [[ -f _darcs/prefs/author ]]; then + fail "The author was not recorded in the repository." +fi +if ! grep -q 'AUTHOR_1' _darcs/prefs/author; then + fail "An 'author' file was created in the repository, but does not contain the chosen author." +fi diff --git a/tests/issue2526-whatsnew-boring.sh b/tests/issue2526-whatsnew-boring.sh new file mode 100644 --- /dev/null +++ b/tests/issue2526-whatsnew-boring.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +. lib + +# test that 'whatsnew -l --boring' actually lists boring files + +rm -rf R +darcs init R +cd R + +echo xxx > boring +darcs setpref boringfile boring +darcs record -lam'added boring and set as boringile' +touch xxx +darcs whatsnew -l --boring | grep xxx +darcs whatsnew -l --boring | grep -v 'No changes' + +cd .. +rm -rf R diff --git a/tests/issue2545_command-execution-via-ssh-uri.sh b/tests/issue2545_command-execution-via-ssh-uri.sh new file mode 100644 --- /dev/null +++ b/tests/issue2545_command-execution-via-ssh-uri.sh @@ -0,0 +1,49 @@ +#!/usr/bin/env bash +## Test for issue2545 - Argument smuggling in SSH repository URLs +## Darcs allows (almost) arbitrary command execution via a crafted ssh URI. +## +## Copyright (C) 2017 Gian Piero Carrubba +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init --repo R # Create our test repos. +cd R + +DARCS_SCP=sftp darcs pull -a ssh://-oProxyCommand='touch FAIL' \ + 2>/dev/null || true +not ls FAIL >/dev/null + +DARCS_SCP=sftp darcs pull -a -- -oProxyCommand='touch FAIL':dir \ + 2>/dev/null || true +not ls FAIL >/dev/null + +# Executing the same tests with `clone' instead of `pull'. The results shoud +# be the same, but better safe than sorry. +DARCS_SCP=sftp darcs clone ssh://-oProxyCommand='touch FAIL' S \ + 2>/dev/null || true +not ls FAIL >/dev/null + +DARCS_SCP=sftp darcs clone -- -oProxyCommand='touch FAIL':dir T \ + 2>/dev/null || true +not ls FAIL >/dev/null + +cd .. diff --git a/tests/issue2567-darcs-whatsnew-unified.sh b/tests/issue2567-darcs-whatsnew-unified.sh new file mode 100644 --- /dev/null +++ b/tests/issue2567-darcs-whatsnew-unified.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash + +# check that darcs whatsnew --unified outputs correct context lines + +. lib + +cat > before << EOF +1 +2 +3 +4 +5 +EOF + +cat > after << EOF +1 +3 +4a +4b +5 +EOF + +cat > exp << EOF +hunk ./file 2 + 1 +-2 + 3 +hunk ./file 3 +-4 ++4a ++4b + 5 +EOF + +darcs init R +cd R +cp ../before file +darcs record -lam 'add file' +cp ../after file +darcs whatsnew --unified > ../got +diff ../exp ../got diff --git a/tests/issue2575-revert_during_rebase.sh b/tests/issue2575-revert_during_rebase.sh new file mode 100644 --- /dev/null +++ b/tests/issue2575-revert_during_rebase.sh @@ -0,0 +1,11 @@ +. lib + +darcs init R +cd R +touch f +darcs record -l f -am'add f' +darcs rebase suspend -a --last 1 +echo bla > g +darcs add g +darcs revert -a +not grep 'DO NOT TOUCH' _darcs/patches/unrevert diff --git a/tests/issue2581-rebase_pull_reorder_updates_format.sh b/tests/issue2581-rebase_pull_reorder_updates_format.sh new file mode 100644 --- /dev/null +++ b/tests/issue2581-rebase_pull_reorder_updates_format.sh @@ -0,0 +1,16 @@ +. lib + +darcs init R +cd R +touch f +darcs record -l f -am "add f in R" +cd .. + +darcs init S +cd S +touch f +darcs record -l f -am "add f in S" + +# first y is for the "repos are unrelated" prompt +echo yaa | darcs rebase pull ../R --reorder-patches +darcs rebase log diff --git a/tests/issue279_get_extra.sh b/tests/issue279_get_extra.sh --- a/tests/issue279_get_extra.sh +++ b/tests/issue279_get_extra.sh @@ -5,10 +5,12 @@ . lib -rm -rf temp1 temp_a temp_b temp_c temp_d +# this test fails for darcs-1 repos +skip-formats darcs-1 + mkdir temp1 cd temp1 -darcs init --darcs-2 +darcs init echo 0 > f darcs add f darcs record -am 00 @@ -38,5 +40,3 @@ not grep -i "no remote" log not grep -i get_extra log cd .. - -rm -rf temp1 temp_a temp_b temp_c temp_d log diff --git a/tests/issue436.sh b/tests/issue436.sh --- a/tests/issue436.sh +++ b/tests/issue436.sh @@ -1,14 +1,13 @@ #!/usr/bin/env bash -#pragma repo-format darcs-2 - . ./lib -rm -rf temp1 temp2 +# this test fails in the darcs 1 format +skip-formats darcs-1 + mkdir temp1 cd temp1 -# this test fails in the darcs 1 format -darcs init --darcs-2 +darcs init echo A > f darcs add f darcs record --ignore-times -a -m A @@ -29,5 +28,3 @@ (darcs push -a || :) 2> push-result grep "Refusing to apply" push-result cd .. - -rm -rf temp1 temp2 diff --git a/tests/lazy-optimize-reorder.sh b/tests/lazy-optimize-reorder.sh --- a/tests/lazy-optimize-reorder.sh +++ b/tests/lazy-optimize-reorder.sh @@ -8,7 +8,7 @@ darcs init --no-patch-index # this test only applies to hashed formats -if cat _darcs/inventory; then exit 0; fi +if cat _darcs/inventory; then exit 200; fi date > f1 darcs add f1 diff --git a/tests/log-duplicate.sh b/tests/log-duplicate.sh --- a/tests/log-duplicate.sh +++ b/tests/log-duplicate.sh @@ -21,12 +21,11 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-2 - . lib -grep darcs-2 $HOME/.darcs/defaults || exit 200 -rm -rf R S +# this test fails for darcs-1 repos +skip-formats darcs-1 + darcs init --repo R darcs init --repo S diff --git a/tests/log.sh b/tests/log.sh --- a/tests/log.sh +++ b/tests/log.sh @@ -58,13 +58,12 @@ grep 'num 1' out cd .. -rm -rf temp1 # Some tests for the output of log when combined with move. -darcs init temp1 -cd temp1 +darcs init temp2 +cd temp2 date > foo darcs record -lam 'add foo' mkdir d @@ -91,27 +90,25 @@ grep "mv foo then add new foo" log not grep "unknown" log cd .. -rm -rf temp1 # Issue244 # darcs changes should be able to pull up the history for a file # using its moved and not-yet recorded new name -darcs init temp1 -cd temp1 +darcs init temp3 +cd temp3 touch b darcs record -lam 11 darcs mv b c darcs log c | grep 11 cd .. -rm -rf temp1 ## issue1337 - darcs log shows unrelated patches ## Asking "darcs log" about an unrecorded file d/f will list the ## patch that creates the parent directory d/ (instead of no patches). -darcs init temp1 -cd temp1 +darcs init temp4 +cd temp4 mkdir d darcs record -lam d d # We use --match 'touch d/f' instead of simply d/f because the latter @@ -119,13 +116,12 @@ test 0 -eq "$(darcs log --count --match 'touch d/f')" cd .. -rm -rf temp1 ## issue1632 - 'darcs changes d/f' should not list any changes, ## where d is part of the repo and f is a non-existent file. -darcs init temp1 -cd temp1 +darcs init temp5 +cd temp5 mkdir d darcs record -lam 'added directory d' @@ -136,13 +132,12 @@ darcs changes d/non-existent-file > log not grep 'added directory d' log cd .. -rm -rf temp1 ## issue1888 - changes --context is broken when topmost patch ## is a clean tag. -darcs init temp1 -cd temp1 +darcs init temp6 +cd temp6 echo a > a ; darcs rec -lam "patch_a" darcs log --context | grep patch_a @@ -156,6 +151,5 @@ darcs log --context | grep tag_a darcs log --context | grep patch_b cd .. -rm -rf temp1 diff --git a/tests/look_for_moves_and_replaces.sh b/tests/look_for_moves_and_replaces.sh new file mode 100644 --- /dev/null +++ b/tests/look_for_moves_and_replaces.sh @@ -0,0 +1,70 @@ +#!/usr/bin/env bash + +. ./lib + +# detect move of a file and then a replace in that file + +test_setup() { + num=$1 + shift + paths=$@ + + darcs init R$num + cd R$num + + echo foo > old + echo foo >> old + echo bar >> old + + darcs record -lam 'added old' + mv old new + + echo bar > new + echo bar >> new + echo bar >> new + + darcs whatsnew --look-for-moves --look-for-replaces $paths > ../out.actual + cd .. +} + +cat < out.expected +move ./old ./new +hunk ./new 3 +-bar ++foo +replace ./new [A-Za-z_0-9] foo bar +EOF + +test_setup 1 "" +diff out.actual out.expected + +# same but only for old + +test_setup 2 old +# remove the line about What's new in: old +sed -i '1d' out.actual +diff out.actual out.expected + +# same but only for new + +test_setup 3 new +# remove the line about What's new in: new +sed -i '1d' out.actual +# NOTE: the move is NOT detected in this case +# We might want to change that... +sed '1d' out.expected | sed 's/new/old/' > out.expected3 +diff out.actual out.expected3 + +# same but only for old and new + +test_setup 4 old new +# remove the line about What's new in: old new +sed -i '1d' out.actual +diff out.actual out.expected + +# same but only for old and new and non-existing + +test_setup 5 old new non-existing +# remove the line about What's new in: old new, and the one that reports non-existing +sed -i '1,2d' out.actual +diff out.actual out.expected diff --git a/tests/look_for_moves_with_args.sh b/tests/look_for_moves_with_args.sh new file mode 100644 --- /dev/null +++ b/tests/look_for_moves_with_args.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash + +# test that --look-for-moves properly handles file arguments + +. ./lib + +darcs init R +cd R + +touch old1 +touch old2 +touch old3 +darcs record -lam 'added files' +mv old1 new1 +mv old2 new2 +cd .. + +runtest () { + darcs whatsnew --repodir R --look-for-moves $* | grep move > out +} + +num_lines () { + test "$(cat $2 | wc -l)" = "$1" +} + +move1='move \./old1 \./new1' +move2='move \./old2 \./new2' + +runtest "" +grep "$move1" out +grep "$move2" out +num_lines 2 out + +runtest old1 +# we expect to see only move1 +grep "$move1" out +not grep "$move2" out +num_lines 1 out + +runtest old1 old2 +# we expect to see both moves +grep "$move1" out +grep "$move2" out +num_lines 2 out + +runtest old2 old3 +# we expect to see only move2 +grep "$move2" out +not grep "$move1" out +num_lines 1 out diff --git a/tests/merging_newlines.sh b/tests/merging_newlines.sh --- a/tests/merging_newlines.sh +++ b/tests/merging_newlines.sh @@ -5,35 +5,23 @@ # A test for darcs detecting a conflict, inspired by bug #152 in RT -rm -rf temp1 temp2 - # set up the repository -mkdir temp1 -cd temp1 -darcs init -cd .. +darcs init temp1 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" +darcs record -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 +echo "from temp2" >> one.txt darcs whatsnew -s | grep M -darcs record -A bar -am "add extra line" +darcs record -am "append non-empty line" darcs push -av > log -cat log -not grep -i conflicts log +grep -i conflicts log cd .. - -rm -rf temp1 temp2 diff --git a/tests/network/clone-http-packed-detect.sh b/tests/network/clone-http-packed-detect.sh --- a/tests/network/clone-http-packed-detect.sh +++ b/tests/network/clone-http-packed-detect.sh @@ -4,21 +4,13 @@ # Tests that darcs clone --verbose reports getting a pack when there is one, # and does not report when there is none or when --no-packs is passed. -#pragma repo-format darcs-1,darcs-2 - . lib -rm -rf S - -if grep darcs-1 .darcs/defaults; then -format=hashed -elif grep darcs-2 .darcs/defaults; then -format=darcs-2 -else format=ERROR; fi +skip-formats darcs-1 # compressed repo is darcs-2 -gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - +gunzip -c $TESTDATA/laziness-complete.tgz | tar xf - -cd many* +cd repo darcs optimize http test -e _darcs/packs/basic.tar.gz @@ -28,13 +20,13 @@ serve_http # sets baseurl # check that default behaviour is to get packs -darcs clone $baseurl/many-files--${format} S --verbose |grep "Cloning packed basic repository" +darcs clone $baseurl/laziness-complete S --verbose |grep "Cloning packed basic repository" # check that it does really not get packs when --no-packs is passed rm -rf S -darcs clone $baseurl/many-files--${format} S --no-packs --verbose |not grep "Cloning packed basic repository" +darcs clone $baseurl/laziness-complete S --no-packs --verbose |not grep "Cloning packed basic repository" # check that it does not clam getting packs when there are not rm -rf S -rm -rf many-files--${format}/_darcs/packs/ -darcs clone $baseurl/many-files--${format} S --verbose |not grep "Cloning packed basic repository" +rm -rf laziness-complete/_darcs/packs/ +darcs clone $baseurl/laziness-complete S --verbose |not grep "Cloning packed basic repository" diff --git a/tests/network/clone-http-packed.sh b/tests/network/clone-http-packed.sh --- a/tests/network/clone-http-packed.sh +++ b/tests/network/clone-http-packed.sh @@ -1,21 +1,13 @@ #!/usr/bin/env bash # Written in 2010 by Petr Rockai, placed in public domain -#pragma repo-format darcs-1,darcs-2 - . lib -rm -rf S - -if grep darcs-1 .darcs/defaults; then -format=hashed -elif grep darcs-2 .darcs/defaults; then -format=darcs-2 -else format=ERROR; fi +skip-formats darcs-1 # compressed repo is darcs-2 -gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - +gunzip -c $TESTDATA/laziness-complete.tgz | tar xf - -cd many* +cd repo darcs optimize http test -e _darcs/packs/basic.tar.gz @@ -23,7 +15,7 @@ cd .. serve_http # sets baseurl -darcs clone --packs $baseurl/many-files--${format} S +darcs clone --packs $baseurl/laziness-complete S cd S rm _darcs/prefs/sources # avoid any further contact with the original repository darcs check diff --git a/tests/network/failing-issue1599-automatically-expire-unused-caches.sh b/tests/network/failing-issue1599-automatically-expire-unused-caches.sh new file mode 100644 --- /dev/null +++ b/tests/network/failing-issue1599-automatically-expire-unused-caches.sh @@ -0,0 +1,55 @@ +#!/usr/bin/env bash +## Test for issue1599 - 'Automatically expire unused caches' +## +## Copyright (C) 2010 Adolfo Builes +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. +. lib + +rm -rf R S log && mkdir R +cd R +darcs init +echo a > a +darcs rec -lam a +echo b > b +darcs rec -lam b +echo c > c +darcs rec -lam c +cd .. + +serve_http # sets baseurl +darcs clone --lazy $baseurl/R S +rm S/_darcs/prefs/sources +if [ -z "$http_proxy" ]; then + echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources +fi +echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources +echo "repo:~/test1599/S" >> S/_darcs/prefs/sources +echo "repo:$baseurl/R" >> S/_darcs/prefs/sources +export DARCS_CONNECTION_TIMEOUT=1 && darcs log --repo S --debug --verbose --no-cache 2>&1 | tee log +if [ -z "$http_proxy" ]; then + c=`grep -c "URL.waitUrl http://10.1.2.3/S" log` + [ $c -eq 1 ] +fi +c1=`grep -c "URL.waitUrl $baseurl/dummyRepo" log` +[ $c1 -eq 2 ] +c2=`grep -c "~/test1599/S" log` +[ $c2 -eq 1 ] diff --git a/tests/network/issue1599-automatically-expire-unused-caches.sh b/tests/network/issue1599-automatically-expire-unused-caches.sh deleted file mode 100644 --- a/tests/network/issue1599-automatically-expire-unused-caches.sh +++ /dev/null @@ -1,55 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1599 - 'Automatically expire unused caches' -## -## Copyright (C) 2010 Adolfo Builes -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. -. lib - -rm -rf R S log && mkdir R -cd R -darcs init -echo a > a -darcs rec -lam a -echo b > b -darcs rec -lam b -echo c > c -darcs rec -lam c -cd .. - -serve_http # sets baseurl -darcs clone --lazy $baseurl/R S -rm S/_darcs/prefs/sources -if [ -z "$http_proxy" ]; then - echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources -fi -echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources -echo "repo:~/test1599/S" >> S/_darcs/prefs/sources -echo "repo:$baseurl/R" >> S/_darcs/prefs/sources -export DARCS_CONNECTION_TIMEOUT=1 && darcs log --repo S --debug --verbose --no-cache 2>&1 | tee log -if [ -z "$http_proxy" ]; then - c=`grep -c "URL.waitUrl http://10.1.2.3/S" log` - [ $c -eq 1 ] -fi -c1=`grep -c "URL.waitUrl $baseurl/dummyRepo" log` -[ $c1 -eq 2 ] -c2=`grep -c "~/test1599/S" log` -[ $c2 -eq 1 ] diff --git a/tests/network/issue1932-remote.sh b/tests/network/issue1932-remote.sh --- a/tests/network/issue1932-remote.sh +++ b/tests/network/issue1932-remote.sh @@ -36,7 +36,7 @@ [ -n "$(fgrep 'ssh: Could not resolve hostname invalid: Name or service not known' log)" ] # HTTP repo -( darcs clone http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log +( http_proxy= darcs clone http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log egrep 'CouldNotResolveHost|host lookup failure' log # local repos are tested by tests/issue1932-colon-breaks-add.sh diff --git a/tests/network/issue2090-transfer-mode.sh b/tests/network/issue2090-transfer-mode.sh --- a/tests/network/issue2090-transfer-mode.sh +++ b/tests/network/issue2090-transfer-mode.sh @@ -47,7 +47,6 @@ cd .. darcs clone $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1 -COUNT=$(grep -c 'darcs transfer-mode' log) +COUNT=$(grep -c '^Exec.*darcs.*transfer-mode' log) # with issue2090, this was 6! test $COUNT -eq 1 -cleanup diff --git a/tests/network/issue2545_command-execution-via-ssh-uri.sh b/tests/network/issue2545_command-execution-via-ssh-uri.sh new file mode 100644 --- /dev/null +++ b/tests/network/issue2545_command-execution-via-ssh-uri.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Test for issue2545 - Argument smuggling in SSH repository URLs +## +## Darcs allows (almost) arbitrary command execution via a crafted ssh +## URI. +## When pushing to a remote repo, darcs is invoked on the remote server +## via ssh. This use of ssh is different from the ones tested by the +## not-networked test. Also, I'm not sure how (if) it can be exploited, +## so I'm just checking for the debug message. Pretty lame test, I know. +## +## Copyright (C) 2017 Gian Piero Carrubba +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +. sshlib # Load ssh helpers. + +init_remote_repo R # Create our test repos. +darcs init --repo R # +cd R + +echo "text" > file # Modify the working dir +darcs record -lam "First Patch" # Record the changes + +check="\"${SSH}\" \"--\" \"${REMOTE}\" \"darcs apply --all --debug --repodir '${REMOTE_DIR}/R'\"" +darcs push -a --debug "${REMOTE}":"${REMOTE_DIR}"/R 2>&1 >/dev/null | \ + fgrep "$check" diff --git a/tests/network/ssh.sh b/tests/network/ssh.sh --- a/tests/network/ssh.sh +++ b/tests/network/ssh.sh @@ -103,4 +103,3 @@ grep -q 'conflicts options to apply' log cd .. -cleanup diff --git a/tests/network/sshlib b/tests/network/sshlib --- a/tests/network/sshlib +++ b/tests/network/sshlib @@ -1,5 +1,5 @@ if [ x${REMOTE_DIR} = x ]; then - REMOTE_DIR=/tmp/darcs-ssh-test + REMOTE_DIR=/tmp/darcs-ssh-test$$ fi if [ x"${USE_PUTTY}" != x ]; then @@ -22,20 +22,19 @@ SSH=${DARCS_SSH} fi -rm -rf tempssh -mkdir tempssh -cd tempssh - -cleanup () { - cd .. - rm -rf tempssh -} - if [ x${REMOTE} = x ]; then REMOTE=$(whoami)@localhost fi -# vim: syntax=sh: +init_remote_repo() { + repodir="${1:-R}" + ${SSH} ${REMOTE} \ + "rm -rf '${REMOTE_DIR}' && mkdir '${REMOTE_DIR}' && \ + cd '${REMOTE_DIR}' && darcs init --repo '$repodir' --$format" +} + # test if we can connect via ssh, otherwise skip test -${SSH} ${REMOTE} true || exit 200 +${SSH} -x -o=NumberofPasswordPrompts=0 ${REMOTE} true || exit 200 + +# vim: syntax=sh: diff --git a/tests/oldfashioned.sh b/tests/oldfashioned.sh --- a/tests/oldfashioned.sh +++ b/tests/oldfashioned.sh @@ -76,7 +76,7 @@ cd .. -# issue2253 - darcs log FILE should build patch index in an OF repo +# issue2253 - darcs log FILE should not build patch index in an OF repo cd old darcs log x diff --git a/tests/printer.sh b/tests/printer.sh --- a/tests/printer.sh +++ b/tests/printer.sh @@ -4,7 +4,6 @@ . lib -rm -rf temp1 mkdir temp1 cd temp1 darcs init @@ -15,7 +14,7 @@ env # clear all output formating environment variables for e in DARCS_DONT_ESCAPE_ISPRINT DARCS_USE_ISPRINT\ - DARCS_DONT_ESCAPE_8BIT\ + DARCS_ESCAPE_8BIT\ DARCS_DONT_ESCAPE_EXTRA DARCS_ESCAPE_EXTRA\ DARCS_DONT_ESCAPE_TRAILING_SPACES\ DARCS_DONT_COLOR DARCS_ALWAYS_COLOR DARCS_ALTERNATIVE_COLOR\ @@ -30,7 +29,7 @@ test_line () { rm -f a echo $1 > a - darcs whatsnew | fgrep $2 + darcs whatsnew | grep -F $2 } @@ -62,6 +61,11 @@ test_line $(printf '\x1D') '[_^]_]' test_line $(printf '\x1E') '[_^^_]' test_line $(printf '\x1F') '[_^__]' + +# everything up to here is escaped by default; +# for the rest we must explicitly set it: +export DARCS_ESCAPE_8BIT=1 + test_line $(printf '\x7F') '[_^?_]' # other chars are escaped with test_line $(printf '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F')\ @@ -80,4 +84,3 @@ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' -rm -rf temp1 diff --git a/tests/pull.sh b/tests/pull.sh --- a/tests/pull.sh +++ b/tests/pull.sh @@ -320,3 +320,22 @@ rm -rf temp1 temp2 +# pull --matches +darcs init temp1 +cd temp1 +echo first > a +darcs record -lam 'first' +firsthash=`darcs log --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"` +echo second > b +darcs record -lam 'second' +cd .. + +darcs init temp2 +darcs pull --repodir temp2 -a --match "hash $firsthash" temp1 +test $(darcs log --count --repodir temp2) -eq 1 + +darcs init temp3 +darcs pull --repodir temp3 -a --hash $firsthash temp1 +test $(darcs log --count --repodir temp3) -eq 1 + +rm -rf temp1 temp2 temp3 diff --git a/tests/pull_many_files.sh b/tests/pull_many_files.sh deleted file mode 100644 --- a/tests/pull_many_files.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env bash -. lib - -#pragma repo-format darcs-1,darcs-2 - -rm -rf temp1 temp2 - -if grep darcs-1 .darcs/defaults; then -format=hashed -elif grep darcs-2 .darcs/defaults; then -format=darcs-2 -else format=ERROR; fi - -mkdir temp2 -cd temp2 -gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - -cd .. - -mkdir temp1 -cd temp1 -darcs init -darcs pull -a ../temp2/many-files--${format} > log -grep -i 'finished pulling' log -cd .. -rm -rf temp1 - -# put things back how we found them. - -rm -rf temp1 temp2 diff --git a/tests/push.sh b/tests/push.sh --- a/tests/push.sh +++ b/tests/push.sh @@ -27,7 +27,7 @@ # push without a repo gives an error cd temp1 not darcs push -p 123 2> log -grep -i 'missing argument' log +grep -i 'No default repository to push to' log cd .. mkdir -p temp2/one/two diff --git a/tests/rebase-apply.sh b/tests/rebase-apply.sh --- a/tests/rebase-apply.sh +++ b/tests/rebase-apply.sh @@ -53,7 +53,7 @@ # (should it answer 'yes' to both pulling and suspending? echo yyy | darcs rebase apply -a ../R2/2.dpatch -darcs changes --count | grep "Rebase in progress: 2 suspended patches" +darcs changes --count 2>&1 | grep "Rebase in progress: 2 suspended patches" echo yny | darcs rebase unsuspend | grep "We have conflicts" cat > expected < wibble darcs rec -lam "add wibble" -echo 'yy' | darcs rebase suspend | grep-once "Rebase in progress: 1 suspended patch" +echo 'yy' | darcs rebase suspend 2>&1 | grep-once "Rebase in progress: 1 suspended patch" not test -f wibble echo 'yy' | darcs rebase unsuspend | grep-once "Rebase finished" test -f wibble diff --git a/tests/rebase-nochanges.sh b/tests/rebase-nochanges.sh --- a/tests/rebase-nochanges.sh +++ b/tests/rebase-nochanges.sh @@ -54,10 +54,9 @@ * add wobble Making no changes: this is a dry run. -Rebase in progress: 1 suspended patches EOF darcs unpull --dry-run | tail -n+5 | grep -v tester | diff -u expected - -echo 'yy' | darcs rebase unsuspend | grep "Rebase finished" +echo 'yy' | darcs rebase unsuspend 2>&1 | grep "Rebase finished" test -f wibble diff --git a/tests/rebase-pull.sh b/tests/rebase-pull.sh --- a/tests/rebase-pull.sh +++ b/tests/rebase-pull.sh @@ -52,7 +52,7 @@ # (should it answer 'yes' to both pulling and suspending? echo yyy | darcs rebase pull -a ../R2 -darcs changes --count | grep "Rebase in progress: 2 suspended patches" +darcs changes --count 2>&1 | grep "Rebase in progress: 2 suspended patches" echo yny | darcs rebase unsuspend | grep "We have conflicts" cat > expected < foo +darcs add foo +darcs record -lam add +echo goodbye world >> foo +darcs revert -a +darcs show contents foo | cmp foo - + +# Now let's test a trickier revert where changes commute nontrivially. + +cat > foo < foo + +echo "nyy" | darcs revert + +DARCS_DONT_COLOR=1 darcs wh > whatsnew +cat > correct < bar +echo hello world > foo +darcs add bar +darcs replace hello goodbye bar foo + +echo "cnnnyy/y" | tr / \\012 | darcs revert + +DARCS_DONT_COLOR=1 darcs wh > whatsnew +cat > correct < foo +darcs add foo +darcs revert -a + diff --git a/tests/revert_interactive.sh b/tests/revert_interactive.sh deleted file mode 100644 --- a/tests/revert_interactive.sh +++ /dev/null @@ -1,67 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo hello world > foo -darcs add foo -darcs record -a -m add -A x -echo goodbye world >> foo -echo y/y | tr / \\012 | darcs revert -darcs show contents foo | cmp foo - - -# Now let's test a trickier revert where changes commute nontrivially. - -cat > foo < foo - -echo "nyy" | darcs revert - -DARCS_DONT_COLOR=1 darcs wh > whatsnew -cat > correct < bar -echo hello world > foo -darcs add bar -darcs replace hello goodbye bar foo - -echo "cnnnyy/y" | tr / \\012 | darcs revert - -DARCS_DONT_COLOR=1 darcs wh > whatsnew -cat > correct < foo -darcs add foo - -darcs revert -a diff --git a/tests/send-output-v1.sh b/tests/send-output-v1.sh --- a/tests/send-output-v1.sh +++ b/tests/send-output-v1.sh @@ -24,11 +24,9 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-1 - . lib # Load some portability helpers. -grep darcs-1 $HOME/.darcs/defaults || exit 200 +skip-formats darcs-2 rm -rf empty mkdir empty diff --git a/tests/send-output-v2.sh b/tests/send-output-v2.sh --- a/tests/send-output-v2.sh +++ b/tests/send-output-v2.sh @@ -24,11 +24,9 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-2 - . lib # Load some portability helpers. -grep darcs-2 $HOME/.darcs/defaults || exit 200 +skip-formats darcs-1 rm -rf empty mkdir empty diff --git a/tests/several_commands.sh b/tests/several_commands.sh deleted file mode 100644 --- a/tests/several_commands.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo hello world > foo -darcs add foo -darcs record -a -m add -A x -echo goodbye world >> foo -darcs diff -darcs diff -u -darcs whatsnew -darcs whatsnew --summary -echo y | darcs revert -a -darcs show contents foo | cmp foo - -mkdir d -darcs add d -darcs record -a -m 'add dir' -A x -rmdir d -darcs revert -a d -cd .. -rm -rf temp1 - diff --git a/tests/show-bug.sh b/tests/show-bug.sh deleted file mode 100644 --- a/tests/show-bug.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env bash - -## All these commands SHOULD fail (hence leading NOTs). -. lib - -darcs show bug --debug 1> stdout 2> stderr || true - -cat stdout -cat stderr - -echo The following test will fail if this version of darcs is marked as -echo obsolete. -echo ================================================================== - -not grep 'please do not' stderr - -# The following test fails if HTTP isn't present, but would be a nice test -# to have in place. - -#not grep unable stderr - -grep 'fake bug' stderr diff --git a/tests/show_files.sh b/tests/show_files.sh --- a/tests/show_files.sh +++ b/tests/show_files.sh @@ -89,3 +89,28 @@ cd .. rm -rf temp + +darcs init --repo R +cd R + +for file in foo bar baz quux +do + touch "$file" + darcs add "$file" + darcs record --all --name "Add $file" +done + +darcs unrecord --all --patches "quux" +darcs rebase suspend --all --patches "foo" + +# (pending, match): (False, False) +check_manifest "bar baz" "" "--no-pending" +# (pending, match): (False, True) +check_manifest "bar" "" "--no-pending --patch bar" +# (pending, match): (True, False) +check_manifest "bar baz quux" "" "--pending" +# (pending, match): (True, True) +not darcs show files --pending --patch "bar" + +cd .. +rm -rf R diff --git a/tests/split-patches.sh b/tests/split-patches.sh --- a/tests/split-patches.sh +++ b/tests/split-patches.sh @@ -24,8 +24,6 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-1,darcs-2 - . lib # Load some portability helpers. if grep darcs-2 .darcs/defaults; then diff --git a/tests/switch-encoding.sh b/tests/switch-encoding.sh new file mode 100644 --- /dev/null +++ b/tests/switch-encoding.sh @@ -0,0 +1,87 @@ +. lib + +switch_to_utf8_locale +lc_utf8=$LC_ALL + +darcs init E +darcs clone E U + +cd U +mkdir Texte +echo 'Müßiggang' > 'Texte/böse Zeichen' +darcs record -lam 'Erste Änderung' +darcs log -v +darcs send -ao bundle +tail -n+7 bundle > u_bundle + +LC_ALL=C + +darcs log -v +darcs send -ao bundle +tail -n+7 bundle > c_bundle + +diff u_bundle c_bundle + +darcs apply u_bundle | grep 'already .*applied' +darcs obliterate -a +darcs apply u_bundle | grep 'Finished applying' +darcs unrecord -a +darcs revert -a +darcs apply u_bundle | grep 'Finished applying' + + +LC_ALL=$lc_utf8 + +darcs apply c_bundle | grep 'already .*applied' +darcs obliterate -a +darcs apply c_bundle | grep 'Finished applying' +darcs unrecord -a +darcs revert -a +darcs apply c_bundle | grep 'Finished applying' + +LC_ALL=C + +cd .. + +darcs clone U C +diff -r U/Texte C/Texte + +cd C +darcs pull ../E --set-default + +darcs apply ../U/u_bundle | grep 'already .*applied' +diff -r ../U/Texte Texte +darcs obliterate -ao ou_bundle +diff ../U/u_bundle ou_bundle +darcs apply ou_bundle | grep 'Finished applying' +diff -r ../U/Texte Texte +darcs unrecord -a +darcs revert -a +darcs pull ../U -a +diff -r ../U/Texte Texte +darcs send -ao bundle +tail -n+7 bundle > c_bundle + +LC_ALL=$lc_utf8 + +darcs send -ao bundle +tail -n+7 bundle > u_bundle +diff u_bundle c_bundle + +darcs apply c_bundle | grep 'already .*applied' +diff -r ../U/Texte Texte +darcs obliterate -ao oc_bundle +diff c_bundle oc_bundle +darcs apply c_bundle | grep 'Finished applying' +diff -r ../U/Texte Texte +darcs unrecord -a +darcs revert -a +darcs pull ../U -a +diff -r ../U/Texte Texte +darcs send -ao bundle +tail -n+7 bundle > c_bundle + +cd .. + +diff U/u_bundle C/u_bundle +diff -r U/Texte C/Texte diff --git a/tests/toolbox.sh b/tests/toolbox.sh deleted file mode 100644 --- a/tests/toolbox.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env bash - -. lib - -DIR="`pwd`" - -# set up the repository -rm -rf temp1 # another script may have left a mess. -mkdir temp1 -cd temp1 -darcs init -touch foo -darcs add foo -echo ny | darcs record -cd .. -rm -rf temp1 diff --git a/tests/utf8-display.sh b/tests/utf8-display.sh --- a/tests/utf8-display.sh +++ b/tests/utf8-display.sh @@ -30,7 +30,8 @@ switch_to_utf8_locale -export DARCS_DONT_ESCAPE_8BIT=1 +#is now the default, must use DARCS_ESCAPE_8BIT to disable +#export DARCS_DONT_ESCAPE_8BIT=1 rm -rf R mkdir R diff --git a/tests/v1-braced.sh b/tests/v1-braced.sh --- a/tests/v1-braced.sh +++ b/tests/v1-braced.sh @@ -24,11 +24,9 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -#pragma repo-format darcs-1 - . lib # Load some portability helpers. -grep darcs-1 $HOME/.darcs/defaults || exit 200 +skip-formats darcs-2 rm -rf braced gunzip -c $TESTDATA/braced.tgz | tar xf - diff --git a/tests/whatsnew-adds-no-summary.sh b/tests/whatsnew-adds-no-summary.sh new file mode 100644 --- /dev/null +++ b/tests/whatsnew-adds-no-summary.sh @@ -0,0 +1,51 @@ +#!/bin/sh -e +## +## Test for the interaction of --look-for-adds and --no-summary in darcs whatsnew +## +## Copyright (C) 2017 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. + +. lib + +rm -rf R +mkdir R +cd R + +darcs init + +echo A > A +echo B > B + +darcs add A +darcs rec -am "add A" + +echo "A 2" > A + +darcs whatsnew --look-for-adds --no-summary > output.txt + +grep "hunk \./A 1" output.txt +grep "\-A" output.txt +grep "+A 2" output.txt +grep "addfile \./B" output.txt +grep "hunk \./B 1" output.txt +grep "+B" output.txt + diff --git a/tests/whatsnew.sh b/tests/whatsnew.sh --- a/tests/whatsnew.sh +++ b/tests/whatsnew.sh @@ -21,7 +21,8 @@ touch look_summary.txt darcs whatsnew -l | grep -i "a ./look_summary.txt" -#whatsnew works with uncommon file names +# whatsnew works with uncommon file names and does NOT display +# the internal "white space encoded" filename if echo $OS | grep -i windows; then echo test does not work on windows exit 0; @@ -29,13 +30,13 @@ echo foo > \\ darcs add \\ darcs whatsnew | tee log - grep 'hunk ./\\92\\' log + grep 'hunk ./\\' log fi echo foo > "foo bar" darcs add "foo bar" darcs wh | tee log -grep 'hunk ./foo\\32\\bar' log +grep 'hunk ./foo bar' log # check that filename encoding does not botch up the index darcs rec -am "weird filenames" @@ -141,10 +142,9 @@ cat out grep date out | wc -l | grep 1 -# This one fails actually, but it's not my fault. Filed as issue1196. -#darcs wh foo foo/../foo/. > out -#cat out -#grep date out | wc -l | grep 1 +darcs wh foo foo/../foo/. > out +cat out +grep date out | wc -l | grep 1 cd .. rm -rf temp1