Sat Aug 28 00:04:54 CEST 2010 Petr Rockai * Flip "cabal test" over to use darcs-test to run the shell tests. diff -rN -u old-darcs/Setup.lhs new-darcs/Setup.lhs --- old-darcs/Setup.lhs 2010-11-21 21:21:46.039000012 +0100 +++ new-darcs/Setup.lhs 2010-11-21 21:21:46.603000012 +0100 @@ -50,14 +50,13 @@ import System.IO.Error ( isDoesNotExistError ) import Data.List( isPrefixOf, isSuffixOf, sort, partition ) +import System.Cmd( rawSystem ) import System.FilePath ( (), splitDirectories, isAbsolute ) import Foreign.Marshal.Utils ( with ) import Foreign.Storable ( peek ) import Foreign.Ptr ( castPtr ) import Data.Word ( Word8, Word32 ) -import qualified Distribution.ShellHarness as Harness ( runTests ) - import qualified Control.Exception as Exception -- Handle exceptions migration. We could use extensible-exceptions @@ -92,28 +91,17 @@ runTests = \ args _ _ lbi -> do cwd <- getCurrentDirectory let isabs = isAbsolute $ buildDir lbi - path = (if isabs then id else (cwd )) - (buildDir lbi "darcs") - what = if null args then ["tests"] else args - (series, tests) = partition - (`elem` ["bugs", "network", "tests"]) what - sequence_ [ case w of - "bugs" -> allTests path Bug [] - "network" -> execTests path Network "" [] - "tests" -> allTests path Test [] - _ -> return () {- impossible, silence -Wall -} - | w <- series ] - when (not $ null tests) $ individualTests path tests, - - -- Remove the temporary directories created by "cabal test". - postClean = \ _ _ _ _ -> mapM_ rmRf - ["tests-darcs-2.dir", - "tests-hashed.dir", - "tests-old-fashioned-inventory.dir", - "bugs-darcs-2.dir", - "bugs-hashed.dir", - "bugs-old-fashioned-inventory.dir", - "tests-network.dir"], + builddir = (if isabs then id else (cwd )) $ buildDir lbi + darcs = builddir "darcs" "darcs" + darcstest = builddir "darcs-test" "darcs-test" + (what, args') = partition (`elem` ["bugs", "network", "tests"]) + (if null args then ["tests"] else args) + opts = [ "--darcs", darcs, "--no-unit" ] ++ concat [ ["-t", x] | x <- args' ] ++ + [ "--network" | "network" <- what ] ++ [ "--failing" | "bugs" <- what ] ++ + [ "--no-shell" | _ <- [()], "tests" `notElem` what ] + havetest <- doesFileExist darcstest + if havetest then rawSystem darcstest opts >> return () + else fail "Please configure with -ftest and build before running tests.", sDistHook = \ pkg lbi hooks flags -> do let pkgVer = packageVersion pkg @@ -267,134 +255,4 @@ _ -> return Nothing else return Nothing -------------------------------------- --- Running the testsuite --- - -data TestKind = Bug | Test | Network deriving Eq - -testDir :: TestKind -> String -testDir Bug = "tests" -testDir Test = "tests" -testDir Network = "tests/network" - -deslash :: Char -> Char -deslash '/' = '-' -deslash x = x - -isSh :: FilePath -> Bool -isSh = (".sh" `isSuffixOf`) - --- | By convention, a test script starts with "failing-" iff it is --- expected to fail, i.e. it is a bug that hasn't been fixed yet. -isTest :: TestKind -> FilePath -> Bool -isTest Bug = ("failing-" `isPrefixOf`) -isTest _ = not . isTest Bug - -execTests :: FilePath -> TestKind -> String -> [String] -> IO () -execTests darcs_path k fmt tests = do - let dir = map deslash (testDir k) ++ (if null fmt then fmt else "-" ++ fmt) ++ ".dir" - rmRf dir - cloneTree (testDir k) dir - withCurrentDirectory dir $ do - createDirectory ".darcs" - when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n" - putStrLn $ "Running tests for format: " ++ fmt - fs <- case tests of - [] -> sort `fmap` getDirectoryContents "." - x -> return x - let run = filter (\f -> isSh f && isTest k f) fs - cwd <- getCurrentDirectory - res <- Harness.runTests (Just darcs_path) cwd run - when ((not res) && (k /= Bug)) $ fail "Tests failed" - return () - -individualTests :: FilePath -> [String] -> IO () -individualTests darcs_path tests = do - run <- concat `fmap` mapM find tests - sequence_ [ do exec kind [test | (kind', test) <- run, kind' == kind] - | kind <- [Test, Bug, Network] ] - where tryin w t' = [w t', w (t' ++ ".sh")] - exec _ [] = return () - exec kind to_run = allTests darcs_path kind to_run - find t = do - let c = [t, t ++ ".sh"] ++ tryin "tests" t - ++ tryin "network" t - run <- map kindify `fmap` filterM doesFileExist c - return $ take 1 run - kindify test = case splitDirectories test of - ["tests", y] -> (parse_kind y, y) - ["tests","network",y] -> (Network, y) - xs -> error $ "Bad format in " ++ test ++ - ": expected type/test" ++ " but got " ++ show xs - parse_kind y = if isTest Bug y then Bug else Test - -allTests :: FilePath -> TestKind -> [String] -> IO () -allTests darcs_path k s = - do test `mapM` repotypes - return () - where repotypes = ["darcs-2", "hashed", "old-fashioned-inventory"] - test x = execTests darcs_path k x s - -------------------------------------------------------- --- Utility functions (FIXME) --- copy & paste & edit: darcs wants to share these --- - -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory name m = - bracket - (do cwd <- getCurrentDirectory - when (name /= "") (setCurrentDirectory name) - return cwd) - (\oldwd -> setCurrentDirectory oldwd `catchAny` (\_ -> return ())) - (const m) - -cloneTree :: FilePath -> FilePath -> IO () -cloneTree = cloneTreeExcept [] - -cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO () -cloneTreeExcept except source dest = - do isdir <- doesDirectoryExist source - if isdir then do - createDirectoryIfMissing True dest - fps <- getDirectoryContents source - let fps' = filter (`notElem` (".":"..":except)) fps - mk_source fp = source ++ "/" ++ fp - mk_dest fp = dest ++ "/" ++ fp - zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') - else fail ("cloneTreeExcept: Bad source " ++ source) - `catchAny` fail ("cloneTreeExcept: Bad source " ++ source) - -cloneSubTree :: FilePath -> FilePath -> IO () -cloneSubTree source dest = - do isdir <- doesDirectoryExist source - isfile <- doesFileExist source - if isdir then do - createDirectory dest - fps <- getDirectoryContents source - let fps' = filter (`notElem` [".", ".."]) fps - mk_source fp = source ++ "/" ++ fp - mk_dest fp = dest ++ "/" ++ fp - zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') - else if isfile then do - cloneFile source dest - else fail ("cloneSubTree: Bad source "++ source) - `Prelude.catch` (\e -> if isDoesNotExistError e - then return () - else ioError e) - -cloneFile :: FilePath -> FilePath -> IO () -cloneFile = copyFile - -rmRf :: FilePath -> IO () -rmRf path = do - isdir <- doesDirectoryExist path - isf <- doesFileExist path - when isdir $ removeDirectoryRecursive path - when isf $ removeFile path - return () - --- (END FIXME) - \end{code}