diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.10.1.0 +Version: 1.10.2.0 Copyright: 2003-2006, Isaac Jones 2005-2011, Duncan Coutts License: BSD3 diff --git a/Distribution/Compat/CopyFile.hs b/Distribution/Compat/CopyFile.hs --- a/Distribution/Compat/CopyFile.hs +++ b/Distribution/Compat/CopyFile.hs @@ -11,6 +11,7 @@ copyExecutableFile, setFileOrdinary, setFileExecutable, + setDirOrdinary, ) where #ifdef __GLASGOW_HASKELL__ @@ -59,7 +60,7 @@ copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest -setFileOrdinary, setFileExecutable :: FilePath -> IO () +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () #ifndef mingw32_HOST_OS setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x @@ -76,6 +77,8 @@ setFileOrdinary _ = return () setFileExecutable _ = return () #endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable copyFile :: FilePath -> FilePath -> IO () #ifdef __GLASGOW_HASKELL__ diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs --- a/Distribution/Compat/Exception.hs +++ b/Distribution/Compat/Exception.hs @@ -10,7 +10,7 @@ #endif module Distribution.Compat.Exception - (onException, catchIO, catchExit, throwIOIO) + (Exception.IOException, onException, catchIO, catchExit, throwIOIO) where import System.Exit diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs --- a/Distribution/PackageDescription/Parse.hs +++ b/Distribution/PackageDescription/Parse.hs @@ -250,11 +250,8 @@ validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite validateTestSuite line stanza = case testStanzaTestType stanza of - Nothing -> - syntaxError line $ - "The 'type' field is required for test suites. " - ++ "The available test types are: " - ++ intercalate ", " (map display knownTestTypes) + Nothing -> return $ + emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeUnknown _ _) -> return emptyTestSuite { @@ -748,9 +745,48 @@ "'test-suite' needs one argument (the test suite's name)" testname <- lift $ runP line_no "test" parseTokenQ sec_label flds <- collectFields (parseTestFields line_no) sec_fields - skipField - (repos, flags, lib, exes, tests) <- getBody - return (repos, flags, lib, exes, tests ++ [(testname, flds)]) + + -- Check that a valid test suite type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The test suite must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkTestType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a test type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkTestType ts' t && checkTestType ts' e + -- Does the current node specify a test type? + hasTestType = testInterface ts' + /= testInterface emptyTestSuite + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasTestType || (any checkComponent components) + if checkTestType emptyTestSuite flds + then do + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flags, lib, exes, (testname, flds) : tests) + else lift $ syntaxError line_no $ + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) | sec_type == "library" -> do when (not (null sec_label)) $ lift $ diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -217,21 +217,23 @@ defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs comp userInstall _hasLibs = do - windowsProgramFilesDir <- getWindowsProgramFilesDir - userInstallPrefix <- getAppUserDataDirectory "cabal" - lhcPrefix <- getAppUserDataDirectory "lhc" + installPrefix <- + if userInstall + then getAppUserDataDirectory "cabal" + else case buildOS of + Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> case comp of + LHC | userInstall -> getAppUserDataDirectory "lhc" + _ -> return ("$prefix" "lib") return $ fmap toPathTemplate $ InstallDirs { - prefix = if userInstall - then userInstallPrefix - else case buildOS of - Windows -> windowsProgramFilesDir "Haskell" - _other -> "/usr/local", + prefix = installPrefix, bindir = "$prefix" "bin", - libdir = case buildOS of - Windows -> "$prefix" - _other -> case comp of - LHC | userInstall -> lhcPrefix - _ -> "$prefix" "lib", + libdir = installLibDir, libsubdir = case comp of Hugs -> "hugs" "packages" "$pkg" JHC -> "$compiler" diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -67,7 +67,8 @@ ) where import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) ) + ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) + , TestSuite(..), TestSuiteInterface(..) ) import Distribution.PackageDescription.Check ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) import Distribution.Package @@ -165,6 +166,24 @@ Nothing -> findFile (hsSourceDirs exeBi) mainPath Just pp -> return pp copyFileTo verbosity targetDir srcMainFile + -- move the test suites into place + withTest $ \t -> do + let bi = testBuildInfo t + prep = prepareDir verbosity pkg_descr distPref targetDir pps + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + prep [] bi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + TestSuiteLibV09 _ m -> do + prep [m] bi + TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp flip mapM_ (dataFiles pkg_descr) $ \ filename -> do files <- matchFileGlob (dataDir pkg_descr filename) let dir = takeDirectory (dataDir pkg_descr filename) @@ -230,6 +249,7 @@ -- versions of these functions that ignore the 'buildable' attribute: withLib action = maybe (return ()) action (library pkg_descr) withExe action = mapM_ action (executables pkg_descr) + withTest action = mapM_ action (testSuites pkg_descr) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -76,14 +76,14 @@ import Distribution.System ( buildPlatform, Platform ) import Control.Exception ( bracket ) -import Control.Monad ( when, liftM, unless ) +import Control.Monad ( when, liftM, unless, filterM ) import Data.Char ( toUpper ) import Data.Monoid ( mempty ) import System.Directory ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory - , removeFile ) + , removeFile, getDirectoryContents ) import System.Environment ( getEnvironment ) -import System.Exit ( ExitCode(..), exitFailure, exitSuccess, exitWith ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) import System.FilePath ( (), (<.>) ) import System.IO ( hClose, IOMode(..), openFile ) import System.Process ( runProcess, waitForProcess ) @@ -294,7 +294,7 @@ when (not $ PD.hasTests pkg_descr) $ do notice verbosity "Package has no test suites." - exitSuccess + exitWith ExitSuccess when (PD.hasTests pkg_descr && null enabledTests) $ die $ "No test suites enabled. Did you remember to configure with " @@ -314,6 +314,11 @@ | otherwise -> die $ "no such test: " ++ tName createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= mapM_ removeFile let totalSuites = length testsToRun notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -153,14 +153,15 @@ ( exitWith, ExitCode(..) ) import System.FilePath ( normalise, (), (<.>), takeDirectory, splitFileName - , splitExtension, splitExtensions ) + , splitExtension, splitExtensions, splitDirectories ) import System.Directory - ( createDirectoryIfMissing, renameFile, removeDirectoryRecursive ) + ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error - ( isDoesNotExistError, ioeSetFileName, ioeGetFileName, ioeGetErrorString ) + ( try, isDoesNotExistError, isAlreadyExistsError + , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) #if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) import System.IO.Error ( ioeSetLocation, ioeGetLocation ) @@ -190,11 +191,12 @@ #endif import Distribution.Compat.CopyFile - ( copyFile, copyOrdinaryFile, copyExecutableFile ) + ( copyFile, copyOrdinaryFile, copyExecutableFile + , setDirOrdinary ) import Distribution.Compat.TempFile ( openTempFile, openNewBinaryFile, createTempDirectory ) import Distribution.Compat.Exception - ( catchIO, catchExit, onException ) + ( IOException, throwIOIO, catchIO, catchExit, onException ) import Distribution.Verbosity #ifdef VERSION_base @@ -700,11 +702,49 @@ -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. -- -createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO () -createDirectoryIfMissingVerbose verbosity parentsToo dir = do - let msgParents = if parentsToo then " (and its parents)" else "" - info verbosity ("Creating " ++ dir ++ msgParents) - createDirectoryIfMissing parentsToo dir +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIOIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIOIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- try $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + if isDir then return () + else throwIOIO e + ) `catch` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIOIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir -- | Copies a file without copying file permissions. The target file is created -- with default permissions. Any existing target file is replaced. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -4,6 +4,12 @@ 1.10.0.x (next stable release version) +1.10.2.0 Duncan Coutts June 2011 + * Include test suites in cabal sdist + * Fix for conditionals in test suite stanzas in .cabal files + * Fix permissions of directories created during install + * Fix for global builds when $HOME env var is not set + 1.10.1.0 Duncan Coutts February 2011 * Improved error messages when test suites are not enabled * Template parameters allowed in test --test-option(s) flag