diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.8.0.6 +Version: 1.10.0.0 Copyright: 2003-2006, Isaac Jones 2005-2009, Duncan Coutts License: BSD3 @@ -18,6 +18,7 @@ The Haskell Cabal is part of a larger infrastructure for distributing, organizing, and cataloging Haskell libraries and tools. Category: Distribution +cabal-version: >=1.6 Build-Type: Custom -- Even though we do use the default Setup.lhs it's vital to bootstrapping -- that we build Setup.lhs using our own local Cabal source code. @@ -29,11 +30,6 @@ type: darcs location: http://darcs.haskell.org/cabal/ -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-1.8/ - tag: 1.8.0.6 - Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -41,15 +37,15 @@ Description: Choose the new smaller, split-up base package. Library - build-depends: base >= 1 && < 5, - filepath >= 1 && < 1.2 + build-depends: base >= 2 && < 5, + filepath >= 1 && < 1.3 if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } if flag(base3) - Build-Depends: directory >= 1 && < 1.1, + Build-Depends: directory >= 1 && < 1.2, process >= 1 && < 1.1, old-time >= 1 && < 1.1, - containers >= 0.1 && < 0.4, + containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, pretty >= 1 && < 1.1 @@ -59,7 +55,6 @@ ghc-options: -Wall -fno-ignore-asserts if impl(ghc >= 6.8) ghc-options: -fwarn-tabs - cpp-options: "-DCABAL_VERSION=1,8,0,6" nhc98-Options: -K4M Exposed-Modules: @@ -107,9 +102,12 @@ Distribution.Simple.Register, Distribution.Simple.Setup, Distribution.Simple.SrcDist, + Distribution.Simple.Test, + Distribution.Simple.UHC, Distribution.Simple.UserHooks, Distribution.Simple.Utils, Distribution.System, + Distribution.TestSuite, Distribution.Text, Distribution.Verbosity, Distribution.Version, @@ -122,6 +120,7 @@ Distribution.Compat.CopyFile, Distribution.Compat.TempFile, Distribution.Simple.GHC.IPI641, - Distribution.Simple.GHC.IPI642 + Distribution.Simple.GHC.IPI642, + Paths_Cabal Extensions: CPP diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs --- a/Distribution/Compat/TempFile.hs +++ b/Distribution/Compat/TempFile.hs @@ -75,7 +75,7 @@ (templateBase, templateExt) = splitExtension template findTempName :: Int -> IO (FilePath, Handle) findTempName x - = do let path = tmp_dir (templateBase ++ show x) <.> templateExt + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt b <- doesFileExist path if b then findTempName (x+1) else do hnd <- openFile path ReadWriteMode @@ -142,7 +142,7 @@ then findTempName (x+1) else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) else do - -- XXX We want to tell fdToHandle what the filepath is, + -- TODO: We want to tell fdToHandle what the filepath is, -- as any exceptions etc will only be able to report the -- fd currently h <- @@ -161,14 +161,14 @@ filename = prefix ++ show x ++ suffix filepath = dir `combine` filename - -- XXX bits copied from System.FilePath, since that's not available here + -- FIXME: bits copied from System.FilePath combine a b | null b = a | null a = b | last a == pathSeparator = a ++ b | otherwise = a ++ [pathSeparator] ++ b --- XXX Should use filepath library +-- FIXME: Should use filepath library pathSeparator :: Char #ifdef mingw32_HOST_OS pathSeparator = '\\' @@ -176,7 +176,7 @@ pathSeparator = '/' #endif --- XXX Copied from GHC.Handle +-- FIXME: Copied from GHC.Handle std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -73,12 +73,12 @@ import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) import Control.Monad (when) -data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC +data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | OtherCompiler String deriving (Show, Read, Eq, Ord) knownCompilerFlavors :: [CompilerFlavor] -knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC] +knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] instance Text CompilerFlavor where disp (OtherCompiler name) = Disp.text name diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs --- a/Distribution/GetOpt.hs +++ b/Distribution/GetOpt.hs @@ -99,7 +99,7 @@ -> String -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table) where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos) - ,sepBy ", " (map (fmtLong ad) los) + ,concatMap (fmtLong ad) (take 1 los) ,d) | Option sos los ad d <- optDescr ] ssWidth = (maximum . map length) ss diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -106,7 +106,7 @@ knownLicenses :: [License] knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3]) - , BSD3, BSD4, MIT + , BSD3, MIT , PublicDomain, AllRightsReserved, OtherLicense] where unversioned = Nothing diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -15,7 +15,7 @@ -- maintenance and no testing. Perhaps at some point we should stop pretending -- that it works. -- --- Uses the parsed command-line from Distribution.Setup in order to build +-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build -- Haskell tools using a backend build system based on make. Obviously we -- assume that there is a configure script, and that after the ConfigCmd has -- been run, there is a Makefile. Further assumptions: @@ -171,8 +171,6 @@ let destArgs = case fromFlag $ copyDest flags of NoCopyDest -> ["install"] CopyTo path -> ["copy", "destdir=" ++ path] - CopyPrefix path -> ["install", "prefix=" ++ path] - -- CopyPrefix is backwards compat, DEPRECATED rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs installAction :: InstallFlags -> [String] -> IO () diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs --- a/Distribution/ModuleName.hs +++ b/Distribution/ModuleName.hs @@ -86,8 +86,6 @@ validModuleComponent (c:cs) = Char.isUpper c && all validModuleChar cs --- XXX This is used in Distribution/Simple/PreProcess.hs, so we can't --- deprecate it yet without getting warnings, and thus build failures {-# DEPRECATED simple "use ModuleName.fromString instead" #-} simple :: String -> ModuleName simple str = ModuleName [str] diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -7,13 +7,14 @@ -- Portability : portable -- -- This defines the data structure for the @.cabal@ file format. There are --- several parts to this structure. It has top level info and then 'Library' --- and 'Executable' sections each of which have associated 'BuildInfo' data --- that's used to build the library or exe. To further complicate things there --- is both a 'PackageDescription' and a 'GenericPackageDescription'. This --- distinction relates to cabal configurations. When we initially read a --- @.cabal@ file we get a 'GenericPackageDescription' which has all the --- conditional sections. Before actually building a package we have to decide +-- several parts to this structure. It has top level info and then 'Library', +-- 'Executable', and 'TestSuite' sections each of which have associated +-- 'BuildInfo' data that's used to build the library, exe, or test. To further +-- complicate things there is both a 'PackageDescription' and a +-- 'GenericPackageDescription'. This distinction relates to cabal +-- configurations. When we initially read a @.cabal@ file we get a +-- 'GenericPackageDescription' which has all the conditional sections. +-- Before actually building a package we have to decide -- on each conditional. Once we've done that we get a 'PackageDescription'. -- It was done this way initially to avoid breaking too much stuff when the -- feature was introduced. It could probably do with being rationalised at some @@ -53,6 +54,8 @@ -- * Package descriptions PackageDescription(..), emptyPackageDescription, + specVersion, + descCabalVersion, BuildType(..), knownBuildTypes, @@ -70,10 +73,24 @@ hasExes, exeModules, + -- * Tests + TestSuite(..), + TestSuiteInterface(..), + TestType(..), + testType, + knownTestTypes, + emptyTestSuite, + hasTests, + withTest, + testModules, + -- * Build information BuildInfo(..), emptyBuildInfo, allBuildInfo, + allLanguages, + allExtensions, + usedExtensions, hcOptions, -- ** Supplementary build information @@ -87,26 +104,34 @@ CondTree(..), ConfVar(..), Condition(..), -- * Source repositories - SourceRepo(..), RepoKind(..), RepoType(..), + SourceRepo(..), + RepoKind(..), + RepoType(..), + knownRepoTypes, ) where -import Data.List (nub) +import Data.List (nub, intersperse) +import Data.Maybe (maybeToList) import Data.Monoid (Monoid(mempty, mappend)) +import Control.Monad (MonadPlus(mplus)) import Text.PrettyPrint.HughesPJ as Disp import qualified Distribution.Compat.ReadP as Parse -import qualified Data.Char as Char (isAlphaNum, toLower) +import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) import Distribution.Package ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) , Dependency, Package(..) ) -import Distribution.ModuleName (ModuleName) -import Distribution.Version (Version(Version), VersionRange, anyVersion) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), VersionRange, anyVersion, orLaterVersion + , asVersionIntervals, LowerBound(..) ) import Distribution.License (License(AllRightsReserved)) import Distribution.Compiler (CompilerFlavor) import Distribution.System (OS, Arch) import Distribution.Text ( Text(..), display ) -import Language.Haskell.Extension (Extension) +import Language.Haskell.Extension + ( Language, Extension ) -- ----------------------------------------------------------------------------- -- The PackageDescription type @@ -139,11 +164,16 @@ -- with x-, stored in a -- simple assoc-list. buildDepends :: [Dependency], - descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here. + -- | The version of the Cabal spec that this package description uses. + -- For historical reasons this is specified with a version range but + -- only ranges of the form @>= v@ make sense. We are in the process of + -- transitioning to specifying just a single version, not a range. + specVersionRaw :: Either Version VersionRange, buildType :: Maybe BuildType, -- components library :: Maybe Library, executables :: [Executable], + testSuites :: [TestSuite], dataFiles :: [FilePath], dataDir :: FilePath, extraSrcFiles :: [FilePath], @@ -154,6 +184,32 @@ instance Package PackageDescription where packageId = package +-- | The version of the Cabal spec that this package should be interpreted +-- against. +-- +-- Historically we used a version range but we are switching to using a single +-- version. Currently we accept either. This function converts into a single +-- version by ignoring upper bounds in the version range. +-- +specVersion :: PackageDescription -> Version +specVersion pkg = case specVersionRaw pkg of + Left version -> version + Right versionRange -> case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + +-- | The range of versions of the Cabal tools that this package is intended to +-- work with. +-- +-- This function is deprecated and should not be used for new purposes, only to +-- support old packages that rely on the old interpretation. +-- +descCabalVersion :: PackageDescription -> VersionRange +descCabalVersion pkg = case specVersionRaw pkg of + Left version -> orLaterVersion version + Right versionRange -> versionRange +{-# DEPRECATED descCabalVersion "Use specVersion instead" #-} + emptyPackageDescription :: PackageDescription emptyPackageDescription = PackageDescription { @@ -161,7 +217,7 @@ (Version [] []), license = AllRightsReserved, licenseFile = "", - descCabalVersion = anyVersion, + specVersionRaw = Right anyVersion, buildType = Nothing, copyright = "", maintainer = "", @@ -179,6 +235,7 @@ customFieldsPD = [], library = Nothing, executables = [], + testSuites = [], dataFiles = [], dataDir = "", extraSrcFiles = [], @@ -311,6 +368,129 @@ exeModules exe = otherModules (buildInfo exe) -- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | A \"test-suite\" stanza in a cabal file. +-- +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo + } + deriving (Show, Read, Eq) + +-- | The test suite interfaces that are currently defined. Each test suite must +-- specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or totally +-- new interfaces. +-- +data TestSuiteInterface = + + -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. It takes no + -- command line parameters and nothing on stdin. + -- + TestSuiteExeV10 Version FilePath + + -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + -- + | TestSuiteLibV09 Version ModuleName + + -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + -- + | TestSuiteUnsupported TestType + deriving (Eq, Read, Show) + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty + } + + mappend a b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) + mappend a (TestSuiteUnsupported _) = a + mappend _ b = b + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + +-- | Does this package have any test suites? +hasTests :: PackageDescription -> Bool +hasTests = any (buildable . testBuildInfo) . testSuites + +-- | Perform an action on each buildable 'TestSuite' in a package. +withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () +withTest pkg_descr f = + mapM_ f $ filter (buildable . testBuildInfo) $ + testSuites pkg_descr + +-- | Get all the module names from a test suite. +testModules :: TestSuite -> [ModuleName] +testModules test = (case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> []) + ++ otherModules (testBuildInfo test) + +-- | The \"test-type\" field in the test suite stanza. +-- +data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" + | TestTypeLib Version -- ^ \"type: detailed-x.y\" + | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" + deriving (Show, Read, Eq) + +knownTestTypes :: [TestType] +knownTestTypes = [ TestTypeExe (Version [1,0] []) + -- 'detailed-0.9' test type is disabled in Cabal-1.10.x + -- needs more work on the details of the library interface + {- , TestTypeLib (Version [0,9] []) -} ] + +instance Text TestType where + disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (TestTypeLib ver) = text "detailed-" <> disp ver + disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = concat (intersperse "-" cs) + return $! case lowercase name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +testType :: TestSuite -> TestType +testType test = case testInterface test of + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteUnsupported testtype -> testtype + +-- --------------------------------------------------------------------------- -- The BuildInfo type -- Consider refactoring into executable and library versions. @@ -325,7 +505,13 @@ cSources :: [FilePath], hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy otherModules :: [ModuleName], -- ^ non-exposed or non-main modules - extensions :: [Extension], + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package extraLibDirs :: [String], includeDirs :: [FilePath], -- ^directories to find .h files @@ -353,7 +539,11 @@ cSources = [], hsSourceDirs = [], otherModules = [], - extensions = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], @@ -376,7 +566,11 @@ cSources = combineNub cSources, hsSourceDirs = combineNub hsSourceDirs, otherModules = combineNub otherModules, - extensions = combineNub extensions, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, extraLibs = combine extraLibs, extraLibDirs = combineNub extraLibDirs, includeDirs = combineNub includeDirs, @@ -391,6 +585,7 @@ where combine field = field a `mappend` field b combineNub field = nub (combine field) + combineMby field = field b `mplus` field a emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty @@ -404,7 +599,30 @@ ++ [ bi | exe <- executables pkg_descr , let bi = buildInfo exe , buildable bi ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst + , buildable bi ] + --FIXME: many of the places where this is used, we actually want to look at + -- unbuildable bits too, probably need separate functions +-- | The 'Language's used by this component +-- +allLanguages :: BuildInfo -> [Language] +allLanguages bi = maybeToList (defaultLanguage bi) + ++ otherLanguages bi + +-- | The 'Extension's that are used somewhere by this component +-- +allExtensions :: BuildInfo -> [Extension] +allExtensions bi = usedExtensions bi + ++ otherExtensions bi + +-- | The 'Extensions' that are used by all modules in this component +-- +usedExtensions :: BuildInfo -> [Extension] +usedExtensions bi = oldExtensions bi + ++ defaultExtensions bi + type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) emptyHookedBuildInfo :: HookedBuildInfo @@ -585,33 +803,15 @@ packageDescription :: PackageDescription, genPackageFlags :: [Flag], condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), - condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] } deriving (Show, Eq) instance Package GenericPackageDescription where packageId = packageId . packageDescription -{- --- XXX: I think we really want a PPrint or Pretty or ShowPretty class. -instance Show GenericPackageDescription where - show (GenericPackageDescription pkg flgs mlib exes) = - showPackageDescription pkg ++ "\n" ++ - (render $ vcat $ map ppFlag flgs) ++ "\n" ++ - render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib) - ++ "\n" ++ - (render $ vcat $ - map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes) - where - ppFlag (MkFlag name desc dflt manual) = - showStanza ("Flag " ++ name) - ((if (null desc) then empty else - text ("Description: " ++ desc)) $+$ - text ("Default: " ++ show dflt) $+$ - text ("Manual: " ++ show manual)) - showDeps = fsep . punctuate comma . map showDependency - showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace --} +--TODO: make PackageDescription an instance of Text. -- | A flag can represent a feature to be included, or a way of linking -- a target against its dependencies, or in fact whatever you can think of. @@ -625,7 +825,7 @@ -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -62,13 +62,15 @@ checkPackageFileNames, ) where -import Data.Maybe (isNothing, catMaybes, fromMaybe) +import Data.Maybe + ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) import Data.List (sort, group, isPrefixOf, nub, find) import Control.Monad ( filterM, liftM ) import qualified System.Directory as System ( doesFileExist, doesDirectoryExist ) +import Distribution.Package ( pkgName ) import Distribution.PackageDescription import Distribution.PackageDescription.Configuration ( flattenPackageDescription, finalizePackageDescription ) @@ -83,18 +85,23 @@ import Distribution.Version ( Version(..) - , VersionRange, withinRange, foldVersionRange' + , VersionRange(..), foldVersionRange' , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion , orLaterVersion, orEarlierVersion , unionVersionRanges, intersectVersionRanges - , asVersionIntervals, LowerBound(..), UpperBound(..) ) + , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package ( PackageName(PackageName), packageName, packageVersion , Dependency(..) ) + import Distribution.Text - ( display ) -import qualified Language.Haskell.Extension as Extension -import Language.Haskell.Extension (Extension(..)) + ( display, disp ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) + +import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) +import Language.Haskell.Extension + ( Language(UnknownLanguage), knownLanguages, Extension(..) ) import System.FilePath ( (), takeExtension, isRelative, isAbsolute , splitDirectories, splitPath ) @@ -196,20 +203,39 @@ , check (null (executables pkg) && isNothing (library pkg)) $ PackageBuildImpossible "No executables and no library found. Nothing to do." + + , check (not (null exeDuplicates)) $ + PackageBuildImpossible $ "Duplicate executable sections " + ++ commaSep exeDuplicates + , check (not (null testDuplicates)) $ + PackageBuildImpossible $ "Duplicate test sections " + ++ commaSep testDuplicates + + --TODO: this seems to duplicate a check on the testsuites + , check (not (null testsThatAreExes)) $ + PackageBuildImpossible $ "These test sections share names with executable sections: " + ++ commaSep testsThatAreExes ] + --TODO: check for name clashes case insensitively: windows file systems cannot cope. ++ maybe [] checkLibrary (library pkg) ++ concatMap checkExecutable (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) ++ catMaybes [ - check (not $ cabalVersion `withinRange` requiredCabalVersion) $ + check (specVersion pkg > cabalVersion) $ PackageBuildImpossible $ - "This package requires Cabal version: " - ++ display requiredCabalVersion + "This package description follows version " + ++ display (specVersion pkg) ++ " of the Cabal specification. This " + ++ "tool only supports up to version " ++ display cabalVersion ++ "." ] - - where requiredCabalVersion = descCabalVersion pkg + where + exeNames = map exeName $ executables pkg + testNames = map testName $ testSuites pkg + exeDuplicates = dups exeNames + testDuplicates = dups testNames + testsThatAreExes = filter (flip elem exeNames) testNames checkLibrary :: Library -> [PackageCheck] checkLibrary lib = @@ -217,13 +243,12 @@ check (not (null moduleDuplicates)) $ PackageBuildWarning $ - "Duplicate modules in library: " ++ commaSep moduleDuplicates + "Duplicate modules in library: " + ++ commaSep (map display moduleDuplicates) ] - where moduleDuplicates = [ display module_ - | let modules = exposedModules lib - ++ otherModules (libBuildInfo lib) - , (module_:_:_) <- group (sort modules) ] + where + moduleDuplicates = dups (libModules lib) checkExecutable :: Executable -> [PackageCheck] checkExecutable exe = @@ -242,13 +267,62 @@ , check (not (null moduleDuplicates)) $ PackageBuildWarning $ "Duplicate modules in executable '" ++ exeName exe ++ "': " - ++ commaSep moduleDuplicates + ++ commaSep (map display moduleDuplicates) ] + where + moduleDuplicates = dups (exeModules exe) - where moduleDuplicates = [ display module_ - | let modules = otherModules (buildInfo exe) - , (module_:_:_) <- group (sort modules) ] +checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] +checkTestSuite pkg test = + catMaybes [ + case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of test suite. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + + TestSuiteUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported test suite version. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildWarning $ + "Duplicate modules in test suite '" ++ testName test ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + , check exeNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as an executable." + + , check libNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ testModules test + + mainIsWrongExt = case testInterface test of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ] + libNameClash = testName test `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------ @@ -282,10 +356,21 @@ "Unknown compiler " ++ commaSep (map quote unknownCompilers) ++ " in 'tested-with' field." + , check (not (null unknownLanguages)) $ + PackageBuildWarning $ + "Unknown languages: " ++ commaSep unknownLanguages + , check (not (null unknownExtensions)) $ PackageBuildWarning $ "Unknown extensions: " ++ commaSep unknownExtensions + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning $ + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." + , check (not (null deprecatedExtensions)) $ PackageDistSuspicious $ "Deprecated extensions: " @@ -313,16 +398,39 @@ , check (length (synopsis pkg) >= 80) $ PackageDistSuspicious "The 'synopsis' field is rather long (max 80 chars is recommended)." + + -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + , check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable $ + "Invalid 'tested-with' version range: " + ++ commaSep (map display testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." ] where unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] + unknownLanguages = [ name | bi <- allBuildInfo pkg + , UnknownLanguage name <- allLanguages bi ] unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- extensions bi ] + , UnknownExtension name <- allExtensions bi + , name `notElem` map display knownLanguages ] deprecatedExtensions = nub $ catMaybes [ find ((==ext) . fst) Extension.deprecatedExtensions | bi <- allBuildInfo pkg - , ext <- extensions bi ] + , ext <- allExtensions bi ] + languagesUsedAsExtensions = + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `elem` map display knownLanguages ] + testedWithImpossibleRanges = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , isNoVersion vr ] + + checkLicense :: PackageDescription -> [PackageCheck] checkLicense pkg = catMaybes [ @@ -424,8 +532,8 @@ , checkFlags ["-fasm"] $ PackageDistInexcusable $ - "'ghc-options: -fasm' is unnecessary and breaks on all " - ++ "arches except for x86, x86-64 and ppc." + "'ghc-options: -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." , checkFlags ["-fvia-C"] $ PackageDistSuspicious $ @@ -664,19 +772,83 @@ --TODO: use the tar path checks on all the above paths --- | Check that if the package uses new syntax that it declares the --- @\"cabal-version: >= x.y\"@ version correctly. +-- | Check that the package declares the version in the @\"cabal-version\"@ +-- field correctly. -- checkCabalVersion :: PackageDescription -> [PackageCheck] checkCabalVersion pkg = catMaybes [ + -- check syntax of cabal-version field + check (specVersion pkg >= Version [1,10] [] + && not simpleSpecVersionRangeSyntax) $ + PackageBuildWarning $ + "Packages relying on Cabal 1.10 or later must only specify a " + ++ "version range of the form 'cabal-version: >= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check syntax of cabal-version field + , check (specVersion pkg < Version [1,9] [] + && not simpleSpecVersionRangeSyntax) $ + PackageDistSuspicious $ + "It is recommended that the 'cabal-version' field only specify a " + ++ "version range of the form '>= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " + ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." + + -- check syntax of cabal-version field + , checkVersion [1,12] simpleSpecVersionSyntax $ + PackageBuildWarning $ + "With Cabal 1.10 or earlier, the 'cabal-version' field must use " + ++ "range syntax rather than a simple version number. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check use of test suite stanzas + , checkVersion [1,10] (not (null $ testSuites pkg)) $ + PackageDistInexcusable $ + "The package uses test suite stanzas. To use this new syntax, " + ++ "the package needs to specify at least 'cabal-version: >= 1.10'." + + -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning $ + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + , check (specVersion pkg >= Version [1,10] [] + && (any isNothing (buildInfoField defaultLanguage))) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.10' must specify the " + ++ "'default-language' field for each component (e.g. Haskell98 or " + ++ "Haskell2010). If a component uses different languages in " + ++ "different modules then list the other ones in the " + ++ "'other-languages' field." + + -- check use of default-extensions field + -- don't need to do the equivalent check for other-extensions + , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $ + PackageBuildWarning $ + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + -- check use of extensions field + , check (specVersion pkg >= Version [1,10] [] + && (any (not . null) (buildInfoField oldExtensions))) $ + PackageBuildWarning $ + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax - checkVersion [1,8] (not (null versionRangeExpressions)) $ + , checkVersion [1,8] (not (null versionRangeExpressions)) $ PackageDistInexcusable $ "The package uses full version-range expressions " ++ "in a 'build-depends' field: " - ++ commaSep (map display versionRangeExpressions) + ++ commaSep (map displayRawDependency versionRangeExpressions) ++ ". To use this new syntax the package needs to specify at least " ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " ++ "is important, then convert to conjunctive normal form, and use " @@ -693,6 +865,26 @@ [ display (Dependency name (eliminateWildcardSyntax versionRange)) | Dependency name versionRange <- depsUsingWildcardSyntax ] + -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax + , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'tested-with' field: " + ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'." + + -- check use of "tested-with: GHC == 6.12.*" syntax + , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'tested-with' field: " + ++ commaSep (map display testedWithUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- testedWithUsingWildcardSyntax ] + -- check use of "data-files: data/*.txt" syntax , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ PackageDistInexcusable $ @@ -715,7 +907,7 @@ -- check use of "source-repository" section , checkVersion [1,6] (not (null (sourceRepos pkg))) $ PackageDistInexcusable $ - "The 'source-repository' section is new in Cabal-1.6. " + "The 'source-repository' section is new in Cabal 1.6. " ++ "Unfortunately it messes up the parser in earlier Cabal versions " ++ "so you need to specify 'cabal-version: >= 1.6'." @@ -728,38 +920,35 @@ ++ "compatability with earlier Cabal versions then use 'OtherLicense'." -- check for new language extensions - , checkVersion [1,2,3] (not (null usedExtensionsThatNeedCabal12)) $ + , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ PackageDistInexcusable $ "Unfortunately the language extensions " - ++ commaSep (map (quote . display) usedExtensionsThatNeedCabal12) + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12) ++ " break the parser in earlier Cabal versions so you need to " ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require " ++ "compatability with earlier Cabal versions then you may be able to " ++ "use an equivalent compiler-specific flag." - , checkVersion [1,4] (not (null usedExtensionsThatNeedCabal14)) $ + , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ PackageDistInexcusable $ "Unfortunately the language extensions " - ++ commaSep (map (quote . display) usedExtensionsThatNeedCabal14) + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14) ++ " break the parser in earlier Cabal versions so you need to " ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " ++ "compatability with earlier Cabal versions then you may be able to " ++ "use an equivalent compiler-specific flag." ] where + -- Perform a check on packages that use a version of the spec less than + -- the version given. This is for cases where a new Cabal version adds + -- a new feature and we want to check that it is not used prior to that + -- version. checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck checkVersion ver cond pc - | packageName pkg == PackageName "Cabal" = Nothing - | requiresAtLeast (Version ver []) = Nothing - | not cond = Nothing - | otherwise = Just pc - - requiresAtLeast :: Version -> Bool - requiresAtLeast = case cabalVersionIntervals of - (LowerBound ver' _,_):_ -> (ver' >=) - _ -> const False - where cabalVersionIntervals = asVersionIntervals (descCabalVersion pkg) + | specVersion pkg >= Version ver [] = Nothing + | otherwise = check cond pc + buildInfoField field = map field (allBuildInfo pkg) dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) usesGlobSyntax str = case parseFileGlob str of @@ -768,17 +957,49 @@ versionRangeExpressions = [ dep | dep@(Dependency _ vr) <- buildDepends pkg - , depth vr > (2::Int) ] - where depth = foldVersionRange' - 1 (const 1) - (const 1) (const 1) - (const 1) (const 1) - (const (const 1)) - (+) (+) + , usesNewVersionRangeSyntax vr ] + testedWithVersionRangeExpressions = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesNewVersionRangeSyntax vr ] + + simpleSpecVersionRangeSyntax = + either (const True) + (foldVersionRange' + True + (\_ -> False) + (\_ -> False) (\_ -> False) + (\_ -> True) -- >= + (\_ -> False) + (\_ _ -> False) + (\_ _ -> False) (\_ _ -> False) + id) + (specVersionRaw pkg) + + -- is the cabal-version field a simple version number, rather than a range + simpleSpecVersionSyntax = + either (const True) (const False) (specVersionRaw pkg) + + usesNewVersionRangeSyntax :: VersionRange -> Bool + usesNewVersionRangeSyntax = + (> 2) -- uses the new syntax if depth is more than 2 + . foldVersionRange' + (1 :: Int) + (const 1) + (const 1) (const 1) + (const 1) (const 1) + (const (const 1)) + (+) (+) + (const 3) -- uses new ()'s syntax + depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg , usesWildcardSyntax vr ] + testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesWildcardSyntax vr ] + usesWildcardSyntax :: VersionRange -> Bool usesWildcardSyntax = foldVersionRange' @@ -786,7 +1007,7 @@ (const False) (const False) (const False) (const False) (\_ _ -> True) -- the wildcard case - (||) (||) + (||) (||) id eliminateWildcardSyntax = foldVersionRange' @@ -794,19 +1015,20 @@ laterVersion earlierVersion orLaterVersion orEarlierVersion (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) - intersectVersionRanges unionVersionRanges + intersectVersionRanges unionVersionRanges id compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4 , PublicDomain, AllRightsReserved, OtherLicense ] - usedExtensions = [ ext | bi <- allBuildInfo pkg, ext <- extensions bi ] - usedExtensionsThatNeedCabal12 = - nub (filter (`elem` compatExtensionsExtra) usedExtensions) + mentionedExtensions = [ ext | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + mentionedExtensionsThatNeedCabal12 = + nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) -- As of Cabal-1.4 we can add new extensions without worrying about -- breaking old versions of cabal. - usedExtensionsThatNeedCabal14 = - nub (filter (`notElem` compatExtensions) usedExtensions) + mentionedExtensionsThatNeedCabal14 = + nub (filter (`notElem` compatExtensions) mentionedExtensions) -- The known extensions in Cabal-1.2.3 compatExtensions = @@ -833,6 +1055,39 @@ , ConstrainedClassMethods ] +-- | A variation on the normal 'Text' instance, shows any ()'s in the original +-- textual syntax. We need to show these otherwise it's confusing to users when +-- we complain of their presense but do not pretty print them! +-- +displayRawVersionRange :: VersionRange -> String +displayRawVersionRange = + Disp.render + . fst + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, _ ) -> (Disp.parens r, 0)) -- parens + + where + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + +displayRawDependency :: Dependency -> String +displayRawDependency (Dependency pkg vr) = + display pkg ++ " " ++ displayRawVersionRange vr + + -- ------------------------------------------------------------ -- * Checks on the GenericPackageDescription -- ------------------------------------------------------------ @@ -966,9 +1221,11 @@ setupError <- checkSetupExists ops pkg configureError <- checkConfigureExists ops pkg localPathErrors <- checkLocalPathsExist ops pkg + vcsLocation <- checkMissingVcsInfo ops pkg return $ catMaybes [licenseError, setupError, configureError] ++ localPathErrors + ++ vcsLocation checkLicenseExists :: Monad m => CheckPackageContentOps m -> PackageDescription @@ -1023,6 +1280,35 @@ } | (dir, kind) <- missing ] +checkMissingVcsInfo :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do + vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [ PackageDistSuspicious message ] + else return [] + where + repoDirnames = [ dirname | repo <- knownRepoTypes + , dirname <- repoTypeDirname repo ] + message = "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." + +checkMissingVcsInfo _ _ = return [] + +repoTypeDirname :: RepoType -> [FilePath] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] +repoTypeDirname Mercurial = [".hg"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname _ = [] + -- ------------------------------------------------------------ -- * Checks involving files in the package -- ------------------------------------------------------------ @@ -1123,3 +1409,6 @@ commaSep :: [String] -> String commaSep = intercalate ", " + +dups :: Ord a => [a] -> [a] +dups xs = [ x | (x:_:_) <- group (sort xs) ] diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -1,7 +1,8 @@ {-# OPTIONS -cpp #-} -- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} +-- -fno-warn-deprecations for use of Map.foldWithKey +{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-} {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp #-} ----------------------------------------------------------------------------- @@ -63,7 +64,7 @@ ( GenericPackageDescription(..), PackageDescription(..) , Library(..), Executable(..), BuildInfo(..) , Flag(..), FlagName(..), FlagAssignment - , CondTree(..), ConfVar(..), Condition(..) ) + , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) ) import Distribution.Version ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler @@ -139,7 +140,7 @@ && compVer `withinRange` vr interp (Flag f) = Left f --- XXX: Add instances and check +-- TODO: Add instances and check -- -- prop_sC_idempotent cond a o = cond' == cond'' -- where @@ -221,9 +222,9 @@ -- assignments. -- -- In case of failure, the _smallest_ number of of missing dependencies is --- returned. [XXX: Could also be specified with a function argument.] +-- returned. [TODO: Could also be specified with a function argument.] -- --- XXX: The current algorithm is rather naive. A better approach would be to: +-- TODO: The current algorithm is rather naive. A better approach would be to: -- -- * Rule out possible paths, by taking a look at the associated dependencies. -- @@ -414,22 +415,33 @@ -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go. -flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Executable)]) -flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets +flattenTaggedTargets :: TargetSet PDTagged -> + (Maybe Library, [(String, Executable)], [(String, TestSuite)]) +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets where - untag (_, Lib _) (Just _, _) = bug "Only one library expected" - untag (deps, Lib l) (Nothing, exes) = (Just l', exes) + untag (_, Lib _) (Just _, _, _) = bug "Only one library expected" + untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests) where l' = l { libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } } - untag (deps, Exe n e) (mlib, exes) + untag (deps, Exe n e) (mlib, exes, tests) | any ((== n) . fst) exes = bug "Exe with same name found" - | otherwise = (mlib, exes ++ [(n, e')]) + | any ((== n) . fst) tests = bug "Test sharing name of exe found" + | otherwise = (mlib, exes ++ [(n, e')], tests) where e' = e { buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } } + untag (deps, Test n t) (mlib, exes, tests) + | any ((== n) . fst) tests = bug "Test with same name found" + | any ((== n) . fst) exes = bug "Test sharing name of exe found" + | otherwise = (mlib, exes, tests ++ [(n, t')]) + where + t' = t { + testBuildInfo = (testBuildInfo t) + { targetBuildDepends = fromDepMap deps } + } untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal @@ -437,7 +449,7 @@ -- Convert GenericPackageDescription to PackageDescription -- -data PDTagged = Lib Library | Exe String Executable | PDNull deriving Show +data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show instance Monoid PDTagged where mempty = PDNull @@ -445,6 +457,7 @@ x `mappend` PDNull = x Lib l `mappend` Lib l' = Lib (l `mappend` l') Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') + Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') _ `mappend` _ = bug "Cannot combine incompatible tags" -- | Create a package description with all configurations resolved. @@ -481,11 +494,12 @@ -- ^ Either missing dependencies or the resolved package -- description along with the flag assignments chosen. finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints - (GenericPackageDescription pkg flags mlib0 exes0) = + (GenericPackageDescription pkg flags mlib0 exes0 tests0) = case resolveFlags of - Right ((mlib, exes'), targetSet, flagVals) -> + Right ((mlib, exes', tests'), targetSet, flagVals) -> Right ( pkg { library = mlib , executables = exes' + , testSuites = tests' , buildDepends = fromDepMap (overallDependencies targetSet) --TODO: we need to find a way to avoid pulling in deps -- for non-buildable components. However cannot simply @@ -496,16 +510,18 @@ Left missing -> Left missing where - -- Combine lib and exes into one list of @CondTree@s with tagged data + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 + ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 resolveFlags = case resolveWithFlags flagChoices os arch impl constraints condTrees check of Right (targetSet, fs) -> - let (mlib, exes) = flattenTaggedTargets targetSet in + let (mlib, exes, tests) = flattenTaggedTargets targetSet in Right ( (fmap libFillInDefaults mlib, - map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes), + map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, + map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests), targetSet, fs) Left missing -> Left missing @@ -537,17 +553,18 @@ -- joined into one field, which may not be possible in the original package -- description, due to the use of exclusive choices (if ... else ...). -- --- XXX: One particularly tricky case is defaulting. In the original package +-- TODO: One particularly tricky case is defaulting. In the original package -- description, e.g., the source directory might either be the default or a -- certain, explicitly set path. Since defaults are filled in only after the -- package has been resolved and when no explicit value has been set, the -- default path will be missing from the package description returned by this -- function. flattenPackageDescription :: GenericPackageDescription -> PackageDescription -flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0) = +flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) = pkg { library = mlib , executables = reverse exes - , buildDepends = ldeps ++ reverse edeps + , testSuites = reverse tests + , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps } where (mlib, ldeps) = case mlib0 of @@ -555,9 +572,13 @@ (Just (libFillInDefaults l), ds) Nothing -> (Nothing, []) (exes, edeps) = foldr flattenExe ([],[]) exes0 + (tests, tdeps) = foldr flattenTst ([],[]) tests0 flattenExe (n, t) (es, ds) = let (e, ds') = ignoreConditions t in ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) + flattenTst (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) -- This is in fact rather a hack. The original version just overrode the -- default values, however, when adding conditions we had to switch to a @@ -573,6 +594,10 @@ exeFillInDefaults :: Executable -> Executable exeFillInDefaults exe@(Executable { buildInfo = bi }) = exe { buildInfo = biFillInDefaults bi } + +testFillInDefaults :: TestSuite -> TestSuite +testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = + tst { testBuildInfo = biFillInDefaults bi } biFillInDefaults :: BuildInfo -> BuildInfo biFillInDefaults bi = diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs --- a/Distribution/PackageDescription/Parse.hs +++ b/Distribution/PackageDescription/Parse.hs @@ -62,21 +62,25 @@ import Data.Char (isSpace) import Data.Maybe (listToMaybe, isJust) +import Data.Monoid ( Monoid(..) ) import Data.List (nub, unfoldr, partition, (\\)) import Control.Monad (liftM, foldM, when, unless) import System.Directory (doesFileExist) import Distribution.Text ( Text(disp, parse), display, simpleParse ) +import Distribution.Compat.ReadP + ((+++), option) import Text.PrettyPrint.HughesPJ import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription import Distribution.Package - ( PackageName(..), PackageIdentifier(..), Dependency(..) - , packageName, packageVersion ) + ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) +import Distribution.ModuleName ( ModuleName ) import Distribution.Version - ( anyVersion, isAnyVersion, withinRange ) + ( Version(Version), orLaterVersion + , LowerBound(..), asVersionIntervals ) import Distribution.Verbosity (Verbosity) import Distribution.Compiler (CompilerFlavor(..)) import Distribution.PackageDescription.Configuration (parseCondition, freeVars) @@ -98,8 +102,8 @@ disp parse packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) , simpleField "cabal-version" - disp parse - descCabalVersion (\v pkg -> pkg{descCabalVersion=v}) + (either disp disp) (liftM Left parse +++ liftM Right parse) + specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) , simpleField "build-type" (maybe empty disp) (fmap Just parse) buildType (\t pkg -> pkg{buildType=t}) @@ -207,6 +211,94 @@ storeXFieldsExe _ _ = Nothing -- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza { + testStanzaTestType :: Maybe TestType, + testStanzaMainIs :: Maybe FilePath, + testStanzaTestModule :: Maybe ModuleName, + testStanzaBuildInfo :: BuildInfo + } + +emptyTestStanza :: TestSuiteStanza +emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty + +testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] +testSuiteFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) + , simpleField "test-module" + (maybe empty disp) (fmap Just parseModuleNameQ) + testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) + ] + ++ map biToTest binfoFieldDescrs + where + biToTest = liftField testStanzaBuildInfo + (\bi suite -> suite { testStanzaBuildInfo = bi }) + +storeXFieldsTest :: UnrecFieldParser TestSuiteStanza +storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = + Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsTest _ _ = Nothing + +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) + + Just tt@(TestTypeUnknown _ _) -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> + case testStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (testStanzaTestModule stanza)) $ + warning (extraField "test-module" tt) + return emptyTestSuite { + testInterface = TestSuiteExeV10 ver file, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> + case testStanzaTestModule stanza of + Nothing -> syntaxError line (missingField "test-module" tt) + Just module_ -> do + when (isJust (testStanzaMainIs stanza)) $ + warning (extraField "main-is" tt) + return emptyTestSuite { + testInterface = TestSuiteLibV09 ver module_, + testBuildInfo = testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + + +-- --------------------------------------------------------------------------- -- The BuildInfo type @@ -235,9 +327,23 @@ , listField "c-sources" showFilePath parseFilePathQ cSources (\paths binfo -> binfo{cSources=paths}) + + , simpleField "default-language" + (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) + defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) + , listField "other-languages" + disp parseLanguageQ + otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) + , listField "default-extensions" + disp parseExtensionQ + defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) + , listField "other-extensions" + disp parseExtensionQ + otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) , listField "extensions" disp parseExtensionQ - extensions (\exts binfo -> binfo{extensions=exts}) + oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) + , listField "extra-libraries" showToken parseTokenQ extraLibs (\xs binfo -> binfo{extraLibs=xs}) @@ -264,7 +370,7 @@ ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) , listField "ghc-shared-options" text parseTokenQ - ghcProfOptions (\val binfo -> binfo{ghcSharedOptions=val}) + ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val}) , optsField "ghc-options" GHC options (\path binfo -> binfo{options=path}) , optsField "hugs-options" Hugs @@ -469,10 +575,14 @@ _ -> parseFail err let cabalVersionNeeded = - head $ [ versionRange + head $ [ minVersionBound versionRange | Just versionRange <- [ simpleParse v | F _ "cabal-version" v <- fields0 ] ] - ++ [anyVersion] + ++ [Version [0] []] + minVersionBound versionRange = + case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version handleFutureVersionParseFailure cabalVersionNeeded $ do @@ -507,14 +617,14 @@ -- 'getBody' assumes that the remaining fields only consist of -- flags, lib and exe sections. - (repos, flags, mlib, exes) <- getBody + (repos, flags, mlib, exes, tests) <- getBody warnIfRest -- warn if getBody did not parse up to the last field. - when (not (oldSyntax fields0)) $ -- warn if we use new syntax - maybeWarnCabalVersion pkg -- without Cabal >= 1.2 - checkForUndefinedFlags flags mlib exes + -- warn about using old/new syntax with wrong cabal-version: + maybeWarnCabalVersion (not $ oldSyntax fields0) pkg + checkForUndefinedFlags flags mlib exes tests return $ GenericPackageDescription pkg { sourceRepos = repos } - flags mlib exes + flags mlib exes tests where oldSyntax flds = all isSimpleField flds @@ -522,21 +632,37 @@ syntaxError (fst (head tabs)) $ "Do not use tabs for indentation (use spaces instead)\n" ++ " Tabs were used at (line,column): " ++ show tabs - maybeWarnCabalVersion pkg = - when (packageName pkg /= PackageName "Cabal" -- supress warning for Cabal - && isAnyVersion (descCabalVersion pkg)) $ - lift $ warning $ - "A package using section syntax should require\n" - ++ "\"Cabal-Version: >= 1.2\" or equivalent." + maybeWarnCabalVersion newsyntax pkg + | newsyntax && specVersion pkg < Version [1,2] [] + = lift $ warning $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion newsyntax pkg + | not newsyntax && specVersion pkg >= Version [1,2] [] + = lift $ warning $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = (unless versionOk (warning message) >> parseBody) `catchParseError` \parseError -> case parseError of TabsError _ -> parseFail parseError _ | versionOk -> parseFail parseError | otherwise -> fail message - where versionOk = cabalVersion `withinRange` cabalVersionNeeded - message = "This package requires Cabal version: " + where versionOk = cabalVersionNeeded <= cabalVersion + message = "This package requires at least Cabal version " ++ display cabalVersionNeeded -- "Sectionize" an old-style Cabal file. A sectionized file has: @@ -598,13 +724,14 @@ _ -> return (reverse acc) -- - -- body ::= { repo | flag | library | executable }+ -- at most one lib + -- body ::= { repo | flag | library | executable | test }+ -- at most one lib -- -- The body consists of an optional sequence of declarations of flags and -- an arbitrary number of executables and at most one library. getBody :: PM ([SourceRepo], [Flag] ,Maybe (CondTree ConfVar [Dependency] Library) - ,[(String, CondTree ConfVar [Dependency] Executable)]) + ,[(String, CondTree ConfVar [Dependency] Executable)] + ,[(String, CondTree ConfVar [Dependency] TestSuite)]) getBody = peekField >>= \mf -> case mf of Just (Section line_no sec_type sec_label sec_fields) | sec_type == "executable" -> do @@ -613,18 +740,27 @@ exename <- lift $ runP line_no "executable" parseTokenQ sec_label flds <- collectFields parseExeFields sec_fields skipField - (repos, flags, lib, exes) <- getBody - return (repos, flags, lib, exes ++ [(exename, flds)]) + (repos, flags, lib, exes, tests) <- getBody + return (repos, flags, lib, exes ++ [(exename, flds)], tests) + | sec_type == "test-suite" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'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)]) + | sec_type == "library" -> do when (not (null sec_label)) $ lift $ syntaxError line_no "'library' expects no argument" flds <- collectFields parseLibFields sec_fields skipField - (repos, flags, lib, exes) <- getBody + (repos, flags, lib, exes, tests) <- getBody when (isJust lib) $ lift $ syntaxError line_no "There can only be one library section in a package description." - return (repos, flags, Just flds, exes) + return (repos, flags, Just flds, exes, tests) | sec_type == "flag" -> do when (null sec_label) $ lift $ @@ -635,8 +771,8 @@ (MkFlag (FlagName (lowercase sec_label)) "" True False) sec_fields skipField - (repos, flags, lib, exes) <- getBody - return (repos, flag:flags, lib, exes) + (repos, flags, lib, exes, tests) <- getBody + return (repos, flag:flags, lib, exes, tests) | sec_type == "source-repository" -> do when (null sec_label) $ lift $ syntaxError line_no $ @@ -660,8 +796,8 @@ }) sec_fields skipField - (repos, flags, lib, exes) <- getBody - return (repo:repos, flags, lib, exes) + (repos, flags, lib, exes, tests) <- getBody + return (repo:repos, flags, lib, exes, tests) | otherwise -> do lift $ warning $ "Ignoring unknown section type: " ++ sec_type @@ -672,7 +808,7 @@ "Construct not supported at this position: " ++ show f skipField getBody - Nothing -> return ([], [], Nothing, []) + Nothing -> return ([], [], Nothing, [], []) -- Extracts all fields in a block and returns a 'CondTree'. -- @@ -710,18 +846,27 @@ parseLibFields :: [Field] -> PM Library parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + -- Note: we don't parse the "executable" field here, hence the tail hack. parseExeFields :: [Field] -> PM Executable - parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable + parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable + parseTestFields :: LineNo -> [Field] -> PM TestSuite + parseTestFields line fields = do + x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest + emptyTestStanza fields + lift $ validateTestSuite line x + checkForUndefinedFlags :: [Flag] -> Maybe (CondTree ConfVar [Dependency] Library) -> [(String, CondTree ConfVar [Dependency] Executable)] -> + [(String, CondTree ConfVar [Dependency] TestSuite)] -> PM () - checkForUndefinedFlags flags mlib exes = do + checkForUndefinedFlags flags mlib exes tests = do let definedFlags = map flagName flags maybe (return ()) (checkCondTreeFlags definedFlags) mlib mapM_ (checkCondTreeFlags definedFlags . snd) exes + mapM_ (checkCondTreeFlags definedFlags . snd) tests checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () checkCondTreeFlags definedFlags ct = do @@ -824,6 +969,8 @@ writePackageDescription :: FilePath -> PackageDescription -> IO () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) +--TODO: make this use section syntax +-- add equivalent for GenericPackageDescription showPackageDescription :: PackageDescription -> String showPackageDescription pkg = render $ ppPackage pkg diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -57,7 +57,7 @@ parseFilePathQ, parseTokenQ, parseTokenQ', parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, parseOptVersion, parsePackageNameQ, parseVersionRangeQ, - parseTestedWithQ, parseLicenseQ, parseExtensionQ, + parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, parseSepList, parseCommaList, parseOptCommaList, showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, field, simpleField, listField, spaceListField, commaListField, @@ -78,7 +78,8 @@ ( Text(..) ) import Distribution.Simple.Utils ( intercalate, lowercase, normaliseLineEndings ) -import Language.Haskell.Extension (Extension) +import Language.Haskell.Extension + ( Language, Extension ) import Text.PrettyPrint.HughesPJ hiding (braces) import Data.Char (isSpace, toLower, isAlphaNum, isDigit) @@ -597,16 +598,19 @@ parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver - where ver = parse <++ return noVersion + where ver :: ReadP r Version + ver = parse <++ return noVersion noVersion = Version{ versionBranch=[], versionTags=[] } parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw - where tw = do compiler <- parseCompilerFlavorCompat - skipSpaces - version <- parse <++ return anyVersion - skipSpaces - return (compiler,version) + where + tw :: ReadP r (CompilerFlavor,VersionRange) + tw = do compiler <- parseCompilerFlavorCompat + skipSpaces + version <- parse <++ return anyVersion + skipSpaces + return (compiler,version) parseLicenseQ :: ReadP r License parseLicenseQ = parseQuoted parse <++ parse @@ -615,6 +619,9 @@ -- because the "compat" version of ReadP isn't quite powerful enough. In -- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a -- Hence the trick above to make 'lic' polymorphic. + +parseLanguageQ :: ReadP r Language +parseLanguageQ = parseQuoted parse <++ parse parseExtensionQ :: ReadP r Extension parseExtensionQ = parseQuoted parse <++ parse diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -54,6 +54,15 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Distribution.Simple ( module Distribution.Package, module Distribution.Version, @@ -99,11 +108,12 @@ import Distribution.Simple.Configure ( getPersistBuildConfig, maybeGetPersistBuildConfig - , writePersistBuildConfig, checkPersistBuildConfig + , writePersistBuildConfig, checkPersistBuildConfigOutdated , configure, checkForeignDeps ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Test (test) import Distribution.Simple.Install (install) import Distribution.Simple.Haddock (haddock, hscolour) import Distribution.Simple.Utils @@ -184,7 +194,8 @@ progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration commands = - [configureCommand progs `commandAddAction` configureAction hooks + [configureCommand progs `commandAddAction` \fs as -> + configureAction hooks fs as >> return () ,buildCommand progs `commandAddAction` buildAction hooks ,installCommand `commandAddAction` installAction hooks ,copyCommand `commandAddAction` copyAction hooks @@ -207,7 +218,7 @@ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) -configureAction :: UserHooks -> ConfigFlags -> Args -> IO () +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do let distPref = fromFlag $ configDistPref flags pbi <- preConf hooks args flags @@ -224,11 +235,16 @@ localbuildinfo0 <- confHook hooks epkg_descr flags -- remember the .cabal filename if we know it - let localbuildinfo = localbuildinfo0{ pkgDescrFile = mb_pd_file } + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } writePersistBuildConfig distPref localbuildinfo let pkg_descr = localPkgDescr localbuildinfo postConf hooks args flags pkg_descr localbuildinfo + return localbuildinfo where verbosity = fromFlag (configVerbosity flags) confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) @@ -246,7 +262,7 @@ let distPref = fromFlag $ buildDistPref flags verbosity = fromFlag $ buildVerbosity flags - lbi <- getBuildConfig hooks distPref + lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity (buildProgramPaths flags) (buildProgramArgs flags) @@ -258,9 +274,10 @@ hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args - = do let distPref = fromFlag $ hscolourDistPref flags + = do let distPref = fromFlag $ hscolourDistPref flags + verbosity = fromFlag $ hscolourVerbosity flags hookedAction preHscolour hscolourHook postHscolour - (getBuildConfig hooks distPref) + (getBuildConfig hooks verbosity distPref) hooks flags args haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () @@ -268,7 +285,7 @@ let distPref = fromFlag $ haddockDistPref flags verbosity = fromFlag $ haddockVerbosity flags - lbi <- getBuildConfig hooks distPref + lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity (haddockProgramPaths flags) (haddockProgramArgs flags) @@ -293,16 +310,18 @@ copyAction :: UserHooks -> CopyFlags -> Args -> IO () copyAction hooks flags args - = do let distPref = fromFlag $ copyDistPref flags + = do let distPref = fromFlag $ copyDistPref flags + verbosity = fromFlag $ copyVerbosity flags hookedAction preCopy copyHook postCopy - (getBuildConfig hooks distPref) + (getBuildConfig hooks verbosity distPref) hooks flags args installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args - = do let distPref = fromFlag $ installDistPref flags + = do let distPref = fromFlag $ installDistPref flags + verbosity = fromFlag $ installVerbosity flags hookedAction preInst instHook postInst - (getBuildConfig hooks distPref) + (getBuildConfig hooks verbosity distPref) hooks flags args sdistAction :: UserHooks -> SDistFlags -> Args -> IO () @@ -322,23 +341,35 @@ testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do - let distPref = fromFlag $ testDistPref flags - localbuildinfo <- getBuildConfig hooks distPref - let pkg_descr = localPkgDescr localbuildinfo - runTests hooks args False pkg_descr localbuildinfo + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + localBuildInfo <- getBuildConfig hooks verbosity distPref + let pkg_descr = localPkgDescr localBuildInfo + -- It is safe to do 'runTests' before the new test handler because the + -- default action is a no-op and if the package uses the old test interface + -- the new handler will find no tests. + runTests hooks args False pkg_descr localBuildInfo + --FIXME: this is a hack, passing the args inside the flags + -- it's because the args to not get passed to the main test hook + let flags' = flags { testList = Flag args } + hookedAction preTest testHook postTest + (getBuildConfig hooks verbosity distPref) + hooks flags' args registerAction :: UserHooks -> RegisterFlags -> Args -> IO () registerAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags hookedAction preReg regHook postReg - (getBuildConfig hooks distPref) + (getBuildConfig hooks verbosity distPref) hooks flags args unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags hookedAction preUnreg unregHook postUnreg - (getBuildConfig hooks distPref) + (getBuildConfig hooks verbosity distPref) hooks flags args hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) @@ -354,23 +385,50 @@ let pkg_descr0 = localPkgDescr localbuildinfo --pkg_descr0 <- get_pkg_descr (get_verbose flags) let pkg_descr = updatePackageDescription pbi pkg_descr0 - -- XXX: should we write the modified package descr back to the + -- TODO: should we write the modified package descr back to the -- localbuildinfo? cmd_hook hooks pkg_descr localbuildinfo hooks flags post_hook hooks args flags pkg_descr localbuildinfo -getBuildConfig :: UserHooks -> FilePath -> IO LocalBuildInfo -getBuildConfig hooks distPref = do - lbi <- getPersistBuildConfig distPref - case pkgDescrFile lbi of - Nothing -> return () - Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file - return lbi { +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { withPrograms = restoreProgramConfiguration (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi) + (withPrograms lbi_wo_programs) } + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = cFlags { + -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a conigure run: + configPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (configPrograms cFlags), + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + + -- -------------------------------------------------------------------------- -- Cleaning @@ -417,6 +475,7 @@ postConf = finalChecks, buildHook = defaultBuildHook, copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params + testHook = defaultTestHook, instHook = defaultInstallHook, sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), cleanHook = \p _ _ f -> clean p f, @@ -537,6 +596,11 @@ Just infoFile -> do info verbosity $ "Reading parameters from " ++ infoFile readHookedBuildInfo verbosity infoFile + +defaultTestHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> TestFlags -> IO () +defaultTestHook pkg_descr localbuildinfo _ flags = + test pkg_descr localbuildinfo flags defaultInstallHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -57,17 +57,19 @@ import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.NHC as NHC import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.Build.Macros as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule import Distribution.Package - ( Package(..), PackageId, InstalledPackageId(..) ) + ( Package(..), PackageName(..), PackageIdentifier(..) + , thisPackageVersion ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..) - , Library(..), Executable(..) ) + ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) + , TestSuite(..), TestSuiteInterface(..) ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName @@ -77,11 +79,13 @@ ( preprocessSources, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(compiler, buildDir, withPackageDB) - , ComponentLocalBuildInfo, withLibLBI, withExeLBI ) + , ComponentLocalBuildInfo(..), withLibLBI, withExeLBI + , inplacePackageId, withTestLBI ) import Distribution.Simple.BuildPaths ( autogenModulesDir, autogenModuleName, cppHeaderName ) import Distribution.Simple.Register ( registerPackage, inplaceInstalledPackageInfo ) +import Distribution.Simple.Test ( stubFilePath, stubName ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, rewriteFile , die, info, setupMessage ) @@ -130,7 +134,8 @@ IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo) } registerPackage verbosity - installedPkgInfo pkg_descr lbi True{-inplace-} internalPackageDB + installedPkgInfo pkg_descr lbi True -- True meaning inplace + (withPackageDB lbi ++ [internalPackageDB]) -- Use the internal package db for the exes. let lbi' = lbi { withPackageDB = withPackageDB lbi ++ [internalPackageDB] } @@ -139,10 +144,64 @@ info verbosity $ "Building executable " ++ exeName exe ++ "..." buildExe verbosity pkg_descr lbi' exe clbi --- Quick hack in 1.8 branch, it's done properly in HEAD -inplacePackageId :: PackageId -> InstalledPackageId -inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + withTestLBI pkg_descr lbi' $ \test clbi -> + case testInterface test of + TestSuiteExeV10 _ f -> do + let exe = Executable + { exeName = testName test + , modulePath = f + , buildInfo = testBuildInfo test + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + TestSuiteLibV09 _ m -> do + pwd <- getCurrentDirectory + let lib = Library + { exposedModules = [ m ] + , libExposed = True + , libBuildInfo = testBuildInfo test + } + pkg = pkg_descr + { package = (package pkg_descr) + { pkgName = PackageName $ testName test + } + , buildDepends = targetBuildDepends $ testBuildInfo test + , executables = [] + , testSuites = [] + , library = Just lib + } + ipi = (inplaceInstalledPackageInfo + pwd distPref pkg lib lbi clbi) + { IPI.installedPackageId = inplacePackageId $ packageId ipi + } + testDir = buildDir lbi' stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable + { exeName = stubName test + , modulePath = stubFilePath test + , buildInfo = (testBuildInfo test) + { hsSourceDirs = [ testDir ] + , targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + exeClbi = clbi + { componentPackageDeps = + (IPI.installedPackageId ipi, packageId ipi) + : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") + $ componentPackageDeps clbi) + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildLib verbosity pkg lbi' lib clbi + registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' + buildExe verbosity pkg_descr lbi' exe exeClbi + TestSuiteUnsupported tt -> die $ "No support for building test suite " + ++ "type " ++ display tt + -- | Initialize a new package db file for libraries defined -- internally to the package. createInternalPackageDB :: FilePath -> IO PackageDB @@ -152,6 +211,8 @@ writeFile dbFile "[]" return packageDB +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style testsuites buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = @@ -161,6 +222,7 @@ LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi NHC -> NHC.buildLib verbosity pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi _ -> die "Building is not supported with this compiler." buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo @@ -172,6 +234,7 @@ LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi NHC -> NHC.buildExe verbosity pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi _ -> die "Building is not supported with this compiler." initialBuildSteps :: FilePath -- ^"dist" prefix diff --git a/Distribution/Simple/Build/Macros.hs b/Distribution/Simple/Build/Macros.hs --- a/Distribution/Simple/Build/Macros.hs +++ b/Distribution/Simple/Build/Macros.hs @@ -10,6 +10,7 @@ -- -- When using CPP you get -- +-- > VERSION_ -- > MIN_VERSION_(A,B,C) -- -- for each /package/ in @build-depends@, which is true if the version of @@ -40,6 +41,7 @@ "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : [ concat ["/* package ",display pkgid," */\n" + ,"#define VERSION_",pkgname," ",show (display version),"\n" ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" ," (major1) < ",major1," || \\\n" ," (major1) == ",major1," && (major2) < ",major2," || \\\n" diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs --- a/Distribution/Simple/Build/PathsModule.hs +++ b/Distribution/Simple/Build/PathsModule.hs @@ -15,7 +15,7 @@ -- at runtime. This code should probably be split off into another module. -- module Distribution.Simple.Build.PathsModule ( - generate + generate, pkgPathEnvVar ) where import Distribution.System @@ -142,10 +142,7 @@ mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++ " (\\_ -> "++expr++")" - where var' = showPkgName (packageName pkg_descr) ++ "_" ++ var - showPkgName = map fixchar . display - fixchar '-' = '_' - fixchar c = c + where var' = pkgPathEnvVar pkg_descr var -- In several cases we cannot make relocatable installations absolute = @@ -175,6 +172,19 @@ compilerFlavor (compiler lbi) == GHC && (compilerVersion (compiler lbi) `withinRange` orLaterVersion (Version [6,6,1] [])) + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +pkgPathEnvVar :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", + -- \"datadir\" or \"libexecdir\" + -> String -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + where + showPkgName = map fixchar . display + fixchar '-' = '_' + fixchar c = c get_prefix_win32 :: String get_prefix_win32 = diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -64,6 +64,8 @@ -- * Support for language extensions Flag, + languageToFlags, + unsupportedLanguages, extensionsToFlags, unsupportedExtensions ) where @@ -71,13 +73,14 @@ import Distribution.Compiler import Distribution.Version (Version(..)) import Distribution.Text (display) -import Language.Haskell.Extension (Extension(..)) +import Language.Haskell.Extension (Language(Haskell98), Extension) import Data.List (nub) import Data.Maybe (catMaybes, isNothing) data Compiler = Compiler { compilerId :: CompilerId, + compilerLanguages :: [(Language, String)], compilerExtensions :: [(Extension, String)] } deriving (Show, Read) @@ -105,7 +108,7 @@ data PackageDB = GlobalPackageDB | UserPackageDB | SpecificPackageDB FilePath - deriving (Eq, Show, Read) + deriving (Eq, Ord, Show, Read) -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example @@ -157,8 +160,22 @@ _ -> error $ "Can't parse optimisation level " ++ s -- ------------------------------------------------------------ --- * Extensions +-- * Languages and Extensions -- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs + , isNothing (languageToFlag comp lang) ] + +languageToFlags :: Compiler -> Maybe Language -> [Flag] +languageToFlags comp = filter (not . null) + . catMaybes . map (languageToFlag comp) + . maybe [Haskell98] (\x->[x]) + +languageToFlag :: Compiler -> Language -> Maybe Flag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + -- |For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -53,7 +53,7 @@ module Distribution.Simple.Configure (configure, writePersistBuildConfig, getPersistBuildConfig, - checkPersistBuildConfig, + checkPersistBuildConfigOutdated, maybeGetPersistBuildConfig, localBuildInfoFile, getInstalledPackages, @@ -66,7 +66,8 @@ import Distribution.Simple.Compiler ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion - , showCompilerId, unsupportedExtensions, PackageDB(..), PackageDBStack ) + , showCompilerId, unsupportedLanguages, unsupportedExtensions + , PackageDB(..), PackageDBStack ) import Distribution.Package ( PackageName(PackageName), PackageIdentifier(PackageIdentifier), PackageId , packageName, packageVersion, Package(..) @@ -78,12 +79,12 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.PackageDescription as PD - ( PackageDescription(..), GenericPackageDescription(..) - , Library(..), hasLibs, Executable(..), BuildInfo(..) + ( PackageDescription(..), specVersion, GenericPackageDescription(..) + , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions , HookedBuildInfo, updatePackageDescription, allBuildInfo - , FlagName(..) ) + , FlagName(..), TestSuite(..) ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) + ( finalizePackageDescription, flattenPackageDescription ) import Distribution.PackageDescription.Check ( PackageCheck(..), checkPackage, checkPackageFiles ) import Distribution.Simple.Program @@ -91,7 +92,7 @@ , ProgramConfiguration, defaultProgramConfiguration , configureAllKnownPrograms, knownPrograms, lookupKnownProgram , userSpecifyArgss, userSpecifyPaths - , lookupProgram, requireProgram, requireProgramVersion + , requireProgram, requireProgramVersion , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) import Distribution.Simple.Setup ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) @@ -99,18 +100,18 @@ ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , absoluteInstallDirs, prefixRelativeInstallDirs ) + , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir ) import Distribution.Simple.Utils ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose - , intercalate, cabalVersion, cabalBootstrapping + , intercalate, cabalVersion , withFileContents, writeFileAtomic , withTempFile ) import Distribution.System ( OS(..), buildOS, buildPlatform ) import Distribution.Version - ( Version(..), anyVersion, orLaterVersion, withinRange - , isSpecificVersion, isAnyVersion - , LowerBound(..), asVersionIntervals ) + ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity ( Verbosity, lessVerbose ) @@ -119,13 +120,14 @@ import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.NHC as NHC import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC import Control.Monad ( when, unless, foldM, filterM ) import Data.List ( nub, partition, isPrefixOf, inits ) import Data.Maybe - ( fromMaybe, isNothing ) + ( isNothing, catMaybes ) import Data.Monoid ( Monoid(..) ) import System.Directory @@ -221,9 +223,7 @@ where currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier (PackageName "Cabal") currentVersion - where currentVersion | cabalBootstrapping = Version [0] [] - | otherwise = cabalVersion +currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion currentCompilerId :: PackageIdentifier currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) @@ -244,12 +244,11 @@ -- |Check that localBuildInfoFile is up-to-date with respect to the -- .cabal file. -checkPersistBuildConfig :: FilePath -> FilePath -> IO () -checkPersistBuildConfig distPref pkg_descr_file = do +checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = do t0 <- getModificationTime pkg_descr_file t1 <- getModificationTime $ localBuildInfoFile distPref - when (t0 > t1) $ - die (pkg_descr_file ++ " has been changed, please re-configure.") + return (t0 > t1) -- |@dist\/setup-config@ localBuildInfoFile :: FilePath -> FilePath @@ -311,16 +310,20 @@ Installed.sourcePackageId = pid } internalPackageSet = PackageIndex.fromList [internalPackage] - maybeInstalledPackageSet <- getInstalledPackages (lessVerbose verbosity) comp + installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp packageDbs programsConfig' let -- Constraint test function for the solver - dependencySatisfiable = case maybeInstalledPackageSet of - Nothing -> const True -- we do not know what is available so - -- we pretend everything is available - Just pkgs -> not . null . PackageIndex.lookupDependency pkgs' - where - pkgs' = PackageIndex.insert internalPackage pkgs + dependencySatisfiable = + not . null . PackageIndex.lookupDependency pkgs' + where + pkgs' = PackageIndex.insert internalPackage installedPackageSet + pkg_descr0'' = + --TODO: avoid disabling tests entirely, we otherwise cannot + -- perform semantic checks, see also checkPackageProblems + if fromFlag (configTests cfg) + then pkg_descr0 + else pkg_descr0 { condTestSuites = [] } (pkg_descr0', flags) <- case finalizePackageDescription @@ -329,7 +332,7 @@ Distribution.System.buildPlatform (compilerId comp) (configConstraints cfg) - pkg_descr0 + pkg_descr0'' of Right r -> return r Left missing -> die $ "At least the following dependencies are missing:\n" @@ -349,18 +352,7 @@ checkPackageProblems verbosity pkg_descr0 (updatePackageDescription pbi pkg_descr) - let installedPackageSet = fromMaybe bogusPackageSet maybeInstalledPackageSet - -- FIXME: For Hugs, nhc98 and other compilers we do not know what - -- packages are already installed, so we just make some up, pretend - -- that they do exist and just hope for the best. We make them up - -- based on what other package the package we're currently building - -- happens to depend on. See 'inventBogusPackageInfo' below. - -- Let's hope they really are installed... :-) - bogusDependencies = map inventBogusPackageInfo - (buildDepends pkg_descr) - bogusPackageSet = PackageIndex.fromList bogusDependencies - - selectDependencies = + let selectDependencies = (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) . map (selectDependency internalPackageSet installedPackageSet) @@ -416,8 +408,15 @@ let installDirs = combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs cfg) - -- check extensions - let extlist = nub $ concatMap extensions (allBuildInfo pkg_descr) + -- check languages and extensions + let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display langs) + let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) let exts = unsupportedExtensions comp extlist when (not (null exts)) $ die $ "The package " ++ display (packageId pkg_descr0) @@ -450,6 +449,8 @@ -- versions of the same package. let configLib lib = configComponent (libBuildInfo lib) configExe exe = (exeName exe, configComponent(buildInfo exe)) + configTest test = (testName test, + configComponent(testBuildInfo test)) configComponent bi = ComponentLocalBuildInfo { componentPackageDeps = if newPackageDepsBehaviour pkg_descr' @@ -467,6 +468,10 @@ names = [ name | Dependency name _ <- targetBuildDepends bi ] let lbi = LocalBuildInfo{ + configFlags = cfg, + extraConfigArgs = [], -- Currently configure does not + -- take extra args, but if it + -- did they would go here. installDirTemplates = installDirs, compiler = comp, buildDir = distPref "build", @@ -475,6 +480,7 @@ (configScratchDir cfg), libraryConfig = configLib `fmap` library pkg_descr', executableConfigs = configExe `fmap` executables pkg_descr', + testSuiteConfigs = configTest `fmap` testSuites pkg_descr', installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, localPkgDescr = pkg_descr', @@ -531,25 +537,9 @@ in pkg_descr{ library = modifyLib `fmap` library pkg_descr , executables = modifyExecutable `map` executables pkg_descr} --- Quick hack in 1.8 branch, it's done properly in HEAD -inplacePackageId :: PackageId -> InstalledPackageId -inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") - -- ----------------------------------------------------------------------------- -- Configuring package dependencies --- |Converts build dependencies to a versioned dependency. only sets --- version information for exact versioned dependencies. -inventBogusPackageInfo :: Dependency -> InstalledPackageInfo -inventBogusPackageInfo (Dependency s vr) = - emptyInstalledPackageInfo { - Installed.sourcePackageId = case isSpecificVersion vr of - -- if they specify the exact version, use that: - Just v -> PackageIdentifier s v - -- otherwise, just set it to empty - Nothing -> PackageIdentifier s (Version [] []) - } - reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () reportProgram verbosity prog Nothing = info verbosity $ "No " ++ programName prog ++ " found" @@ -630,16 +620,18 @@ getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration - -> IO (Maybe PackageIndex) + -> IO PackageIndex getInstalledPackages verbosity comp packageDBs progconf = do info verbosity "Reading installed packages..." case compilerFlavor comp of - GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDBs progconf - Hugs-> Just `fmap`Hugs.getInstalledPackages verbosity packageDBs progconf - JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDBs progconf - LHC -> Just `fmap` LHC.getInstalledPackages verbosity packageDBs progconf - NHC -> Just `fmap` NHC.getInstalledPackages verbosity packageDBs progconf - _ -> return Nothing + GHC -> GHC.getInstalledPackages verbosity packageDBs progconf + Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf + JHC -> JHC.getInstalledPackages verbosity packageDBs progconf + LHC -> LHC.getInstalledPackages verbosity packageDBs progconf + NHC -> NHC.getInstalledPackages verbosity packageDBs progconf + UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf + flv -> die $ "don't know how to find the installed packages for " + ++ display flv -- | Currently the user interface specifies the package dbs to use with just a -- single valued option, a 'PackageDB'. However internally we represent the @@ -664,13 +656,8 @@ -- specified is >= a certain minimum. Otherwise, for compatibility we use the -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool -newPackageDepsBehaviour pkg_descr = - minVersionRequired >= newPackageDepsBehaviourMinVersion - where - minVersionRequired = - case asVersionIntervals (descCabalVersion pkg_descr) of - [] -> Version [0] [] - ((LowerBound v _, _):_) -> v +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion -- ----------------------------------------------------------------------------- -- Configuring program dependencies @@ -804,9 +791,15 @@ LHC.configure verbosity hcPath Nothing ghcConf Hugs -> Hugs.configure verbosity hcPath hcPkg conf NHC -> NHC.configure verbosity hcPath hcPkg conf + UHC -> UHC.configure verbosity hcPath hcPkg conf _ -> die "Unknown compiler" +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () checkForeignDeps pkg lbi verbosity = do ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky @@ -822,22 +815,23 @@ ok <- builds (makeProgram headers) args if ok then success else failure - -- NOTE: if some package-local header has errors, - -- we will report that this header is missing. - -- Maybe additional tests for local headers are needed - -- for better diagnostics findOffendingHdr = - ifBuildsWith allHeaders cppArgs + ifBuildsWith allHeaders ccArgs (return Nothing) (go . tail . inits $ allHeaders) where go [] = return Nothing -- cannot happen - go (hdrs:hdrsInits) = do + go (hdrs:hdrsInits) = + -- Try just preprocessing first ifBuildsWith hdrs cppArgs - (go hdrsInits) - (return . Just . last $ hdrs) + -- If that works, try compiling too + (ifBuildsWith hdrs ccArgs + (go hdrsInits) + (return . Just . Right . last $ hdrs)) + (return . Just . Left . last $ hdrs) - cppArgs = "-c":commonCcArgs -- don't try to link + cppArgs = "-E":commonCppArgs -- preprocess only + ccArgs = "-c":commonCcArgs -- don't try to link findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) (return []) @@ -845,8 +839,8 @@ libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - commonCcArgs = programArgs gccProg - ++ hcDefines (compiler lbi) + commonCppArgs = hcDefines (compiler lbi) + ++ [ "-I" ++ autogenModulesDir lbi ] ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] ++ ["-I."] ++ collectField PD.cppOptions @@ -858,6 +852,12 @@ | dep <- deps , opt <- Installed.ccOptions dep ] + commonCcArgs = commonCppArgs + ++ collectField PD.ccOptions + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] ++ collectField PD.ldOptions ++ [ "-L" ++ dir @@ -872,7 +872,6 @@ collectField f = concatMap f allBi allBi = allBuildInfo pkg - Just gccProg = lookupProgram gccProgram (withPrograms lbi) deps = PackageIndex.topologicalOrder (installedPkgs lbi) builds program args = do @@ -888,35 +887,57 @@ `catchIO` (\_ -> return False) `catchExit` (\_ -> return False) - explainErrors Nothing [] = return () - explainErrors hdr libs = die $ unlines $ - (if plural then "Missing dependencies on foreign libraries:" - else "Missing dependency on a foreign library:") - : case hdr of - Nothing -> [] - Just h -> ["* Missing header file: " ++ h ] + explainErrors Nothing [] = return () -- should be impossible! + explainErrors hdr libs = die $ unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] + _ -> [] ++ case libs of [] -> [] [lib] -> ["* Missing C library: " ++ lib] _ -> ["* Missing C libraries: " ++ intercalate ", " libs] - ++ [if plural then messagePlural else messageSingular] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [ headerCppMessage ] + Just (Right h) -> [ (if missing then "* " else "") + ++ "Bad header file: " ++ h + , headerCcMessage ] + _ -> [] + where - plural = length libs >= 2 - messageSingular = - "This problem can usually be solved by installing the system " - ++ "package that provides this library (you may need the " - ++ "\"-dev\" version). If the library is already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where it is." - messagePlural = - "This problem can usually be solved by installing the system " - ++ "packages that provide these libraries (you may need the " - ++ "\"-dev\" versions). If the libraries are already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where they are." + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + --FIXME: share this with the PreProcessor module hcDefines :: Compiler -> [String] hcDefines comp = @@ -949,7 +970,7 @@ -> GenericPackageDescription -> PackageDescription -> IO () -checkPackageProblems verbosity gpkg pkg = do +checkPackageProblems verbosity gpkg pkg0 = do ioChecks <- checkPackageFiles pkg "." let pureChecks = checkPackage gpkg (Just pkg) errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] @@ -958,3 +979,16 @@ then mapM_ (warn verbosity) warnings else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors exitWith (ExitFailure 1) + where + -- TODO: Sigh, this is a fairly unpleasent hack. The issue is that + -- we want to check test-suite sections even when tests are disabled. + -- When tests are disabled we have to exclude the test-suite sections + -- when resolving the conditionals. But the checks we do are done + -- on the post-resolved form! Ug. A better solution would be either + -- 1) to do the checks on the pre-resolved form + -- 2) to resolve in two steps: find a flag assignment, then apply it + -- that'd allow us to find the flag assingment ignoring tests + -- but then to apply it anyway. + -- In the meantime we stick the tests back in before checking by + -- flattening the pre-resovled form. + pkg = pkg0 { testSuites = testSuites (flattenPackageDescription gpkg) } diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -65,17 +65,18 @@ buildLib, buildExe, installLib, installExe, libAbiHash, + registerPackage, ghcOptions, - ghcVerbosityOptions + ghcVerbosityOptions, + ghcPackageDbOptions, + ghcLibDir, ) where import qualified Distribution.Simple.GHC.IPI641 as IPI641 import qualified Distribution.Simple.GHC.IPI642 as IPI642 -import Distribution.Simple.Setup - ( CopyFlags(..), fromFlag ) import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..), withExe - , Library(..), libModules, hcOptions ) + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -83,8 +84,8 @@ import Distribution.Simple.PackageIndex (PackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), - absoluteInstallDirs ) + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , absoluteInstallDirs ) import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils @@ -105,7 +106,7 @@ import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , OptimisationLevel(..), PackageDB(..), PackageDBStack - , Flag, extensionsToFlags ) + , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion ) import Distribution.System @@ -113,7 +114,7 @@ import Distribution.Verbosity import Distribution.Text ( display, simpleParse ) -import Language.Haskell.Extension (Extension(..)) +import Language.Haskell.Extension (Language(..), Extension(..)) import Control.Monad ( unless, when ) import Data.Char ( isSpace ) @@ -154,11 +155,13 @@ ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion - languageExtensions <- getLanguageExtensions verbosity ghcProg + languages <- getLanguages verbosity ghcProg + extensions <- getExtensions verbosity ghcProg let comp = Compiler { compilerId = CompilerId GHC ghcVersion, - compilerExtensions = languageExtensions + compilerLanguages = languages, + compilerExtensions = extensions } conf''' = configureToolchain ghcProg conf'' -- configure gcc and ld return (comp, conf''') @@ -279,8 +282,17 @@ then return ["-x"] else return [] -getLanguageExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] -getLanguageExtensions verbosity ghcProg +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ ghcProg + -- TODO: should be using --supported-languages rather than hard coding + | ghcVersion >= Version [7] [] = return [(Haskell98, "-XHaskell98") + ,(Haskell2010, "-XHaskell2010")] + | otherwise = return [(Haskell98, "")] + where + Just ghcVersion = programVersion ghcProg + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity ghcProg | ghcVersion >= Version [6,7] [] = do exts <- rawSystemStdout verbosity (programPath ghcProg) @@ -380,6 +392,11 @@ _ -> index -- No (or multiple) ghc rts package is registered!! -- Feh, whatever, the ghc testsuite does some crazy stuff. +ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +ghcLibDir verbosity lbi = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] + ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath ghcLibDir' verbosity ghcProg = (reverse . dropWhile isSpace . reverse) `fmap` @@ -488,7 +505,7 @@ comp (withProfLib lbi) (libBuildInfo lib) let libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` extensions libBi + forceVanillaLib = TemplateHaskell `elem` allExtensions libBi -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir @@ -686,7 +703,7 @@ -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi) + when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi) (runGhcProg (binArgs False False)) runGhcProg (binArgs True (withProfExe lbi)) @@ -791,7 +808,8 @@ NormalOptimisation -> ["-O"] MaximumOptimisation -> ["-O2"]) ++ hcOptions GHC bi - ++ extensionsToFlags (compiler lbi) (extensions bi) + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) where ghcVer = compilerVersion (compiler lbi) @@ -815,7 +833,7 @@ where specific (SpecificPackageDB db) = [ "-package-conf", db ] specific _ = ierror - ierror = error "internal error: unexpected package db stack" + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> Verbosity -> Bool @@ -839,7 +857,7 @@ ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> [String] ghcCcOptions lbi bi clbi odir - = ["-I" ++ dir | dir <- PD.includeDirs bi] + = ["-I" ++ dir | dir <- odir : PD.includeDirs bi] ++ ghcPackageDbOptions (withPackageDB lbi) ++ ghcPackageFlags lbi clbi ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] @@ -855,26 +873,25 @@ -- Installing -- |Install executables for GHC. -installExe :: CopyFlags -- ^verbosity +installExe :: Verbosity -> LocalBuildInfo -> InstallDirs FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription + -> Executable -> IO () -installExe flags lbi installDirs buildPref (progprefix, progsuffix) pkg_descr - = do let verbosity = fromFlag (copyVerbosity flags) - binDir = bindir installDirs - createDirectoryIfMissingVerbose verbosity True binDir - withExe pkg_descr $ \Executable { exeName = e } -> do - let exeFileName = e <.> exeExtension - fixedExeBaseName = progprefix ++ e ++ progsuffix - installBinary dest = do - installExecutableFile verbosity - (buildPref e exeFileName) - (dest <.> exeExtension) - stripExe verbosity lbi exeFileName (dest <.> exeExtension) - installBinary (binDir fixedExeBaseName) +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $ @@ -894,39 +911,39 @@ _ -> [] -- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: CopyFlags -- ^verbosity +installLib :: Verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic librarys -> FilePath -- ^Build location - -> PackageDescription -> IO () -installLib flags lbi targetDir dynlibTargetDir builtDir - pkg@PackageDescription{library=Just lib} = do - -- copy .hi files over: - let verbosity = fromFlag (copyVerbosity flags) - copyHelper installFun src dst n = do - createDirectoryIfMissingVerbose verbosity True dst - installFun verbosity (src n) (dst n) - copy = copyHelper installOrdinaryFile - copyShared = copyHelper installExecutableFile - copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) - >>= installOrdinaryFiles verbosity targetDir - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" - ifShared $ copyModuleFiles "dyn_hi" + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copyHelper installFun src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installFun verbosity (src n) (dst n) + copy = copyHelper installOrdinaryFile + copyShared = copyHelper installExecutableFile + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + ifShared $ copyModuleFiles "dyn_hi" - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copyShared builtDir dynlibTargetDir sharedLibName + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copyShared builtDir dynlibTargetDir sharedLibName - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi - (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi - (targetDir profileLibName) + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) where vanillaLibName = mkLibName pkgid @@ -943,9 +960,6 @@ ifGHCi = when (hasLib && withGHCiLib lbi) ifShared = when (hasLib && withSharedLib lbi) -installLib _ _ _ _ _ PackageDescription{library=Nothing} - = die $ "Internal Error. installLibGHC called with no library." - -- | On MacOS X we have to call @ranlib@ to regenerate the archive index after -- copying. This is because the silly MacOS X linker checks that the archive -- index is not older than the file itself, which means simply @@ -957,3 +971,19 @@ (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi) rawSystemProgram verbosity ranlib [path] | otherwise = return () + + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo) diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -55,18 +55,21 @@ ( PackageIdentifier, Package(..), packageName ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD - (PackageDescription(..), BuildInfo(..), - Library(..), hasLibs, withLib, - Executable(..), withExe) + ( PackageDescription(..), BuildInfo(..), allExtensions + , Library(..), hasLibs, withLib + , Executable(..), withExe ) import Distribution.Simple.Compiler ( Compiler(..), compilerVersion ) +import Distribution.Simple.GHC ( ghcLibDir ) import Distribution.Simple.Program ( ConfiguredProgram(..), requireProgramVersion - , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout - , hscolourProgram, haddockProgram, ghcProgram ) + , rawSystemProgram, rawSystemProgramStdout + , hscolourProgram, haddockProgram ) import Distribution.Simple.PreProcess (ppCpp', ppUnlit, PPSuffixHandler, runSimplePreProcessor) import Distribution.Simple.Setup + ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag + , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps) import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, PathTemplateVariable(..), @@ -103,7 +106,6 @@ import Control.Exception (assert) import Data.Monoid import Data.Maybe ( fromMaybe, listToMaybe ) -import Data.Char (isSpace) import System.FilePath((), (<.>), splitFileName, splitExtension, normalise, splitPath, joinPath) @@ -198,18 +200,22 @@ [ fromFlags flags , fromPackageDescription pkg_descr ] - withLibLBI pkg_descr lbi $ \lib clbi -> do - let bi = libBuildInfo lib - libArgs <- fromLibrary lbi lib clbi - prepareSources verbosity lbi isVersion2 bi (args `mappend` libArgs) $ - runHaddock verbosity confHaddock + withLibLBI pkg_descr lbi $ \lib clbi -> + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = libBuildInfo lib + libArgs <- fromLibrary tmp lbi lib clbi + libArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` libArgs) + runHaddock verbosity confHaddock libArgs' when (flag haddockExecutables) $ - withExeLBI pkg_descr lbi $ \exe clbi -> do - let bi = buildInfo exe - exeArgs <- fromExecutable lbi exe clbi - prepareSources verbosity lbi isVersion2 bi (args `mappend` exeArgs) $ - runHaddock verbosity confHaddock + withExeLBI pkg_descr lbi $ \exe clbi -> + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = buildInfo exe + exeArgs <- fromExecutable tmp lbi exe clbi + exeArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` exeArgs) + runHaddock verbosity confHaddock exeArgs' where verbosity = flag haddockVerbosity @@ -218,15 +224,14 @@ -- | performs cpp and unlit preprocessing where needed on the files in -- | argTargets, which must have an .hs or .lhs extension. prepareSources :: Verbosity + -> FilePath -> LocalBuildInfo -> Bool -- haddock == 2.* -> BuildInfo -> HaddockArgs - -> (HaddockArgs -> IO a) - -> IO a -prepareSources verbosity lbi isVersion2 bi args@HaddockArgs{argTargets=files} k = - withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> - mapM (mockPP tmp) files >>= \targets -> k args {argTargets=targets} + -> IO HaddockArgs +prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} = + mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets} where mockPP pref file = do let (filePref, fileName) = splitFileName file @@ -251,7 +256,7 @@ removeFile targetFile return hsFile - needsCpp = CPP `elem` extensions bi + needsCpp = CPP `elem` allExtensions bi defines | isVersion2 = [] | otherwise = ["-D__HADDOCK__"] @@ -287,22 +292,38 @@ subtitle | null (synopsis pkg_descr) = "" | otherwise = ": " ++ synopsis pkg_descr -fromLibrary :: LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO HaddockArgs -fromLibrary lbi lib clbi = +fromLibrary :: FilePath + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> IO HaddockArgs +fromLibrary tmp lbi lib clbi = do inFiles <- map snd `fmap` getLibSourceFiles lbi lib return $ mempty { argHideModules = (mempty,otherModules $ bi), - argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi), + argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ++ [ "-odir", tmp, "-hidir", tmp + , "-stubdir", tmp ], argTargets = inFiles } where bi = libBuildInfo lib -fromExecutable :: LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO HaddockArgs -fromExecutable lbi exe clbi = +fromExecutable :: FilePath + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo + -> IO HaddockArgs +fromExecutable tmp lbi exe clbi = do inFiles <- map snd `fmap` getExeSourceFiles lbi exe return $ mempty { - argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi), + argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ++ [ "-odir", tmp, "-hidir", tmp + , "-stubdir", tmp ], argOutputDir = Dir (exeName exe), argTitle = Flag (exeName exe), argTargets = inFiles @@ -546,11 +567,6 @@ -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" - -ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -ghcLibDir verbosity lbi = - (reverse . dropWhile isSpace . reverse) `fmap` - rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] --------------------------------------------------------------------------------------------- diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -46,24 +46,26 @@ getInstalledPackages, buildLib, buildExe, - install + install, + registerPackage, ) where import Distribution.Package ( PackageName, PackageIdentifier(..), InstalledPackageId(..) , packageName ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo + ( InstalledPackageInfo, emptyInstalledPackageInfo , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId , sourcePackageId ) - , emptyInstalledPackageInfo, parseInstalledPackageInfo ) + , parseInstalledPackageInfo, showInstalledPackageInfo ) import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), hcOptions, - Executable(..), withExe, Library(..), withLib, libModules ) + ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions + , Executable(..), withExe, Library(..), withLib, libModules ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag + ( CompilerFlavor(..), CompilerId(..) + , Compiler(..), Flag, languageToFlags, extensionsToFlags , PackageDB(..), PackageDBStack ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) @@ -79,18 +81,21 @@ import Distribution.Simple.PreProcess.Unlit ( unlit ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths ( autogenModuleName, autogenModulesDir, dllExtension ) +import Distribution.Simple.Setup + ( CopyDest(..) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, installOrdinaryFiles - , withUTF8FileContents, writeFileAtomic, copyFileVerbose - , findFile, findFileWithExtension, findModuleFiles + , withUTF8FileContents, writeFileAtomic, writeUTF8File + , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles , rawSystemStdInOut , die, info, notice ) import Language.Haskell.Extension - ( Extension(..) ) + ( Language(Haskell98), Extension(..) ) import System.FilePath ( (), takeExtension, (<.>), searchPathSeparator, normalise, takeDirectory ) import Distribution.System @@ -130,6 +135,7 @@ let comp = Compiler { compilerId = CompilerId Hugs version, + compilerLanguages = hugsLanguages, compilerExtensions = hugsLanguageExtensions } return (comp, conf'') @@ -164,6 +170,9 @@ months = [ "January", "February", "March", "April", "May", "June", "July" , "August", "September", "October", "November", "December" ] +hugsLanguages :: [(Language, Flag)] +hugsLanguages = [(Haskell98, "")] --default is 98 mode + -- | The flags for the supported extensions hugsLanguageExtensions :: [(Extension, Flag)] hugsLanguageExtensions = @@ -194,9 +203,9 @@ getInstalledPackages verbosity packagedbs conf = do homedir <- getHomeDirectory (hugsProg, _) <- requireProgram verbosity hugsProgram conf - let bindir = takeDirectory (programPath hugsProg) - libdir = takeDirectory bindir "lib" "hugs" - dbdirs = nub (concatMap (packageDbPaths homedir libdir) packagedbs) + let hugsbindir = takeDirectory (programPath hugsProg) + hugslibdir = takeDirectory hugsbindir "lib" "hugs" + dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs) indexes <- mapM getIndividualDBPackages dbdirs return $! mconcat indexes @@ -312,6 +321,8 @@ where paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) <.> ".hs" + --TODO: switch to using autogenModulesDir as a search dir, rather than + -- always copying the file over. -- |Building an executable for Hugs. buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo @@ -326,7 +337,7 @@ srcMainFile <- findFile (hsSourceDirs bi) mainPath let exeDir = destDir exeName exe let destMainFile = exeDir hugsMainFilename exe - copyModule verbosity (CPP `elem` extensions bi) bi lbi srcMainFile destMainFile + copyModule verbosity (CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile let destPathsFile = exeDir paths_modulename copyFileVerbose verbosity (autogenModulesDir lbi paths_modulename) destPathsFile @@ -345,9 +356,10 @@ -> BuildInfo -> LocalBuildInfo -> IO () +--TODO: should not be using mLibSrcDirs at all compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do -- Pass 1: copy or cpp files from build directory to scratch directory - let useCpp = CPP `elem` extensions bi + let useCpp = CPP `elem` allExtensions bi let srcDir = buildDir lbi srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs info verbosity $ "Source directories: " ++ show srcDirs @@ -534,6 +546,7 @@ -- \\/lib\/hugs\/programs\/\. install :: Verbosity -- ^verbosity + -> LocalBuildInfo -> FilePath -- ^Library install location -> FilePath -- ^Program install location -> FilePath -- ^Executable install location @@ -542,7 +555,8 @@ -> (FilePath,FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> IO () -install verbosity libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do +--FIXME: this script should be generated at build time, just installed at this stage +install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do removeDirectoryRecursive libDir `catchIO` \_ -> return () withLib pkg_descr $ \ lib -> findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib) @@ -551,6 +565,7 @@ when (any (buildable . buildInfo) (executables pkg_descr)) $ createDirectoryIfMissingVerbose verbosity True binDir withExe pkg_descr $ \ exe -> do + let bi = buildInfo exe let theBuildDir = buildProgDir exeName exe let installDir = installProgDir exeName exe let targetDir = targetProgDir exeName exe @@ -560,9 +575,9 @@ : otherModules (buildInfo exe)) >>= installOrdinaryFiles verbosity installDir let targetName = "\"" ++ (targetDir hugsMainFilename exe) ++ "\"" - -- FIX (HUGS): use extensions, and options from file too? - -- see http://hackage.haskell.org/trac/hackage/ticket/43 let hugsOptions = hcOptions Hugs (buildInfo exe) + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (allExtensions bi) let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix let exeFile = case buildOS of Windows -> binDir baseExeFile <.> ".bat" @@ -588,3 +603,24 @@ hugsMainFilename :: Executable -> FilePath hugsMainFilename exe = "Main" <.> ext where ext = takeExtension (modulePath exe) + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + --TODO: prefer to have it based on the packageDbs, but how do we know + -- the package subdir based on the name? the user can set crazy libsubdir + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi + | otherwise = libdir installDirs + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir "package.conf") + (showInstalledPackageInfo installedPkgInfo) diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -65,6 +65,7 @@ import qualified Distribution.Simple.JHC as JHC import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC import Control.Monad (when, unless) import System.Directory @@ -73,6 +74,8 @@ ( takeFileName, takeDirectory, (), isAbsolute ) import Distribution.Verbosity +import Distribution.Text + ( display ) -- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" -- actions. Move files into place based on the prefix argument. FIX: @@ -148,23 +151,28 @@ when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref case compilerFlavor (compiler lbi) of - GHC -> do withLib pkg_descr $ \_ -> - GHC.installLib flags lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ \_ -> - GHC.installExe flags lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - LHC -> do withLib pkg_descr $ \_ -> - LHC.installLib flags lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ \_ -> - LHC.installExe flags lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - JHC -> do withLib pkg_descr $ JHC.installLib verbosity libPref buildPref pkg_descr - withExe pkg_descr $ JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr + GHC -> do withLib pkg_descr $ + GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + LHC -> do withLib pkg_descr $ + LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + JHC -> do withLib pkg_descr $ + JHC.installLib verbosity libPref buildPref pkg_descr + withExe pkg_descr $ + JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr Hugs -> do let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest) let scratchPref = scratchDir lbi - Hugs.install verbosity libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr + Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr NHC -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr) withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) - _ -> die ("only installing with GHC, JHC, Hugs or nhc98 is implemented") + UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + _ -> die $ "installing with " + ++ display (compilerFlavor (compiler lbi)) + ++ " is not implemented" return () -- register step should be performed by caller. diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -236,6 +236,7 @@ Hugs -> "hugs" "packages" "$pkg" JHC -> "$compiler" LHC -> "$compiler" + UHC -> "$pkgid" _other -> "$pkgid" "$compiler", dynlibdir = "$libdir", libexecdir = case buildOS of @@ -315,12 +316,7 @@ _ -> id) . appendSubdirs () . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs { - prefix = case copydest of - -- possibly override the prefix - CopyPrefix p -> toPathTemplate p - _ -> prefix dirs - } + $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId compilerId @@ -329,7 +325,6 @@ data CopyDest = NoCopyDest | CopyTo FilePath - | CopyPrefix FilePath -- DEPRECATED deriving (Eq, Show) -- | Check which of the paths are relative to the installation $prefix. @@ -373,6 +368,7 @@ data PathComponent = Ordinary FilePath | Variable PathTemplateVariable + deriving Eq data PathTemplateVariable = PrefixVar -- ^ The @$prefix@ path variable @@ -390,6 +386,8 @@ | OSVar -- ^ The operating system name, eg @windows@ or @linux@ | ArchVar -- ^ The cpu architecture name, eg @i386@ or @x86_64@ | ExecutableNameVar -- ^ The executable name; used in shell wrappers + | TestSuiteNameVar -- ^ The name of the test suite being run + | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@. deriving Eq type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] @@ -418,7 +416,6 @@ Just (PathTemplate components) -> components Nothing -> [component] - -- | The initial environment has all the static stuff but no paths initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv initialPathTemplateEnv pkgId compilerId = @@ -483,6 +480,8 @@ show OSVar = "os" show ArchVar = "arch" show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" instance Read PathTemplateVariable where readsPrec _ s = @@ -504,7 +503,9 @@ ,("compiler", CompilerVar) ,("os", OSVar) ,("arch", ArchVar) - ,("executablename", ExecutableNameVar)] + ,("executablename", ExecutableNameVar) + ,("test-suite", TestSuiteNameVar) + ,("result", TestSuiteResultVar)] instance Show PathComponent where show (Ordinary path) = path diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs --- a/Distribution/Simple/JHC.hs +++ b/Distribution/Simple/JHC.hs @@ -50,7 +50,7 @@ import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions ) + , Library(..), libModules, hcOptions, usedExtensions ) import Distribution.InstalledPackageInfo ( emptyInstalledPackageInfo, ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -62,8 +62,9 @@ ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , PackageDBStack, Flag, extensionsToFlags ) -import Language.Haskell.Extension (Extension(..)) + , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..)) import Distribution.Simple.Program ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration , userMaybeSpecifyPath, requireProgramVersion, lookupProgram @@ -103,10 +104,14 @@ let Just version = programVersion jhcProg comp = Compiler { compilerId = CompilerId JHC version, + compilerLanguages = jhcLanguages, compilerExtensions = jhcLanguageExtensions } return (comp, conf') +jhcLanguages :: [(Language, Flag)] +jhcLanguages = [(Haskell98, "")] + -- | The flags for the supported extensions jhcLanguageExtensions :: [(Extension, Flag)] jhcLanguageExtensions = @@ -172,8 +177,9 @@ -> FilePath -> Verbosity -> [String] constructJHCCmdLine lbi bi clbi _odir verbosity = (if verbosity >= deafening then ["-v"] else []) - ++ extensionsToFlags (compiler lbi) (extensions bi) ++ hcOptions JHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) ++ ["--noauto","-i-"] ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] ++ ["-i", autogenModulesDir lbi] diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs --- a/Distribution/Simple/LHC.hs +++ b/Distribution/Simple/LHC.hs @@ -64,15 +64,14 @@ configure, getInstalledPackages, buildLib, buildExe, installLib, installExe, + registerPackage, ghcOptions, ghcVerbosityOptions ) where -import Distribution.Simple.Setup - ( CopyFlags(..), fromFlag ) import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..), withExe - , Library(..), libModules, hcOptions ) + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo , parseInstalledPackageInfo ) @@ -87,7 +86,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package - ( PackageIdentifier, Package(..), PackageName(..) ) + ( PackageIdentifier, Package(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg @@ -98,10 +97,11 @@ , arProgram, ranlibProgram, ldProgram , gccProgram, stripProgram , lhcProgram, lhcPkgProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , OptimisationLevel(..), PackageDB(..), PackageDBStack - , Flag, extensionsToFlags ) + , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version ( Version(..), orLaterVersion ) import Distribution.System @@ -109,7 +109,8 @@ import Distribution.Verbosity import Distribution.Text ( display, simpleParse ) -import Language.Haskell.Extension (Extension(..)) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..) ) import Control.Monad ( unless, when ) import Data.List @@ -145,11 +146,13 @@ ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion - languageExtensions <- getLanguageExtensions verbosity lhcProg + languages <- getLanguages verbosity lhcProg + extensions <- getExtensions verbosity lhcProg let comp = Compiler { compilerId = CompilerId LHC lhcVersion, - compilerExtensions = languageExtensions + compilerLanguages = languages, + compilerExtensions = extensions } conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld return (comp, conf''') @@ -216,8 +219,12 @@ then return ["-x"] else return [] -getLanguageExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] -getLanguageExtensions verbosity lhcProg = do +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ _ = return [(Haskell98, "")] +--FIXME: does lhc support -XHaskell98 flag? from what version? + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity lhcProg = do exts <- rawSystemStdout verbosity (programPath lhcProg) ["--supported-languages"] -- GHC has the annoying habit of inverting some of the extensions @@ -237,7 +244,7 @@ pkgss <- getInstalledPackages' verbosity packagedbs conf let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] - return $! hackRtsPackage (mconcat indexes) + return $! (mconcat indexes) where -- On Windows, various fields have $topdir/foo rather than full @@ -247,12 +254,6 @@ compilerDir = takeDirectory (programPath ghcProg) topDir = takeDirectory compilerDir - hackRtsPackage index = - case PackageIndex.lookupPackageName index (PackageName "rts") of - [(_,[rts])] - -> PackageIndex.insert (removeMingwIncludeDir rts) index - _ -> error "No (or multiple) rts package is registered!!" - checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () @@ -260,15 +261,6 @@ die $ "GHC.getInstalledPackages: the global package db must be " ++ "specified first and cannot be specified multiple times" --- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This --- breaks when you want to use a different gcc, so we need to filter --- it out. -removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo -removeMingwIncludeDir pkg = - let ids = InstalledPackageInfo.includeDirs pkg - ids' = filter (not . ("mingw" `isSuffixOf`)) ids - in pkg { InstalledPackageInfo.includeDirs = ids' } - -- | Get the packages from specific PackageDBs, not cumulative. -- getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration @@ -344,7 +336,7 @@ (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` extensions libBi + forceVanillaLib = TemplateHaskell `elem` allExtensions libBi -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir @@ -353,6 +345,7 @@ ["-package-name", display pkgid ] ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity ++ map display (libModules lib) + lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] ghcArgsProf = ghcArgs ++ ["-prof", "-hisuf", "p_hi", @@ -366,9 +359,9 @@ ] ++ ghcSharedOptions libBi unless (null (libModules lib)) $ - do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs) - ifProfLib (runGhcProg ghcArgsProf) - ifSharedLib (runGhcProg ghcArgsShared) + do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) + ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) + ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) -- build any C sources unless (null (cSources libBi)) $ do @@ -527,6 +520,7 @@ srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] let binArgs linkExe profExe = (if linkExe then ["-o", targetDir exeNameReal] @@ -550,8 +544,8 @@ -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi) - (runGhcProg (binArgs False False)) + when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg $ lhcWrap (binArgs False False)) runGhcProg (binArgs True (withProfExe lbi)) @@ -634,7 +628,8 @@ NormalOptimisation -> ["-O"] MaximumOptimisation -> ["-O2"]) ++ hcOptions GHC bi - ++ extensionsToFlags c (extensions bi) + ++ languageToFlags c (defaultLanguage bi) + ++ extensionsToFlags c (usedExtensions bi) where c = compiler lbi ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] @@ -657,7 +652,7 @@ where specific (SpecificPackageDB db) = [ "-package-conf", db ] specific _ = ierror - ierror = error "internal error: unexpected package db stack" + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) @@ -692,26 +687,25 @@ -- Installing -- |Install executables for GHC. -installExe :: CopyFlags -- ^verbosity +installExe :: Verbosity -> LocalBuildInfo -> InstallDirs FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription + -> Executable -> IO () -installExe flags lbi installDirs buildPref (progprefix, progsuffix) pkg_descr - = do let verbosity = fromFlag (copyVerbosity flags) - binDir = bindir installDirs - createDirectoryIfMissingVerbose verbosity True binDir - withExe pkg_descr $ \Executable { exeName = e } -> do - let exeFileName = e <.> exeExtension - fixedExeBaseName = progprefix ++ e ++ progsuffix - installBinary dest = do - installExecutableFile verbosity - (buildPref e exeFileName) - (dest <.> exeExtension) - stripExe verbosity lbi exeFileName (dest <.> exeExtension) - installBinary (binDir fixedExeBaseName) +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $ @@ -731,37 +725,38 @@ _ -> [] -- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: CopyFlags -- ^verbosity +installLib :: Verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic librarys -> FilePath -- ^Build location - -> PackageDescription -> IO () -installLib flags lbi targetDir dynlibTargetDir builtDir - pkg@PackageDescription{library=Just lib} = do - -- copy .hi files over: - let copy src dst n = do - createDirectoryIfMissingVerbose verbosity True dst - installOrdinaryFile verbosity (src n) (dst n) - copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) - >>= installOrdinaryFiles verbosity targetDir - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" - hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) - flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["install", srcBase srcFile] + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copy src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installOrdinaryFile verbosity (src n) (dst n) + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) + flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copy builtDir dynlibTargetDir sharedLibName + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copy builtDir dynlibTargetDir sharedLibName - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi - (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi - (targetDir profileLibName) + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) where vanillaLibName = mkLibName pkgid @@ -778,12 +773,8 @@ ifGHCi = when (hasLib && withGHCiLib lbi) ifShared = when (hasLib && withSharedLib lbi) - verbosity = fromFlag (copyVerbosity flags) runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) -installLib _ _ _ _ _ PackageDescription{library=Nothing} - = die $ "Internal Error. installLibGHC called with no library." - -- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems -- like MacOS X. If we can't find those, don't worry too much about it. -- @@ -797,3 +788,18 @@ "Unable to generate a symbol index for the static " ++ "library '" ++ path ++ "' (missing the 'ranlib' and 'ar' programs)" + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo) diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -47,16 +47,15 @@ module Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), externalPackageDeps, + inplacePackageId, withLibLBI, withExeLBI, + withTestLBI, ComponentLocalBuildInfo(..), -- * Installation directories module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs, - substPathTemplate, - - -- * Deprecated - packageDeps + substPathTemplate ) where @@ -67,7 +66,7 @@ import Distribution.Simple.Program (ProgramConfiguration) import Distribution.PackageDescription ( PackageDescription(..), withLib, Library, withExe - , Executable(exeName) ) + , Executable(exeName), withTest, TestSuite(..) ) import Distribution.Package ( PackageId, Package(..), InstalledPackageId(..) ) import Distribution.Simple.Compiler @@ -76,23 +75,36 @@ ( PackageIndex ) import Distribution.Simple.Utils ( die ) +import Distribution.Simple.Setup + ( ConfigFlags ) +import Distribution.Text + ( display ) import Data.List (nub) --- |Data cached after configuration step. See also --- 'Distribution.Setup.ConfigFlags'. +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. data LocalBuildInfo = LocalBuildInfo { + configFlags :: ConfigFlags, + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + extraConfigArgs :: [String], + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date installDirTemplates :: InstallDirTemplates, -- ^ The installation directories for the various differnt -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath compiler :: Compiler, -- ^ The compiler we're building with buildDir :: FilePath, -- ^ Where to build the package. + --TODO: eliminate hugs's scratchDir, use builddir scratchDir :: FilePath, -- ^ Where to put the result of the Hugs build. libraryConfig :: Maybe ComponentLocalBuildInfo, executableConfigs :: [(String, ComponentLocalBuildInfo)], + testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], installedPkgs :: PackageIndex, -- ^ All the info about all installed packages. pkgDescrFile :: Maybe FilePath, @@ -123,10 +135,6 @@ } deriving (Read, Show) -{-# DEPRECATED packageDeps "use externalPackageDeps or componentPackageDeps" #-} -packageDeps :: LocalBuildInfo -> [PackageId] -packageDeps = map snd . externalPackageDeps - -- | External package dependencies for the package as a whole, the union of the -- individual 'targetPackageDeps'. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] @@ -135,6 +143,12 @@ maybe [] componentPackageDeps (libraryConfig lbi) ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) +-- | The installed package Id we use for local packages registered in the local +-- package db. This is what is used for intra-package deps between components. +-- +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + -- |If the package description has a library section, call the given -- function with the library build info as argument. Extended version of -- 'withLib' that also gives corresponding build info. @@ -158,6 +172,15 @@ ++ exeName exe ++ " but there is no corresponding " ++ "configuration data" +withTestLBI :: PackageDescription -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI pkg_descr lbi f = + let wrapper test = case lookup (testName test) (testSuiteConfigs lbi) of + Just clbi -> f test clbi + Nothing -> die $ "internal error: the package contains a test suite " + ++ testName test ++ " but there is no corresponding " + ++ "configuration data" + in withTest pkg_descr wrapper -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs --- a/Distribution/Simple/NHC.hs +++ b/Distribution/Simple/NHC.hs @@ -60,7 +60,7 @@ , emptyInstalledPackageInfo, parseInstalledPackageInfo ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) - , hcOptions ) + , hcOptions, usedExtensions ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.LocalBuildInfo @@ -68,12 +68,13 @@ import Distribution.Simple.BuildPaths ( mkLibName, objExtension, exeExtension ) import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , Flag, extensionsToFlags, PackageDB(..), PackageDBStack ) + ( CompilerFlavor(..), CompilerId(..), Compiler(..) + , Flag, languageToFlags, extensionsToFlags + , PackageDB(..), PackageDBStack ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Language.Haskell.Extension - ( Extension(..) ) + ( Language(Haskell98), Extension(..) ) import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, programPath , requireProgram, requireProgramVersion, lookupProgram @@ -130,14 +131,17 @@ let comp = Compiler { compilerId = CompilerId NHC nhcVersion, + compilerLanguages = nhcLanguages, compilerExtensions = nhcLanguageExtensions } return (comp, conf'''') +nhcLanguages :: [(Language, Flag)] +nhcLanguages = [(Haskell98, "-98")] + -- | The flags for the supported extensions nhcLanguageExtensions :: [(Extension, Flag)] nhcLanguageExtensions = - -- TODO: use -98 when no extensions are specified. -- NHC doesn't enforce the monomorphism restriction at all. -- TODO: pattern guards in 1.20 [(NoMonomorphismRestriction, "") @@ -273,7 +277,8 @@ let bi = libBuildInfo lib modules = exposedModules lib ++ otherModules bi -- Unsupported extensions have already been checked by configure - extensionFlags = extensionsToFlags (compiler lbi) (extensions bi) + languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) inFiles <- getModulePaths lbi bi modules let targetDir = buildDir lbi srcDirs = nub (map takeDirectory inFiles) @@ -283,9 +288,9 @@ ["-hc=" ++ programPath nhcProg] ++ nhcVerbosityOptions verbosity ++ ["-d", targetDir, "-hidir", targetDir] - ++ extensionFlags ++ maybe [] (hcOptions NHC . libBuildInfo) (library pkg_descr) + ++ languageFlags ++ concat [ ["-package", display (packageName pkgid) ] | (_, pkgid) <- componentPackageDeps clbi ] ++ inFiles @@ -337,7 +342,8 @@ let bi = buildInfo exe modules = otherModules bi -- Unsupported extensions have already been checked by configure - extensionFlags = extensionsToFlags (compiler lbi) (extensions bi) + languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) inFiles <- getModulePaths lbi bi modules let targetDir = buildDir lbi exeName exe exeDir = targetDir (exeName exe ++ "-tmp") @@ -348,9 +354,9 @@ ["-hc=" ++ programPath nhcProg] ++ nhcVerbosityOptions verbosity ++ ["-d", targetDir, "-hidir", targetDir] - ++ extensionFlags ++ maybe [] (hcOptions NHC . libBuildInfo) (library pkg_descr) + ++ languageFlags ++ concat [ ["-package", display (packageName pkgid) ] | (_, pkgid) <- componentPackageDeps clbi ] ++ inFiles diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs --- a/Distribution/Simple/PackageIndex.hs +++ b/Distribution/Simple/PackageIndex.hs @@ -430,9 +430,9 @@ , not (null missing) ] --- | Tries to take the transative closure of the package dependencies. +-- | Tries to take the transitive closure of the package dependencies. -- --- If the transative closure is complete then it returns that subset of the +-- If the transitive closure is complete then it returns that subset of the -- index. Otherwise it returns the broken packages as in 'brokenPackages'. -- -- * Note that if the result is @Right []@ it is because at least one of @@ -455,7 +455,7 @@ where completed' = insert pkg completed pkgids' = IPI.depends pkg ++ pkgids --- | Takes the transative closure of the packages reverse dependencies. +-- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. -- diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -62,7 +62,9 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..), withExe - , Library(..), withLib, libModules ) + , Library(..), withLib, libModules + , TestSuite(..), withTest, testModules + , TestSuiteInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex @@ -75,13 +77,17 @@ , die, setupMessage, intercalate, copyFileVerbose , findFileWithExtension, findFileWithExtension' ) import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), lookupProgram, programPath + ( Program(..), ConfiguredProgram(..), programPath + , lookupProgram, requireProgram, requireProgramVersion , rawSystemProgramConf, rawSystemProgram , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) +import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System ( OS(OSX, Windows), buildOS ) -import Distribution.Version (Version(..)) +import Distribution.Text +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity import Control.Monad (when, unless) @@ -196,12 +202,40 @@ preprocessFile (hsSourceDirs bi) exeDir forSDist (dropExtensions (modulePath theExe)) verbosity builtinSuffixes biHandlers + unless (null (testSuites pkg_descr)) $ + setupMessage verbosity "Preprocessing test suites for" (packageId pkg_descr) + withTest pkg_descr $ \test -> case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi testName test + testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt where hc = compilerFlavor (compiler lbi) builtinSuffixes | hc == NHC = ["hs", "lhs", "gc"] | otherwise = ["hs", "lhs"] localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + preProcessTest test exePath testDir = do + let bi = testBuildInfo test + biHandlers = localHandlers bi + sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] + sequence_ [ preprocessFile sourceDirs (buildDir lbi) forSDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers + | modu <- testModules test ] + preprocessFile (testDir : (hsSourceDirs bi)) testDir forSDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers +--TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + -- |Find the first extension of the file that exists, and preprocess it -- if required. preprocessFile @@ -219,8 +253,14 @@ psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile case psrcFiles of -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc baseFile + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile case bsrcFiles of Nothing -> die $ "can't find source for " ++ baseFile ++ " in " ++ intercalate ", " searchLoc @@ -253,14 +293,37 @@ when recomp $ do let destDir = buildLoc dirName srcStem createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessor pp + runPreProcessorWithHsBootHack pp (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") verbosity + (buildLoc, srcStem <.> "hs") - where dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x + where + dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + -- ------------------------------------------------------------ -- * known preprocessors -- ------------------------------------------------------------ @@ -294,17 +357,15 @@ GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi _ -> ppCpphs (cppArgs ++ extraArgs) bi lbi - where cppArgs = sysDefines ++ cppOptions bi ++ getCppOptions bi lbi - sysDefines = - ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] ++ - ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] - locations = ["BUILD", "HOST"] + where cppArgs = getCppOptions bi lbi ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppGhcCpp extraArgs _bi lbi = PreProcessor { platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity + ghcProgram anyVersion (withPrograms lbi) rawSystemProgram verbosity ghcProg $ ["-E", "-cpp"] -- This is a bit of an ugly hack. We're going to @@ -318,14 +379,14 @@ ++ ["-o", outFile, inFile] ++ extraArgs } - where Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) - Just ghcVersion = programVersion ghcProg ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppCpphs extraArgs _bi lbi = PreProcessor { platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity + cpphsProgram anyVersion (withPrograms lbi) rawSystemProgram verbosity cpphsProg $ ("-O" ++ outFile) : inFile : "--noline" : "--strip" @@ -334,8 +395,6 @@ else []) ++ extraArgs } - where Just cpphsProg = lookupProgram cpphsProgram (withPrograms lbi) - Just cpphsVersion = programVersion cpphsProg -- Haddock versions before 0.8 choke on #line and #file pragmas. Those -- pragmas are necessary for correct links when we preprocess. So use @@ -348,55 +407,65 @@ _ -> True ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi = standardPP lbi hsc2hsProgram $ - [ "--cc=" ++ programPath gccProg - , "--ld=" ++ programPath gccProg ] +ppHsc2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg ] - -- Additional gcc options - ++ [ "--cflag=" ++ opt | opt <- programArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programArgs gccProg ] + -- Additional gcc options + ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] ] + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. - -- Options from the current package: - ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] - ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi - ++ PD.cppOptions bi ] - ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-Wl,-R," ++ opt | isELF - , opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] - ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] + ++ [ "--cflag=" ++ opt | opt <- sysDefines ] - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] - ++ [ "-Wl,-R," ++ opt | isELF - , opt <- Installed.libraryDirs pkg ] - ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] + -- Options from the current package: + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi ] + ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-Wl,-R," ++ opt | isELF + , opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] + ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-Wl,-R," ++ opt | isELF + , opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + ++ ["-o", outFile, inFile] + } where pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) - Just gccProg = lookupProgram gccProgram (withPrograms lbi) isOSX = case buildOS of OSX -> True; _ -> False isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; packageHacks = case compilerFlavor (compiler lbi) of @@ -414,25 +483,55 @@ ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppC2hs bi lbi - = PreProcessor { - platformIndependent = False, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> - rawSystemProgramConf verbosity c2hsProgram (withPrograms lbi) $ - ["--include=" ++ outBaseDir] - ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] - ++ ["--output-dir=" ++ outBaseDir, - "--output=" ++ outRelativeFile, - inBaseDir inRelativeFile] - } +ppC2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> do + (c2hsProg, _, _) <- requireProgramVersion verbosity + c2hsProgram (orLaterVersion (Version [0,15] [])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgram verbosity c2hsProg $ + -- Options from the current package: + [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] + ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--include=" ++ outBaseDir ] + + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg + , c `elem` "DIU" ] ] + --TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +--TODO: perhaps use this with hsc2hs too +--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi = hcDefines (compiler lbi) + ++ sysDefines + ++ cppOptions bi ++ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] +sysDefines :: [String] +sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] + ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] + where + locations = ["BUILD", "HOST"] + hcDefines :: Compiler -> [String] hcDefines comp = case compilerFlavor comp of @@ -478,21 +577,8 @@ PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - do rawSystemProgramConf verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - -- XXX This is a nasty hack. GHC requires that hs-boot files - -- be in the same place as the hs files, so if we put the hs - -- file in dist/... then we need to copy the hs-boot file - -- there too. This should probably be done another way, e.g. - -- by preprocessing all files, with and "id" preprocessor if - -- nothing else, so the hs-boot files automatically get copied - -- into the right place. - -- Possibly we should also be looking for .lhs-boot files, but - -- I think that preprocessors only produce .hs files. - let inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot + rawSystemProgramConf verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) } -- |Convenience function; get the suffixes of these preprocessors. diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -93,6 +93,7 @@ , jhcProgram , hugsProgram , ffihugsProgram + , uhcProgram , gccProgram , ranlibProgram , arProgram diff --git a/Distribution/Simple/Program/Ar.hs b/Distribution/Simple/Program/Ar.hs --- a/Distribution/Simple/Program/Ar.hs +++ b/Distribution/Simple/Program/Ar.hs @@ -43,7 +43,9 @@ -- When we need to call ar multiple times we use "ar q" and for the last -- call on OSX we use "ar qs" so that it'll make the index. - let simpleArgs = ["-r"] + let simpleArgs = case buildOS of + OSX -> ["-r", "-s"] + _ -> ["-r"] initialArgs = ["-q"] finalArgs = case buildOS of diff --git a/Distribution/Simple/Program/Builtin.hs b/Distribution/Simple/Program/Builtin.hs --- a/Distribution/Simple/Program/Builtin.hs +++ b/Distribution/Simple/Program/Builtin.hs @@ -25,6 +25,7 @@ jhcProgram, hugsProgram, ffihugsProgram, + uhcProgram, gccProgram, ranlibProgram, arProgram, @@ -67,6 +68,7 @@ , jhcProgram , lhcProgram , lhcPkgProgram + , uhcProgram -- preprocessors , hscolourProgram , haddockProgram @@ -146,6 +148,11 @@ case words str of (_:ver:_) -> ver _ -> "" + } + +uhcProgram :: Program +uhcProgram = (simpleProgram "uhc") { + programFindVersion = findProgramVersion "--version-dotted" id } diff --git a/Distribution/Simple/Program/Db.hs b/Distribution/Simple/Program/Db.hs --- a/Distribution/Simple/Program/Db.hs +++ b/Distribution/Simple/Program/Db.hs @@ -197,7 +197,8 @@ \(prog, path, args) -> Just (prog, path, args ++ args')) . updateConfiguredProgs (flip Map.update name $ - \prog -> Just prog { programArgs = programArgs prog ++ args' }) + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) -- | Like 'userSpecifyPath' but for a list of progs and their paths. @@ -285,15 +286,16 @@ Nothing -> return conf Just location -> do version <- programFindVersion prog verbosity (locationPath location) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programArgs = userSpecifiedArgs prog conf, - programLocation = location + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog conf, + programLocation = location } extraArgs <- programPostConf prog verbosity configuredProg - let configuredProg' = configuredProg { - programArgs = extraArgs ++ programArgs configuredProg + let configuredProg' = configuredProg { + programDefaultArgs = extraArgs } return (updateConfiguredProgs (Map.insert name configuredProg') conf) diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs --- a/Distribution/Simple/Program/HcPkg.hs +++ b/Distribution/Simple/Program/HcPkg.hs @@ -34,7 +34,7 @@ import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Simple.Compiler - ( PackageDB(..) ) + ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types ( ConfiguredProgram(programId, programVersion) ) import Distribution.Simple.Program.Run @@ -58,7 +58,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] -- -register :: Verbosity -> ConfiguredProgram -> PackageDB +register :: Verbosity -> ConfiguredProgram -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () @@ -71,7 +71,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] -- -reregister :: Verbosity -> ConfiguredProgram -> PackageDB +reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () @@ -164,7 +164,7 @@ -- registerInvocation, reregisterInvocation - :: ConfiguredProgram -> Verbosity -> PackageDB + :: ConfiguredProgram -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation registerInvocation = registerInvocation' "register" @@ -172,22 +172,28 @@ registerInvocation' :: String - -> ConfiguredProgram -> Verbosity -> PackageDB + -> ConfiguredProgram -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation -registerInvocation' cmdname hcPkg verbosity packagedb (Left pkgFile) = +registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = programInvocation hcPkg args where - args = [cmdname, pkgFile, packageDbOpts packagedb] + args = [cmdname, pkgFile] + ++ (if legacyVersion hcPkg + then [packageDbOpts (last packagedbs)] + else packageDbStackOpts packagedbs) ++ verbosityOpts hcPkg verbosity -registerInvocation' cmdname hcPkg verbosity packagedb (Right pkgInfo) = +registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = (programInvocation hcPkg args) { progInvokeInput = Just (showInstalledPackageInfo pkgInfo), progInvokeInputEncoding = IOEncodingUTF8 } where - args = [cmdname, "-", packageDbOpts packagedb] + args = [cmdname, "-"] + ++ (if legacyVersion hcPkg + then [packageDbOpts (last packagedbs)] + else packageDbStackOpts packagedbs) ++ verbosityOpts hcPkg verbosity @@ -227,6 +233,21 @@ ++ verbosityOpts hcPkg verbosity +packageDbStackOpts :: PackageDBStack -> [String] +packageDbStackOpts dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : "--no-user-package-conf" + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--package-conf=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + packageDbOpts :: PackageDB -> String packageDbOpts GlobalPackageDB = "--global" packageDbOpts UserPackageDB = "--user" @@ -243,3 +264,8 @@ | v >= deafening = ["-v2"] | v == silent = ["-v0"] | otherwise = [] + +-- Handle quirks in ghc-pkg 6.8 and older +legacyVersion :: ConfiguredProgram -> Bool +legacyVersion hcPkg = programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,9] []) diff --git a/Distribution/Simple/Program/Run.hs b/Distribution/Simple/Program/Run.hs --- a/Distribution/Simple/Program/Run.hs +++ b/Distribution/Simple/Program/Run.hs @@ -77,10 +77,12 @@ } programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation -programInvocation prog extraArgs = +programInvocation prog args = emptyProgramInvocation { progInvokePath = programPath prog, - progInvokeArgs = programArgs prog ++ extraArgs + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog } diff --git a/Distribution/Simple/Program/Script.hs b/Distribution/Simple/Program/Script.hs --- a/Distribution/Simple/Program/Script.hs +++ b/Distribution/Simple/Program/Script.hs @@ -50,7 +50,7 @@ ++ [ (case minput of Nothing -> "" Just input -> "echo " ++ quote input ++ " | ") - ++ quote path ++ concatMap (\arg -> ' ':quote arg) args ] + ++ unwords (map quote $ path : args) ++ " \"$@\""] where quote :: String -> String diff --git a/Distribution/Simple/Program/Types.hs b/Distribution/Simple/Program/Types.hs --- a/Distribution/Simple/Program/Types.hs +++ b/Distribution/Simple/Program/Types.hs @@ -65,7 +65,12 @@ -- | Default command-line args for this program. -- These flags will appear first on the command line, so they can be -- overridden by subsequent flags. - programArgs :: [String], + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ programLocation :: ProgramLocation diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -68,21 +68,19 @@ ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName) -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC import Distribution.Simple.Compiler ( compilerVersion, CompilerFlavor(..), compilerFlavor - , PackageDB(..), PackageDBStack, registrationPackageDB ) + , PackageDBStack, registrationPackageDB ) import Distribution.Simple.Program - ( ConfiguredProgram + ( ConfiguredProgram, runProgramInvocation , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) import Distribution.Simple.Program.Script ( invocationAsSystemScript ) import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Program.Run - ( ProgramInvocation(..), IOEncoding(..), programInvocation - , runProgramInvocation ) -import Distribution.Simple.Program.Types - ( ConfiguredProgram(programId, programVersion) ) import Distribution.Simple.Setup ( RegisterFlags(..), CopyDest(..) , fromFlag, fromFlagOrDefault, flagToMaybe ) @@ -95,7 +93,7 @@ , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeUTF8File, writeFileAtomic + ( writeUTF8File, writeFileAtomic , die, notice, setupMessage ) import Distribution.System ( OS(..), buildOS ) @@ -103,7 +101,7 @@ ( display ) import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal, deafening, silent ) + ( Verbosity, normal ) import Distribution.Compat.CopyFile ( setFileExecutable ) @@ -112,10 +110,10 @@ ( getCurrentDirectory, removeDirectoryRecursive ) import System.IO.Error (try) -import Control.Monad (when) import Data.Maybe ( isJust, fromMaybe, maybeToList ) -import Data.List (partition, nub) +import Data.List + ( partition, nub ) -- ----------------------------------------------------------------------------- @@ -135,7 +133,7 @@ case () of _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> writeRegisterScript installedPkgInfo - | otherwise -> registerPackage' verbosity + | otherwise -> registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs where @@ -167,6 +165,7 @@ Hugs -> notice verbosity "Registration scripts not needed for hugs" JHC -> notice verbosity "Registration scripts not needed for jhc" NHC -> notice verbosity "Registration scripts not needed for nhc98" + UHC -> notice verbosity "Registration scripts not needed for uhc" _ -> die "Registration scripts are not implemented for this compiler" register _ _ regFlags = notice verbosity "No package to register" @@ -211,66 +210,28 @@ -> PackageDescription -> LocalBuildInfo -> Bool - -> PackageDB - -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace packageDb = - registerPackage' verbosity installedPkgInfo pkg lbi inplace packageDbs - where - packageDbs - | registrationPackageDB (withPackageDB lbi) == packageDb - = withPackageDB lbi - | otherwise = withPackageDB lbi ++ [packageDb] - -registerPackage' :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool -> PackageDBStack -> IO () -registerPackage' verbosity installedPkgInfo pkg lbi inplace packageDbs = do +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do setupMessage verbosity "Registering" (packageId pkg) case compilerFlavor (compiler lbi) of - GHC -> registerPackageGHC verbosity installedPkgInfo pkg lbi inplace packageDbs - LHC -> registerPackageLHC verbosity installedPkgInfo pkg lbi inplace packageDbs - Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDbs + GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs JHC -> notice verbosity "Registering for jhc (nothing to do)" NHC -> notice verbosity "Registering for nhc98 (nothing to do)" _ -> die "Registering is not implemented for this compiler" -registerPackageGHC, registerPackageLHC, registerPackageHugs - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do - let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) - reregister verbosity ghcPkg packageDbs installedPkgInfo - -registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do - let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) - reregister verbosity lhcPkg packageDbs installedPkgInfo - -registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDbs = do - when inplace $ die "--inplace is not supported with Hugs" - let installDirs = absoluteInstallDirs pkg lbi NoCopyDest - createDirectoryIfMissingVerbose verbosity True (libdir installDirs) - writeUTF8File (libdir installDirs "package.conf") - (showInstalledPackageInfo installedPkgInfo) - - writeHcPkgRegisterScript :: Verbosity -> InstalledPackageInfo -> ConfiguredProgram -> PackageDBStack -> IO () writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do - let invocation = reregisterInvocation hcPkg Verbosity.normal - packageDbs installedPkgInfo + let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal + packageDbs (Right installedPkgInfo) regScript = invocationAsSystemScript buildOS invocation notice verbosity ("Creating package registration script: " ++ regScriptFileName) @@ -426,48 +387,3 @@ unregScriptFileName = case buildOS of Windows -> "unregister.bat" _ -> "unregister.sh" - -reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack - -> InstalledPackageInfo - -> IO () -reregister verbosity hcPkg packagedb pkgFile = - runProgramInvocation verbosity - (reregisterInvocation hcPkg verbosity packagedb pkgFile) - -reregisterInvocation :: ConfiguredProgram -> Verbosity -> PackageDBStack - -> InstalledPackageInfo - -> ProgramInvocation -reregisterInvocation hcPkg verbosity packagedbs pkgInfo = - (programInvocation hcPkg args) { - progInvokeInput = Just (showInstalledPackageInfo pkgInfo), - progInvokeInputEncoding = IOEncodingUTF8 - } - where - args = ["update", "-"] ++ packageDbStackOpts packagedbs - ++ verbosityOpts verbosity - - verbosityOpts :: Verbosity -> [String] - verbosityOpts v - - -- ghc-pkg < 6.11 does not support -v - | programId hcPkg == "ghc-pkg" - && programVersion hcPkg < Just (Version [6,11] []) - = [] - - | v >= deafening = ["-v2"] - | v == silent = ["-v0"] - | otherwise = [] - - packageDbStackOpts :: PackageDBStack -> [String] - packageDbStackOpts dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : "--no-user-package-conf" - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--package-conf=" ++ db - specific _ = ierror - ierror = error "internal error: unexpected package db stack" diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -71,6 +71,7 @@ unregisterCommand, SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, + TestShowDetails(..), CopyDest(..), configureArgs, configureOptions, installDirsOptions, @@ -87,7 +88,10 @@ import Distribution.Compiler () import Distribution.ReadE -import Distribution.Text (display, Text(parse)) +import Distribution.Text + ( Text(..), display ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp import Distribution.Package ( Dependency(..) ) import Distribution.PackageDescription ( FlagName(..), FlagAssignment ) @@ -97,7 +101,7 @@ ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) , OptimisationLevel(..), flagToOptimisationLevel ) import Distribution.Simple.Utils - ( wrapLine, lowercase ) + ( wrapLine, lowercase, intercalate ) import Distribution.Simple.Program (Program(..), ProgramConfiguration, knownPrograms, addKnownProgram, emptyProgramConfiguration, @@ -105,12 +109,13 @@ import Distribution.Simple.InstallDirs ( InstallDirs(..), CopyDest(..), PathTemplate, toPathTemplate, fromPathTemplate ) -import Data.List (sort) -import Data.Char (isSpace) -import Data.Monoid (Monoid(..)) import Distribution.Verbosity --- XXX Not sure where this should live +import Data.List ( sort ) +import Data.Char ( isSpace, isAlpha ) +import Data.Monoid ( Monoid(..) ) + +-- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist" @@ -135,7 +140,7 @@ -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. -- -data Flag a = Flag a | NoFlag deriving (Show, Eq) +data Flag a = Flag a | NoFlag deriving (Show, Read, Eq) instance Functor Flag where fmap f (Flag x) = Flag (f x) @@ -282,9 +287,10 @@ configStripExes :: Flag Bool, -- ^Enable executable stripping configConstraints :: [Dependency], -- ^Additional constraints for -- dependencies - configConfigurationsFlags :: FlagAssignment + configConfigurationsFlags :: FlagAssignment, + configTests :: Flag Bool -- ^Enable test suite compilation } - deriving Show + deriving (Read,Show) defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags { @@ -302,7 +308,8 @@ configUserInstall = Flag False, --TODO: reverse this configGHCiLib = Flag True, configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = Flag True + configStripExes = Flag True, + configTests = Flag False } configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags @@ -333,7 +340,8 @@ , (Flag NHC, ([] , ["nhc98"]), "compile with NHC") , (Flag JHC, ([] , ["jhc"]), "compile with JHC") , (Flag LHC, ([] , ["lhc"]), "compile with LHC") - , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")]) + , (Flag Hugs,([] , ["hugs"]), "compile with Hugs") + , (Flag UHC, ([] , ["uhc"]), "compile with UHC")]) ,option "w" ["with-compiler"] "give the path to a particular compiler" @@ -350,6 +358,7 @@ "directory to receive the built package (hugs-only)" configScratchDir (\v flags -> flags { configScratchDir = v }) (reqArgFlag "DIR") + --TODO: eliminate scratchdir flag ,option "" ["program-prefix"] "prefix to be applied to installed executables" @@ -389,14 +398,10 @@ Flag NormalOptimisation -> [Nothing] Flag MaximumOptimisation -> [Just "2"] _ -> []) - "O" ("enable-optimization": case showOrParseArgs of - -- Allow British English spelling: - ShowArgs -> []; ParseArgs -> ["enable-optimisation"]) + "O" ["enable-optimization","enable-optimisation"] "Build with optimization (n is 0--2, default is 1)", noArg (Flag NoOptimisation) [] - ("disable-optimization": case showOrParseArgs of - -- Allow British English spelling: - ShowArgs -> []; ParseArgs -> ["disable-optimisation"]) + ["disable-optimization","disable-optimisation"] "Build without optimization" ] @@ -453,6 +458,10 @@ (reqArg "DEPENDENCY" (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) (map (\x -> display x))) + ,option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests (\v flags -> flags { configTests = v }) + (boolOpt [] []) ] where readFlagList :: String -> FlagAssignment @@ -559,7 +568,8 @@ configExtraLibDirs = mempty, configConstraints = mempty, configExtraIncludeDirs = mempty, - configConfigurationsFlags = mempty + configConfigurationsFlags = mempty, + configTests = mempty } mappend a b = ConfigFlags { configPrograms = configPrograms b, @@ -588,7 +598,8 @@ configExtraLibDirs = combine configExtraLibDirs, configConstraints = combine configConstraints, configExtraIncludeDirs = combine configExtraIncludeDirs, - configConfigurationsFlags = combine configConfigurationsFlags + configConfigurationsFlags = combine configConfigurationsFlags, + configTests = combine configTests } where combine field = field a `mappend` field b @@ -631,13 +642,6 @@ copyDest (\v flags -> flags { copyDest = v }) (reqArg "DIR" (succeedReadE (Flag . CopyTo)) (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["copy-prefix"] - "[DEPRECATED, directory to copy files to instead of prefix]" - copyDest (\v flags -> flags { copyDest = v }) - (reqArg' "DIR" (Flag . CopyPrefix) - (\f -> case f of Flag (CopyPrefix p) -> [p]; _ -> [])) - ] emptyCopyFlags :: CopyFlags @@ -1025,7 +1029,7 @@ haddockCss (\v flags -> flags { haddockCss = v }) (reqArgFlag "PATH") - ,option "" ["hyperlink-source"] + ,option "" ["hyperlink-source","hyperlink-sources"] "Hyperlink the documentation to the source code (using HsColour)" haddockHscolour (\v flags -> flags { haddockHscolour = v }) trueArg @@ -1191,16 +1195,49 @@ -- * Test flags -- ------------------------------------------------------------ +data TestShowDetails = Never | Failures | Always + deriving (Eq, Ord, Enum, Bounded, Show) + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound..maxBound] + +instance Text TestShowDetails where + disp = Disp.text . lowercase . show + + parse = maybe Parse.pfail return . classify =<< ident + where + ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] + +--TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend a b = if a < b then b else a + data TestFlags = TestFlags { testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity + testVerbosity :: Flag Verbosity, + testHumanLog :: Flag PathTemplate, + testMachineLog :: Flag PathTemplate, + testShowDetails :: Flag TestShowDetails, + --TODO: eliminate the test list and pass it directly as positional args to the testHook + testList :: Flag [String], + -- TODO: think about if/how options are passed to test exes + testOptions :: Flag [String] } - deriving Show defaultTestFlags :: TestFlags defaultTestFlags = TestFlags { testDistPref = Flag defaultDistPref, - testVerbosity = Flag normal + testVerbosity = Flag normal, + testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", + testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", + testShowDetails = toFlag Failures, + testList = Flag [], + testOptions = Flag [] } testCommand :: CommandUI TestFlags @@ -1210,10 +1247,44 @@ shortDesc = "Run the test suite, if any (configure with UserHooks)." longDesc = Nothing options showOrParseArgs = - [optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - ,optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs + [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + , optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs + , option [] ["log"] + ("Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") + testHumanLog (\v flags -> flags { testHumanLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["machine-log"] + ("Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)") + testMachineLog (\v flags -> flags { testMachineLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["show-details"] + ("'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases.") + testShowDetails (\v flags -> flags { testShowDetails = v }) + (reqArg "FILTER" + (readP_to_E (\_ -> "--show-details flag expects one of " + ++ intercalate ", " + (map display knownTestShowDetails)) + (fmap toFlag parse)) + (flagToList . fmap display)) + , option [] ["test-options"] + "give extra options to test executables" + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "OPTS" (toFlag . splitArgs) (fromFlagOrDefault [])) + , option [] ["test-option"] + ("give extra option to test executables " + ++ "(no need to quote options containing spaces)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "OPT" (\x -> toFlag [x]) (fromFlagOrDefault [])) ] emptyTestFlags :: TestFlags @@ -1222,11 +1293,21 @@ instance Monoid TestFlags where mempty = TestFlags { testDistPref = mempty, - testVerbosity = mempty + testVerbosity = mempty, + testHumanLog = mempty, + testMachineLog = mempty, + testShowDetails = mempty, + testList = mempty, + testOptions = mempty } mappend a b = TestFlags { testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testList = combine testList, + testOptions = combine testOptions } where combine field = field a `mappend` field b diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -127,7 +127,7 @@ | otherwise = pkg setupMessage verbosity "Building source dist for" (packageId pkg') - -- XXX This looks a bit suspicious. Should createArchive be passed + -- FIXME This looks a bit suspicious. Should createArchive be passed -- the result of prepareSnapshotTree/prepareTree? _ <- if snapshot then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Test.hs @@ -0,0 +1,435 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/setup test@\" action. It runs test suites designated in the package +-- description and reports on the results. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Test + ( test + , runTests + , writeSimpleTestStub + , stubFilePath + , stubName + , PackageLog(..) + , TestSuiteLog(..) + , Case(..) + , suitePassed, suiteFailed, suiteError + ) where + +import Distribution.Compat.TempFile ( openTempFile ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Package + ( PackageId ) +import qualified Distribution.PackageDescription as PD + ( PackageDescription(..), TestSuite(..) + , TestSuiteInterface(..), testType ) +import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Compiler ( Compiler(..), CompilerId ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) +import Distribution.Simple.Utils ( die, notice ) +import qualified Distribution.TestSuite as TestSuite + ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) ) +import Distribution.Text +import Distribution.Verbosity ( normal, Verbosity ) +import Distribution.System ( buildPlatform, Platform ) + +import Control.Exception ( bracket ) +import Control.Monad ( when, liftM, unless ) +import Data.Char ( toUpper ) +import Data.Monoid ( mempty ) +import System.Directory + ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory + , removeFile ) +import System.Environment ( getEnvironment ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hClose, IOMode(..), openFile ) +import System.Process ( runProcess, waitForProcess ) + +-- | Logs all test results for a package, broken down first by test suite and +-- then by test case. +data PackageLog = PackageLog + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) + +-- | A 'PackageLog' with package and platform information specified. +localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog +localPackageLog pkg_descr lbi = PackageLog + { package = PD.package pkg_descr + , compiler = compilerId $ LBI.compiler lbi + , platform = buildPlatform + , testSuites = [] + } + +-- | Logs test suite results, itemized by test case. +data TestSuiteLog = TestSuiteLog + { name :: String + , cases :: [Case] + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) + +data Case = Case + { caseName :: String + , caseOptions :: TestSuite.Options + , caseResult :: TestSuite.Result + } + deriving (Read, Show, Eq) + +getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options +getTestOptions t l = + case filter ((== TestSuite.name t) . caseName) (cases l) of + (x:_) -> return $ caseOptions x + _ -> TestSuite.defaultOptions t + +-- | From a 'TestSuiteLog', determine if the test suite passed. +suitePassed :: TestSuiteLog -> Bool +suitePassed = all (== TestSuite.Pass) . map caseResult . cases + +-- | From a 'TestSuiteLog', determine if the test suite failed. +suiteFailed :: TestSuiteLog -> Bool +suiteFailed = any isFail . map caseResult . cases + where isFail (TestSuite.Fail _) = True + isFail _ = False + +-- | From a 'TestSuiteLog', determine if the test suite encountered errors. +suiteError :: TestSuiteLog -> Bool +suiteError = any isError . map caseResult . cases + where isError (TestSuite.Error _) = True + isError _ = False + +-- | Run a test executable, logging the output and generating the appropriate +-- summary messages. +testController :: TestFlags + -- ^ flags Cabal was invoked with + -> PD.PackageDescription + -- ^ description of package the test suite belongs to + -> PD.TestSuite + -- ^ TestSuite being tested + -> (FilePath -> String) + -- ^ prepare standard input for test executable + -> FilePath -- ^ executable name + -> (ExitCode -> String -> TestSuiteLog) + -- ^ generator for the TestSuiteLog + -> (TestSuiteLog -> FilePath) + -- ^ generator for final human-readable log filename + -> IO TestSuiteLog +testController flags pkg_descr suite preTest cmd postTest logNamer = do + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + testLogDir = distPref "test" + options = fromFlag $ testOptions flags + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + let dataDirPath = pwd PD.dataDir pkg_descr + shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + + bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> + bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ PD.testName suite + appendFile tempLog $ summarizeSuiteStart $ PD.testName suite + + -- Prepare standard input for test executable + appendFile tempInput $ preTest tempInput + + -- Run test executable + exit <- do + hLog <- openFile tempLog AppendMode + hIn <- openFile tempInput ReadMode + -- these handles get closed by runProcess + proc <- runProcess cmd options Nothing shellEnv + (Just hIn) (Just hLog) (Just hLog) + waitForProcess proc + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- readFile tempInput >>= return . postTest exit + + -- Generate final log file name + let finalLogName = testLogDir logNamer suiteLog + suiteLog' = suiteLog { logFile = finalLogName } + + -- Write summary notice to log file indicating end of test suite + appendFile tempLog $ summarizeSuiteFinish suiteLog' + + -- Append contents of temporary log file to the final human- + -- readable log file + readFile tempLog >>= appendFile (logFile suiteLog') + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = when $ (details > Never) + && (not (suitePassed suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ readFile (logFile suiteLog') >>= + putStr . unlines . map (">>> " ++) . lines + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog' + + return suiteLog' + where + deleteIfExists file = do + exists <- doesFileExist file + when exists $ removeFile file + + openCabalTemp testLogDir = do + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f + + +-- |Perform the \"@.\/setup test@\" action. +test :: PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> TestFlags -- ^flags sent to test + -> IO () +test pkg_descr lbi flags = do + let verbosity = fromFlag $ testVerbosity flags + humanTemplate = fromFlag $ testHumanLog flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = fromFlag $ testList flags + pkgTests = PD.testSuites pkg_descr + + doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog + doTest (suite, mLog) = do + let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi + go pre cmd post = testController flags pkg_descr suite + pre cmd post testLogPath + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> do + let cmd = LBI.buildDir lbi PD.testName suite + PD.testName suite <.> exeExtension + preTest _ = "" + postTest exit _ = + let r = case exit of + ExitSuccess -> TestSuite.Pass + ExitFailure c -> TestSuite.Fail + $ "exit code: " ++ show c + in TestSuiteLog + { name = PD.testName suite + , cases = [Case (PD.testName suite) mempty r] + , logFile = "" + } + go preTest cmd postTest + + PD.TestSuiteLibV09 _ _ -> do + let cmd = LBI.buildDir lbi stubName suite + stubName suite <.> exeExtension + oldLog = case mLog of + Nothing -> TestSuiteLog + { name = PD.testName suite + , cases = [] + , logFile = [] + } + Just l -> l + preTest f = show $ oldLog { logFile = f } + postTest _ = read + go preTest cmd postTest + + _ -> return TestSuiteLog + { name = PD.testName suite + , cases = [Case (PD.testName suite) mempty + $ TestSuite.Error $ "No support for running " + ++ "test suite type: " + ++ show (disp $ PD.testType suite)] + , logFile = "" + } + + testsToRun <- case testNames of + [] -> return $ zip pkgTests $ repeat Nothing + names -> flip mapM names $ \tName -> + let testMap = map (\x -> (PD.testName x, x)) pkgTests + in case lookup tName testMap of + Just t -> return (t, Nothing) + _ -> die $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- mapM doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } + packageLogFile = () testLogDir + $ packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + unless allOk exitFailure + +-- | Print a summary to the console after all test suites have been run +-- indicating the number of successful test suites and cases. Returns 'True' if +-- all test suites passed and 'False' otherwise. +summarizePackage :: Verbosity -> PackageLog -> IO Bool +summarizePackage verbosity packageLog = do + let cases' = map caseResult $ concatMap cases $ testSuites packageLog + passedCases = length $ filter (== TestSuite.Pass) cases' + totalCases = length cases' + passedSuites = length $ filter suitePassed $ testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ show passedSuites ++ " of " ++ show totalSuites + ++ " test suites (" ++ show passedCases ++ " of " + ++ show totalCases ++ " test cases) passed." + return $! passedSuites == totalSuites + +-- | Print a summary of a single test case's result to the console, supressing +-- output for certain verbosity or test filter levels. +summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO () +summarizeCase verbosity details t = + when shouldPrint $ notice verbosity $ "Test case " ++ caseName t + ++ ": " ++ show (caseResult t) + where shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = caseResult t /= TestSuite.Pass + +-- | Print a summary of the test suite's results on the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeSuiteFinish :: TestSuiteLog -> String +summarizeSuiteFinish testLog = unlines + [ "Test suite " ++ name testLog ++ ": " ++ resStr + , "Test suite logged to: " ++ logFile testLog + ] + where resStr = map toUpper (resultString testLog) + +summarizeSuiteStart :: String -> String +summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" + +resultString :: TestSuiteLog -> String +resultString l | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> TestSuiteLog + -> FilePath +testSuiteLogPath template pkg_descr lbi testLog = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) + ++ [ (TestSuiteNameVar, toPathTemplate $ name testLog) + , (TestSuiteResultVar, result) + ] + result = toPathTemplate $ resultString testLog + +packageLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) + +-- | The filename of the source file for the stub executable associated with a +-- library 'TestSuite'. +stubFilePath :: PD.TestSuite -> FilePath +stubFilePath t = stubName t <.> "hs" + +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: PD.TestSuite -> FilePath +stubName t = PD.testName t ++ "Stub" + +-- | Write the source file for a library 'TestSuite' stub executable. +writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath -- ^ path to directory where stub source + -- should be located + -> IO () +writeSimpleTestStub t dir = do + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + PD.TestSuiteLibV09 _ m = PD.testInterface t + writeFile filename $ simpleTestStub m + +-- | Source code for library test suite stub executable +simpleTestStub :: ModuleName -> String +simpleTestStub m = unlines + [ "module Main ( main ) where" + , "import Control.Monad ( liftM )" + , "import Distribution.Simple.Test ( runTests )" + , "import " ++ show (disp m) ++ " ( tests )" + , "main :: IO ()" + , "main = runTests tests" + ] + +-- | The test runner used in library "TestSuite" stub executables. Runs a list +-- of 'Test's. An executable calling this function is meant to be invoked as +-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', +-- provided by Cabal, is read from the standard input; it supplies the name of +-- the test suite and the location of the machine-readable test suite log file. +-- Human-readable log information is written to the standard output for capture +-- by the calling Cabal process. +runTests :: [TestSuite.Test] -> IO () +runTests tests = do + testLogIn <- liftM read getContents + let go :: TestSuite.Test -> IO Case + go t = do + o <- getTestOptions t testLogIn + r <- TestSuite.runM t o + let ret = Case + { caseName = TestSuite.name t + , caseOptions = o + , caseResult = r + } + summarizeCase normal Always ret + return ret + cases' <- mapM go tests + let testLog = testLogIn { cases = cases'} + writeFile (logFile testLog) $ show testLog + when (suiteError testLog) $ exitWith $ ExitFailure 2 + when (suiteFailed testLog) $ exitWith $ ExitFailure 1 + exitWith ExitSuccess diff --git a/Distribution/Simple/UHC.hs b/Distribution/Simple/UHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/UHC.hs @@ -0,0 +1,296 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for +-- inspiration on how to design this module. + +{- +Copyright (c) 2009, Andres Loeh +Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.UHC ( + configure, getInstalledPackages, + buildLib, buildExe, installLib, registerPackage + ) where + +import Control.Monad +import Data.List +import Distribution.Compat.ReadP +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler as C +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.Directory +import System.FilePath + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_uhcProg, uhcVersion, conf') <- + requireProgramVersion verbosity uhcProgram + (orLaterVersion (Version [1,0,2] [])) + (userMaybeSpecifyPath "uhc" hcPath conf) + + let comp = Compiler { + compilerId = CompilerId UHC uhcVersion, + compilerLanguages = uhcLanguages, + compilerExtensions = uhcLanguageExtensions + } + return (comp, conf') + +uhcLanguages :: [(Language, C.Flag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, C.Flag)] +uhcLanguageExtensions = + [(CPP, "--cpp"), + (PolymorphicComponents, ""), + (ExistentialQuantification, ""), + (ForeignFunctionInterface, ""), + (UndecidableInstances, ""), + (MultiParamTypeClasses, ""), + (Rank2Types, ""), + (PatternSignatures, ""), + (EmptyDataDecls, ""), + (NoImplicitPrelude, "--no-prelude"), + (TypeOperators, ""), + (OverlappingInstances, ""), + (FlexibleInstances, "")] + +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packagedbs conf = do + let compilerid = compilerId comp + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + -- call to "lines" necessary, because pkgdir contains an extra newline at the end + pkgs <- liftM (map addBuiltinVersions . concat) . + mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . + concatMap lines $ pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getUserPackageDir :: IO FilePath +getUserPackageDir = + do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths user system db = + case db of + GlobalPackageDB -> [ system ] + UserPackageDB -> [ user ] + SpecificPackageDB path -> [ path ] + +-- | Hack to add version numbers to UHC-builtin packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = emptyInstalledPackageInfo + { installedPackageId = InstalledPackageId (display p), + sourcePackageId = p } + + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- set package name + ["--pkg-build=" ++ display (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine userPkgDir systemPkgDir + lbi (libBuildInfo lib) clbi + (buildDir lbi) verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map (map (\ c -> if c == '.' then pathSeparator else c)) + (map display (libModules lib)) + + runUhcProg uhcArgs + + return () + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- common flags lib/exe + constructUHCCmdLine userPkgDir systemPkgDir + lbi (buildInfo exe) clbi + (buildDir lbi) verbosity + -- output file + ++ ["--output", buildDir lbi exeName exe] + -- main source module + ++ [modulePath exe] + runUhcProg uhcArgs + +constructUHCCmdLine :: FilePath -> FilePath + -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + (if verbosity >= deafening then ["-v4"] + else if verbosity >= normal then [] + else ["-v0"]) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ (case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"]) + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib :: Verbosity -> LocalBuildInfo + -> FilePath -> FilePath -> FilePath + -> PackageDescription -> Library -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir + +-- currently hardcoded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) + | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = packageId pkg + compilerid = compilerId (compiler lbi) diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs --- a/Distribution/Simple/UserHooks.hs +++ b/Distribution/Simple/UserHooks.hs @@ -66,7 +66,7 @@ import Distribution.Simple.Setup (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, - HaddockFlags) + HaddockFlags, TestFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) type Args = [String] @@ -161,9 +161,18 @@ -- |Over-ride this hook to get different behavior during haddock. haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO () + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before test command. + preTest :: Args -> TestFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during test. + testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), + -- |Hook to run after test command. + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () } +{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} + -- |Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks emptyUserHooks @@ -201,7 +210,11 @@ postHscolour = ru, preHaddock = rn, haddockHook = ru, - postHaddock = ru + postHaddock = ru, + preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without + -- noExtraFlags + testHook = ru, + postTest = ru } where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo ru _ _ _ _ = return () diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -48,7 +48,6 @@ module Distribution.Simple.Utils ( cabalVersion, - cabalBootstrapping, -- * logging and errors die, @@ -196,19 +195,16 @@ ( catchIO, catchExit, onException ) import Distribution.Verbosity --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#ifdef CABAL_VERSION -cabalVersion = Version [CABAL_VERSION] [] -#else -cabalVersion = error "Cabal was not bootstrapped correctly" +#ifdef VERSION_base +import qualified Paths_Cabal (version) #endif -cabalBootstrapping :: Bool -#ifdef CABAL_VERSION -cabalBootstrapping = False +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#ifdef VERSION_base +cabalVersion = Paths_Cabal.version #else -cabalBootstrapping = True +cabalVersion = Version [1,9999] [] --used when bootstrapping #endif -- ---------------------------------------------------------------------------- diff --git a/Distribution/TestSuite.hs b/Distribution/TestSuite.hs new file mode 100644 --- /dev/null +++ b/Distribution/TestSuite.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE CPP, ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the detailed test suite interface which makes it +-- possible to expose individual tests to Cabal or other test agents. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.TestSuite + ( -- * Example + -- $example + -- * Options + Options(..) + , lookupOption + , TestOptions(..) + -- * Tests + , Test + , pure, impure + , Result(..) + , ImpureTestable(..) + , PureTestable(..) + ) where + +#ifdef NEW_EXCEPTION +import Control.Exception ( evaluate, catch, throw, SomeException, fromException ) +#else +import Control.Exception ( evaluate, catch, throw, Exception(IOException) ) +#endif + +--TODO: it is totally unreasonable that we have to import things from GHC.* here. +-- see ghc ticket #3517 +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 612 +import GHC.IO.Exception ( IOErrorType(Interrupted) ) +#else +import GHC.IOBase ( IOErrorType(Interrupted) ) +#endif +import System.IO.Error ( ioeGetErrorType ) +#endif + +import Data.List ( unionBy ) +import Data.Monoid ( Monoid(..) ) +import Data.Typeable ( TypeRep ) +import Prelude hiding ( catch ) + +-- | 'Options' are provided to pass options to test runners, making tests +-- reproducable. Each option is a @('String', 'String')@ of the form +-- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same +-- option is given different values, the value from the left argument of +-- 'mappend' will be used. +newtype Options = Options [(String, String)] + deriving (Read, Show, Eq) + +instance Monoid Options where + mempty = Options [] + mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b + where + equating p x y = p x == p y + + +class TestOptions t where + -- | The name of the test. + name :: t -> String + + -- | A list of the options a test recognizes. The name and 'TypeRep' are + -- provided so that test agents can ensure that user-specified options are + -- correctly typed. + options :: t -> [(String, TypeRep)] + + -- | The default options for a test. Test frameworks should provide a new + -- random seed, if appropriate. + defaultOptions :: t -> IO Options + + -- | Try to parse the provided options. Return the names of unparsable + -- options. This allows test agents to detect bad user-specified options. + check :: t -> Options -> [String] + +-- | Read an option from the specified set of 'Options'. It is an error to +-- lookup an option that has not been specified. For this reason, test agents +-- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so +-- the default value specified by the test framework will be used for any +-- otherwise-unspecified options. +lookupOption :: Read r => String -> Options -> r +lookupOption n (Options opts) = + case lookup n opts of + Just str -> read str + Nothing -> error $ "test option not specified: " ++ n + +data Result + = Pass -- ^ indicates a successful test + | Fail String -- ^ indicates a test completed unsuccessfully; + -- the 'String' value should be a human-readable message + -- indicating how the test failed. + | Error String -- ^ indicates a test that could not be + -- completed due to some error; the test framework + -- should provide a message indicating the + -- nature of the error. + deriving (Read, Show, Eq) + +-- | Class abstracting impure tests. Test frameworks should implement this +-- class only as a last resort for test types which actually require 'IO'. +-- In particular, tests that simply require pseudo-random number generation can +-- be implemented as pure tests. +class TestOptions t => ImpureTestable t where + -- | Runs an impure test and returns the result. Test frameworks + -- implementing this class are responsible for converting any exceptions to + -- the correct 'Result' value. + runM :: t -> Options -> IO Result + +-- | Class abstracting pure tests. Test frameworks should prefer to implement +-- this class over 'ImpureTestable'. A default instance exists so that any pure +-- test can be lifted into an impure test; when lifted, any exceptions are +-- automatically caught. Test agents that lift pure tests themselves must +-- handle exceptions. +class TestOptions t => PureTestable t where + -- | The result of a pure test. + run :: t -> Options -> Result + +-- | 'Test' is a wrapper for pure and impure tests so that lists containing +-- arbitrary test types can be constructed. +data Test + = forall p. PureTestable p => PureTest p + | forall i. ImpureTestable i => ImpureTest i + +-- | A convenient function for wrapping pure tests into 'Test's. +pure :: PureTestable p => p -> Test +pure = PureTest + +-- | A convenient function for wrapping impure tests into 'Test's. +impure :: ImpureTestable i => i -> Test +impure = ImpureTest + +instance TestOptions Test where + name (PureTest p) = name p + name (ImpureTest i) = name i + + options (PureTest p) = options p + options (ImpureTest i) = options i + + defaultOptions (PureTest p) = defaultOptions p + defaultOptions (ImpureTest p) = defaultOptions p + + check (PureTest p) = check p + check (ImpureTest p) = check p + +instance ImpureTestable Test where + runM (PureTest p) o = catch (evaluate $ run p o) handler + + -- Because we have to handle old and new style exceptions, GHC and non-GHC + -- this code is totally horrible and really fragile. Has to be tested with + -- lots of ghc versions to check it is right, and with non-ghc too. :-( +#ifdef NEW_EXCEPTION + where + handler :: SomeException -> IO Result + handler e = case fromException e of + Just ioe | isInterruptedError ioe -> throw e + _ -> return (Error (show e)) +#else + where + handler :: Exception -> IO Result + handler e = case e of + IOException ioe | isInterruptedError ioe -> throw e + _ -> return (Error (show e)) +#endif + + -- We do not want to catch control-C here, but only GHC + -- defines the Interrupted exception type! (ticket #3517) + isInterruptedError ioe = +#ifdef __GLASGOW_HASKELL__ + ioeGetErrorType ioe == Interrupted +#else + False +#endif + + runM (ImpureTest i) o = runM i o + +-- $example +-- The following terms are used carefully throughout this file: +-- +-- [test interface] The interface provided by this module. +-- +-- [test agent] A program used by package users to coordinates the running +-- of tests and the reporting of their results. +-- +-- [test framework] A package used by software authors to specify tests, +-- such as QuickCheck or HUnit. +-- +-- Test frameworks are obligated to supply, at least, instances of the +-- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test +-- frameworks implement 'PureTestable' whenever possible, so that test agents +-- have an assurance that tests can be safely run in parallel. +-- +-- Test agents that allow the user to specify options should avoid setting +-- options not listed by the 'options' method. Test agents should use 'check' +-- before running tests with non-default options. Test frameworks must +-- implement a 'check' function that attempts to parse the given options safely. +-- +-- The packages cabal-test-hunit, cabal-test-quickcheck1, and +-- cabal-test-quickcheck2 provide simple interfaces to these popular test +-- frameworks. An example from cabal-test-quickcheck2 is shown below. A +-- better implementation would eliminate the console output from QuickCheck\'s +-- built-in runner and provide an instance of 'PureTestable' instead of +-- 'ImpureTestable'. +-- +-- > import Control.Monad (liftM) +-- > import Data.Maybe (catMaybes, fromJust, maybe) +-- > import Data.Typeable (Typeable(..)) +-- > import qualified Distribution.TestSuite as Cabal +-- > import System.Random (newStdGen, next, StdGen) +-- > import qualified Test.QuickCheck as QC +-- > +-- > data QCTest = forall prop. QC.Testable prop => QCTest String prop +-- > +-- > test :: QC.Testable prop => String -> prop -> Cabal.Test +-- > test n p = Cabal.impure $ QCTest n p +-- > +-- > instance Cabal.TestOptions QCTest where +-- > name (QCTest n _) = n +-- > +-- > options _ = +-- > [ ("std-gen", typeOf (undefined :: String)) +-- > , ("max-success", typeOf (undefined :: Int)) +-- > , ("max-discard", typeOf (undefined :: Int)) +-- > , ("size", typeOf (undefined :: Int)) +-- > ] +-- > +-- > defaultOptions _ = do +-- > rng <- newStdGen +-- > return $ Cabal.Options $ +-- > [ ("std-gen", show rng) +-- > , ("max-success", show $ QC.maxSuccess QC.stdArgs) +-- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs) +-- > , ("size", show $ QC.maxSize QC.stdArgs) +-- > ] +-- > +-- > check t (Cabal.Options opts) = catMaybes +-- > [ maybeNothing "max-success" ([] :: [(Int, String)]) +-- > , maybeNothing "max-discard" ([] :: [(Int, String)]) +-- > , maybeNothing "size" ([] :: [(Int, String)]) +-- > ] +-- > -- There is no need to check the parsability of "std-gen" +-- > -- because the Read instance for StdGen always succeeds. +-- > where +-- > maybeNothing n x = +-- > maybe Nothing (\str -> +-- > if reads str == x then Just n else Nothing) +-- > $ lookup n opts +-- > +-- > instance Cabal.ImpureTestable QCTest where +-- > runM (QCTest _ prop) o = +-- > catch go (return . Cabal.Error . show) +-- > where +-- > go = do +-- > result <- QC.quickCheckWithResult args prop +-- > return $ case result of +-- > QC.Success {} -> Cabal.Pass +-- > QC.GaveUp {}-> +-- > Cabal.Fail $ "gave up after " +-- > ++ show (QC.numTests result) +-- > ++ " tests" +-- > QC.Failure {} -> Cabal.Fail $ QC.reason result +-- > QC.NoExpectedFailure {} -> +-- > Cabal.Fail "passed (expected failure)" +-- > args = QC.Args +-- > { QC.replay = Just +-- > ( Cabal.lookupOption "std-gen" o +-- > , Cabal.lookupOption "size" o +-- > ) +-- > , QC.maxSuccess = Cabal.lookupOption "max-success" o +-- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o +-- > , QC.maxSize = Cabal.lookupOption "size" o +-- > } diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs --- a/Distribution/Verbosity.hs +++ b/Distribution/Verbosity.hs @@ -56,7 +56,7 @@ import Distribution.ReadE data Verbosity = Silent | Normal | Verbose | Deafening - deriving (Show, Eq, Ord, Enum, Bounded) + deriving (Show, Read, Eq, Ord, Enum, Bounded) -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -113,8 +113,9 @@ | LaterVersion Version -- > version (NB. not >=) | EarlierVersion Version -- < version | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax deriving (Show,Read,Eq) {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} @@ -253,7 +254,8 @@ fold (WildcardVersion v) = fold (wildcard v) fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - + fold (VersionRangeParens v) = fold v + wildcard v = intersectVersionRanges (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) @@ -275,9 +277,10 @@ -- range defined by the wildcard. -> (a -> a -> a) -- ^ @\"_ || _\"@ union -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses -> VersionRange -> a foldVersionRange' anyv this later earlier orLater orEarlier - wildcard union intersect = fold + wildcard union intersect parens = fold where fold AnyVersion = anyv fold (ThisVersion v) = this v @@ -296,6 +299,7 @@ fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = parens (fold v) -- | Does this version fall within the given range? @@ -676,6 +680,7 @@ (\v _ -> (Disp.text "==" <> dispWild v , 0)) (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + id where dispWild (Version b _) = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) @@ -720,7 +725,7 @@ (Parse.char ')' >> Parse.skipSpaces) (do a <- p Parse.skipSpaces - return a) + return (VersionRangeParens a)) digits = do first <- Parse.satisfy Char.isDigit diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -6,7 +6,7 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -- --- Haskell language extensions +-- Haskell language dialects and extensions {- All rights reserved. @@ -39,6 +39,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Language.Haskell.Extension ( + Language(..), + knownLanguages, + Extension(..), knownExtensions, deprecatedExtensions @@ -51,6 +54,48 @@ import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) -- ------------------------------------------------------------ +-- * Language +-- ------------------------------------------------------------ + +-- | This represents a Haskell language dialect. +-- +-- Language 'Extension's are interpreted relative to one of these base +-- languages. +-- +data Language = + + -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + + -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + | Haskell2010 + + -- | An unknown language, identified by its name. + | UnknownLanguage String + deriving (Show, Read, Eq) + +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010] + +instance Text Language where + disp (UnknownLanguage other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + lang <- Parse.munch1 Char.isAlphaNum + return (classifyLanguage lang) + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +-- ------------------------------------------------------------ -- * Extension -- ------------------------------------------------------------ @@ -61,92 +106,321 @@ -- -- * also to the 'knownExtensions' list below. --- |This represents language extensions beyond Haskell 98 that are --- supported by some implementations, usually in some special mode. +-- | This represents language extensions beyond a base 'Language' definition +-- (such as 'Haskell98') that are supported by some implementations, usually +-- in some special mode. +-- +-- Where applicable, references are given to an implementation's +-- official documentation, e.g. \"GHC § 7.2.1\" for an extension +-- documented in section 7.2.1 of the GHC User's Guide. -data Extension - = OverlappingInstances +data Extension = + + -- | [GHC § 7.6.3.4] Allow overlapping class instances, + -- provided there is a unique most specific instance for each use. + OverlappingInstances + + -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the + -- termination of class instance resolution. Termination is + -- guaranteed by a fixed-depth recursion stack, and compilation + -- may fail if this depth is exceeded. | UndecidableInstances + + -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the + -- implementation to choose an instance even when it is possible + -- that further instantiation of types will lead to a more specific + -- instance being applicable. | IncoherentInstances + + -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, + -- using the @rec@ keyword. + | DoRec + + -- | [GHC § 7.3.8.2] Deprecated in GHC. Allows recursive bindings + -- using @mdo@, a variant of @do@. @DoRec@ provides a different, + -- preferred syntax. | RecursiveDo + + -- | [GHC § 7.3.9] Provide syntax for writing list + -- comprehensions which iterate over several lists together, like + -- the 'zipWith' family of functions. | ParallelListComp + + -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. | MultiParamTypeClasses + + -- | [GHC § 7.17] Disable the dreaded monomorphism restriction. | NoMonomorphismRestriction + + -- | [GHC § 7.6.2] Allow a specification attached to a + -- multi-parameter type class which indicates that some parameters + -- are entirely determined by others. The implementation will check + -- that this property holds for the declared instances, and will use + -- this property to reduce ambiguity in instance resolution. | FunctionalDependencies + + -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. | Rank2Types + + -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on + -- the left of a function arrow. | RankNTypes + + -- | [GHC § 7.8.5] Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. | PolymorphicComponents + + -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. | ExistentialQuantification + + -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an + -- explicit @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. | ScopedTypeVariables - -- | Deprecated, use ScopedTypeVariables instead. + + -- | Deprecated, use 'ScopedTypeVariables' instead. | PatternSignatures + + -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic + -- scope. | ImplicitParams + + -- | [GHC § 7.8.2] Relax some restrictions on the form of the context + -- of a type signature. | FlexibleContexts + + -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the + -- context of an instance declaration. | FlexibleInstances + + -- | [GHC § 7.4.1] Allow data type declarations with no constructors. | EmptyDataDecls + + -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. | CPP + -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of + -- types over which a type variable ranges. | KindSignatures + + -- | [GHC § 7.11] Enable a form of pattern which forces evaluation + -- before an attempted match, and a form of strict @let@/@where@ + -- binding. | BangPatterns + + -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. | TypeSynonymInstances + + -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time + -- metaprogramming. | TemplateHaskell + + -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, + -- implements the standard Haskell 98 Foreign Function Interface + -- Addendum, plus some GHC-specific extensions. | ForeignFunctionInterface + + -- | [GHC § 7.10] Enable arrow notation. | Arrows + + -- | [GHC § 7.16] Enable generic type classes, with default instances + -- defined in terms of the algebraic structure of a type. | Generics + + -- | [GHC § 7.3.11] Disable the implicit importing of the module + -- @Prelude@. When desugaring certain built-in syntax into ordinary + -- identifiers, use whatever is in scope rather than the @Prelude@ + -- version. | NoImplicitPrelude + + -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. Puns bind specific + -- names, unlike 'RecordWildCards'. | NamedFieldPuns + + -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and + -- binds variables. | PatternGuards + + -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use + -- @deriving@ for any class with an instance for the underlying type. | GeneralizedNewtypeDeriving + -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. | ExtensibleRecords + + -- | [Hugs § 7.2] Enable type synonyms which are transparent in + -- some definitions and opaque elsewhere, as a way of implementing + -- abstract datatypes. | RestrictedTypeSynonyms + + -- | [Hugs § 7.3] Enable an alternate syntax for string literals, + -- with string templating. | HereDocuments + + -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on + -- identifiers. Also enables literal syntax for unboxed values. | MagicHash + + -- | [GHC § 7.7] Allow data types and type synonyms which are + -- indexed by types, i.e. ad-hoc polymorphism for types. | TypeFamilies + + -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the + -- type class @deriving@ mechanism. | StandaloneDeriving + -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for + -- certain ASCII character sequences, e.g. keywords and punctuation. | UnicodeSyntax + + -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, + -- e.g. in @foreign import@ and @foreign export@. | UnliftedFFITypes + + -- | [GHC § 7.4.3] Defer validity checking of types until after + -- expanding type synonyms, relaxing the constraints on how synonyms + -- may be used. | LiberalTypeSynonyms + + -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, + -- or type variable to be an infix operator. | TypeOperators + --PArr -- not ready yet, and will probably be renamed to ParallelArrays + + -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. A wildcard binds + -- all unmentioned names, unlike 'NamedFieldPuns'. | RecordWildCards + + -- | Deprecated, use 'NamedFieldPuns' instead. | RecordPuns + + -- | [GHC § 7.3.14] Allow a record field name to be disambiguated + -- by the type of the record it's in. | DisambiguateRecordFields + + -- | [GHC § 7.6.4] Enable overloading of string literals using a + -- type class, much like integer literals. | OverloadedStrings + + -- | [GHC § 7.4.6] Enable generalized algebraic data types, in + -- which type variables may be instantiated on a per-constructor + -- basis. Enables \"GADT syntax\" which can be used to declare + -- GADTs as well as ordinary algebraic types. | GADTs + + -- | [GHC § 7.17.2] Allow pattern bindings to be polymorphic. | NoMonoPatBinds + + -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive + -- polymorphic functions. | RelaxedPolyRec + + -- | [GHC § 2.4.5] Allow default instantiation of polymorphic + -- types in more situations. | ExtendedDefaultRules + + -- | [GHC § 7.2.2] Enable unboxed tuples. | UnboxedTuples + + -- | [GHC § 7.5.3] Enable @deriving@ for classes + -- @Data.Typeable.Typeable@ and @Data.Generics.Data@. | DeriveDataTypeable + + -- | [GHC § 7.6.1.3] Allow a class method's type to place + -- additional constraints on a class type variable. | ConstrainedClassMethods - -- | Allow imports to be qualified by the package name that the module - -- is intended to be imported from, e.g. + -- | [GHC § 7.3.18] Allow imports to be qualified by the package + -- name the module is intended to be imported from, e.g. -- -- > import "network" Network.Socket | PackageImports + -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in + -- GHC 7. Allow a type variable to be instantiated at a + -- polymorphic type. | ImpredicativeTypes + + -- | [GHC § 7.3.3] Change the syntax for qualified infix + -- operators. | NewQualifiedOperators + + -- | [GHC § 7.3.12] Relax the interpretation of left operator + -- sections to allow unary postfix operators. | PostfixOperators + + -- | [GHC § 7.9.5] Enable quasi-quotation, a mechanism for defining + -- new concrete syntax for expressions and patterns. | QuasiQuotes + + -- | [GHC § 7.3.10] Enable generalized list comprehensions, + -- supporting operations such as sorting and grouping. | TransformListComp + + -- | [GHC § 7.3.6] Enable view patterns, which match a value by + -- applying a function and matching on the result. | ViewPatterns -- | Allow concrete XML syntax to be used in expressions and patterns, -- as per the Haskell Server Pages extension language: -- . The ideas behind it are - -- discussed in the paper "Haskell Server Pages through Dynamic Loading" + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" -- by Niklas Broberg, from Haskell Workshop '05. | XmlSyntax -- | Allow regular pattern matching over lists, as discussed in the - -- paper "Regular Expression Patterns" by Niklas Broberg, Andreas Farre + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre -- and Josef Svenningsson, from ICFP '04. | RegularPatterns + -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + | TupleSections + + -- | Allows GHC primops, written in C--, to be imported into a Haskell + -- file. + | GHCForeignImportPrim + + -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + | NPlusKPatterns + + -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + | DoAndIfThenElse + + -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + | RebindableSyntax + + -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + | ExplicitForAll + + -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + | DatatypeContexts + + -- | Local (@let@ and @where@) bindings are monomorphic. + | MonoLocalBinds + + -- | Enable @deriving@ for the @Data.Functor.Functor@ class. + | DeriveFunctor + + -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. + | DeriveTraversable + + -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. + | DeriveFoldable + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. | UnknownExtension String deriving (Show, Read, Eq) @@ -164,6 +438,7 @@ [ OverlappingInstances , UndecidableInstances , IncoherentInstances + , DoRec , RecursiveDo , ParallelListComp , MultiParamTypeClasses @@ -225,6 +500,18 @@ , ViewPatterns , XmlSyntax , RegularPatterns + + , TupleSections + , GHCForeignImportPrim + , NPlusKPatterns + , DoAndIfThenElse + , RebindableSyntax + , ExplicitForAll + , DatatypeContexts + , MonoLocalBinds + , DeriveFunctor + , DeriveTraversable + , DeriveFoldable ] instance Text Extension where diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,15 +1,8 @@ -*-change-log-*- -1.8.0.4 Duncan Coutts March 2010 - * Fix exe-depends-on-lib feature with ghc-6.12 - * Fix use of --package-db with ghc-6.12 - * By default $datadir now follows the $prefix on Windows - * Find ar.exe on windows better - * Fix mixup between $arch and $os path variables - * Support for for hugs and nhc package databases - * Set dynlib name for shared libs on OSX +1.9.x (current development version) -1.8.0.2 Duncan Coutts December 2009 +1.8.0.x (next stable release version) * Support for GHC-6.12 * New unique installed package IDs which use a package hash * Allow executables to depend on the lib within the same package