X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-cabal%2Fghc-cabal.hs;h=3d9cf13dcb9fbc16311908230c352de873fa9a34;hb=930421d4ed09e5389e0ef4c5eef36075a6809cc0;hp=c19217e5e073496b1c3abdaa59c07e258fd1525e;hpb=71dcc642edcfc3bfeef2619d66183cc08ae90a43;p=ghc-hetmet.git diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs index c19217e..3d9cf13 100644 --- a/utils/ghc-cabal/ghc-cabal.hs +++ b/utils/ghc-cabal/ghc-cabal.hs @@ -1,43 +1,43 @@ module Main (main) where -import Distribution.Compat.Exception import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Parse import Distribution.Simple import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program -import Distribution.Simple.Utils (defaultPackageDesc, withTempFile) +import Distribution.Simple.Program.HcPkg +import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic) import Distribution.Simple.Build (writeAutogenFiles) -import Distribution.Simple.Register (writeInstalledConfig) -import Distribution.Simple.PackageIndex +import Distribution.Simple.Register import Distribution.Text import Distribution.Verbosity import qualified Distribution.InstalledPackageInfo as Installed - ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex - ( topologicalOrder, lookupPackageName, insert ) -import Control.Exception -import Control.Monad +import Data.List import Data.Maybe import System.IO import System.Directory import System.Environment import System.Exit import System.FilePath +import Data.Char main :: IO () main = do args <- getArgs case args of "haddock" : distDir : dir : args' -> runHaddock distDir dir args' - "install" : ghcpkg : ghcpkgconfig : directory : distDir + "check" : dir : [] -> + doCheck dir + "install" : ghc : ghcpkg : topdir : directory : distDir : myDestDir : myPrefix : myLibdir : myDocdir : args' -> - doInstall ghcpkg ghcpkgconfig directory distDir + doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args' "configure" : args' -> case break (== "--") args' of (config_args, "--" : distdir : directories) -> @@ -70,6 +70,20 @@ withCurrentDirectory directory io userHooks :: UserHooks userHooks = autoconfUserHooks +doCheck :: FilePath -> IO () +doCheck directory + = withCurrentDirectory directory + $ do let verbosity = normal + gpdFile <- defaultPackageDesc verbosity + gpd <- readPackageDescription verbosity gpdFile + case partition isFailure $ checkPackage gpd Nothing of + ([], []) -> return () + ([], warnings) -> mapM_ print warnings + (errs, _) -> do mapM_ print errs + exitWith (ExitFailure 1) + where isFailure (PackageDistSuspicious {}) = False + isFailure _ = True + runHaddock :: FilePath -> FilePath -> [String] -> IO () runHaddock distdir directory args = withCurrentDirectory directory @@ -98,8 +112,9 @@ runHaddock distdir directory args = f pd lbi us flags doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath - -> FilePath -> FilePath -> FilePath -> [String] -> IO () -doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocdir args + -> FilePath -> FilePath -> FilePath -> FilePath -> [String] + -> IO () +doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args = withCurrentDirectory directory $ do defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir] ++ (if null myDestDir then [] @@ -108,13 +123,12 @@ doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocd defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args) where hooks = userHooks { - copyHook = modHook (copyHook userHooks), + copyHook = noGhcPrimHook (modHook (copyHook userHooks)), regHook = modHook (regHook userHooks) } - modHook f pd lbi us flags - = let - pd' + noGhcPrimHook f pd lbi us flags + = let pd' | packageName pd == PackageName "ghc-prim" = case library pd of Just lib -> @@ -125,28 +139,78 @@ doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocd Nothing -> error "Expected a library, but none found" | otherwise = pd - idts = installDirTemplates lbi - idts' = idts { prefix = toPathTemplate myPrefix, - libdir = toPathTemplate myLibdir, - libsubdir = toPathTemplate "$pkgid", - docdir = toPathTemplate (myDocdir "$pkgid"), - htmldir = toPathTemplate "$docdir" } - progs = withPrograms lbi - prog = ConfiguredProgram { - programId = programName ghcPkgProgram, - programVersion = Nothing, - programArgs = ["--global-conf", ghcpkgconf] - ++ if not (null myDestDir) - then ["--force"] - else [], - programLocation = UserSpecified ghcpkg + in f pd' lbi us flags + modHook f pd lbi us flags + = do let verbosity = normal + idts = installDirTemplates lbi + idts' = idts { prefix = toPathTemplate myPrefix, + libdir = toPathTemplate myLibdir, + libsubdir = toPathTemplate "$pkgid", + docdir = toPathTemplate (myDocdir "$pkg"), + htmldir = toPathTemplate "$docdir" } + progs = withPrograms lbi + ghcProg = ConfiguredProgram { + programId = programName ghcProgram, + programVersion = Nothing, + programArgs = ["-B" ++ topdir], + programLocation = UserSpecified ghc + } + ghcpkgconf = topdir "package.conf.d" + ghcPkgProg = ConfiguredProgram { + programId = programName ghcPkgProgram, + programVersion = Nothing, + programArgs = ["--global-conf", + ghcpkgconf] + ++ if not (null myDestDir) + then ["--force"] + else [], + programLocation = UserSpecified ghcpkg + } + progs' = updateProgram ghcProg + $ updateProgram ghcPkgProg progs + instInfos <- dump verbosity ghcPkgProg GlobalPackageDB + let installedPkgs' = PackageIndex.listToInstalledPackageIndex + instInfos + let mlc = libraryConfig lbi + mlc' = case mlc of + Just lc -> + let cipds = componentInstalledPackageDeps lc + cipds' = map (fixupPackageId instInfos) cipds + in Just $ lc { + componentInstalledPackageDeps = cipds' + } + Nothing -> Nothing + lbi' = lbi { + libraryConfig = mlc', + installedPkgs = installedPkgs', + installDirTemplates = idts', + withPrograms = progs' } - progs' = updateProgram prog progs - lbi' = lbi { - installDirTemplates = idts', - withPrograms = progs' - } - in f pd' lbi' us flags + f pd lbi' us flags + +-- The packages are built with the package ID ending in "-inplace", but +-- when they're installed they get the package hash appended. We need to +-- fix up the package deps so that they use the hash package IDs, not +-- the inplace package IDs. +fixupPackageId :: [Installed.InstalledPackageInfo] + -> InstalledPackageId + -> InstalledPackageId +fixupPackageId _ x@(InstalledPackageId ipi) + | "builtin:" `isPrefixOf` ipi = x +fixupPackageId ipinfos (InstalledPackageId ipi) + = case stripPrefix (reverse "-inplace") $ reverse ipi of + Nothing -> + error ("Installed package ID doesn't end in -inplace: " ++ show ipi) + Just x -> + let ipi' = reverse ('-' : x) + f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of + y@(InstalledPackageId ipinfoid) + | ipi' `isPrefixOf` ipinfoid -> + y + _ -> + f ipinfos' + f [] = error ("Installed package ID not registered: " ++ show ipi) + in f ipinfos generate :: [String] -> FilePath -> FilePath -> IO () generate config_args distdir directory @@ -161,25 +225,22 @@ generate config_args distdir directory withArgs (["configure", "--distdir", distdir] ++ config_args) (case buildType (flattenPackageDescription gpd) of Just Configure -> defaultMainWithHooks autoconfUserHooks - _other -> defaultMain) - -- not quite right, but good enough for us + -- time has a "Custom" Setup.hs, but it's actually Configure + -- plus a "./Setup test" hook. However, Cabal is also + -- "Custom", but doesn't have a configure script. + Just Custom -> + do configureExists <- doesFileExist "configure" + if configureExists + then defaultMainWithHooks autoconfUserHooks + else defaultMain + -- not quite right, but good enough for us: + _ -> defaultMain) lbi <- getPersistBuildConfig distdir let pd0 = localPkgDescr lbi - -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether - -- or not -liconv is used. We don't use Setup.hs, so we replicate - -- what it does here. We should do this better somehow. - when (display (pkgName (package pd0)) == "haskeline") $ - case library pd0 of - Nothing -> fail "Can't happen: No haskeline library" - Just lib -> do - d <- getCurrentDirectory - print d - maybeSetLibiconv verbosity (libBuildInfo lib) lbi - hooked_bi <- - if (buildType pd0 == Just Configure) + if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom) then do maybe_infoFile <- defaultHookedPackageDesc case maybe_infoFile of @@ -194,12 +255,21 @@ generate config_args distdir directory writeAutogenFiles verbosity pd lbi -- generate inplace-pkg-config - when (isJust $ library pd) $ - writeInstalledConfig distdir pd lbi True Nothing + case (library pd, libraryConfig lbi) of + (Nothing, Nothing) -> return () + (Just lib, Just clbi) -> do + cwd <- getCurrentDirectory + let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace") + let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir + pd lib lbi clbi + final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid } + content = Installed.showInstalledPackageInfo final_ipi ++ "\n" + writeFileAtomic (distdir "inplace-pkg-config") content + _ -> error "Inconsistent lib components; can't happen?" let - libBiModules lib = (libBuildInfo lib, libModules pd) - exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules pd) + libBiModules lib = (libBuildInfo lib, libModules lib) + exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe) biModuless = (maybeToList $ fmap libBiModules $ library pd) ++ (map exeBiModules $ executables pd) buildableBiModuless = filter isBuildable biModuless @@ -225,22 +295,26 @@ generate config_args distdir directory -- stricter than gnu ld). Thus we remove the ldOptions for -- GHC's rts package: hackRtsPackage index = - case PackageIndex.lookupPackageName index (PackageName "rts") of - [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index + case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of + [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index _ -> error "No (or multiple) ghc rts package is registered!!" + dep_ids = map (packageId.getLocalPackageInfo lbi) $ + externalPackageDeps lbi + let variablePrefix = directory ++ '_':distdir let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), variablePrefix ++ "_MODULES = " ++ unwords (map display modules), variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi), - variablePrefix ++ "_DEPS = " ++ unwords (map display (packageDeps lbi)), - variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (packageDeps lbi)), + variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids), + variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids), variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi), variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi), variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi), variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi), variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi), variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi), + variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))", -- XXX This includes things it shouldn't, like: -- -odir dist-bootstrapping/build variablePrefix ++ "_HC_OPTS = " ++ escape (unwords @@ -259,68 +333,3 @@ generate config_args distdir directory where escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) [] ----------------------------------------------------------------------- --- haskeline-specific hacks - --- Sigh, haskeline proper uses stuff in Setup.hs to handle whether --- or not -liconv is used. We don't use Setup.hs, so we replicate --- what it does here. We should do this better somehow. - --- Test whether compiling a c program that links against libiconv needs -liconv. -maybeSetLibiconv :: Verbosity -> BuildInfo -> LocalBuildInfo -> IO () -maybeSetLibiconv verb bi lbi = do - let biWithIconv = addIconv bi - worksWithout <- tryCompile iconv_prog bi lbi verb - if worksWithout - then writeBuildInfo "" - else do - worksWith <- tryCompile iconv_prog biWithIconv lbi verb - if worksWith - then do - writeBuildInfo "iconv" - else fail "Unable to link against the iconv library." - where - -- Cabal (at least 1.6.0.1) won't parse an empty buildinfo file. - writeBuildInfo libs = writeFile "haskeline.buildinfo" - $ unlines ["extra-libraries: " ++ libs] - -tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool -tryCompile program bi lbi verb = flip catchIO processException $ flip catchExit processExit $ do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \fname h -> do - hPutStr h program - hClose h - -- TODO take verbosity from the args. - rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) (fname : args) - return True - where - processException :: IOException -> IO Bool - processException _ = return False - processExit = return . (==ExitSuccess) - -- Mimicing Distribution.Simple.Configure - deps = topologicalOrder (installedPkgs lbi) - args = concat - [ ccOptions bi - , cppOptions bi - , ldOptions bi - -- --extra-include-dirs and --extra-lib-dirs are included - -- in the below fields. - -- Also sometimes a dependency like rts points to a nonstandard - -- include/lib directory where iconv can be found. - , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps) - , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps) - , map ("-l" ++) (extraLibs bi) - ] - -addIconv :: BuildInfo -> BuildInfo -addIconv bi = bi {extraLibs = "iconv" : extraLibs bi} - -iconv_prog :: String -iconv_prog = unlines $ - [ "#include " - , "int main(void) {" - , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");" - , " return 0;" - , "}" - ] -