X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-cabal%2Fghc-cabal.hs;h=fb1c870f3d722224a5af52e9e3e5efe6b9d312a4;hb=915ea7223dfd3050922008b0ca6dfdf921b31578;hp=8ee1304fb8086ef079a5d23251fd2b55e7ca2746;hpb=72547264724117d689a7fa400104185557fb2a0c;p=ghc-hetmet.git diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs index 8ee1304..fb1c870 100644 --- a/utils/ghc-cabal/ghc-cabal.hs +++ b/utils/ghc-cabal/ghc-cabal.hs @@ -10,6 +10,7 @@ import Distribution.Simple import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program +import Distribution.Simple.Program.HcPkg import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic) import Distribution.Simple.Build (writeAutogenFiles) import Distribution.Simple.Register @@ -25,32 +26,35 @@ 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' + "hscolour" : distDir : dir : args' -> + runHsColour distDir dir args' "check" : dir : [] -> doCheck dir - "install" : ghcpkg : ghcpkgconfig : directory : distDir - : myDestDir : myPrefix : myLibdir : myDocdir : args' -> - doInstall ghcpkg ghcpkgconfig directory distDir - myDestDir myPrefix myLibdir myDocdir args' + "install" : ghc : ghcpkg : strip : topdir : directory : distDir + : myDestDir : myPrefix : myLibdir : myDocdir + : relocatableBuild : args' -> + doInstall ghc ghcpkg strip topdir directory distDir + myDestDir myPrefix myLibdir myDocdir + relocatableBuild args' "configure" : args' -> case break (== "--") args' of (config_args, "--" : distdir : directories) -> mapM_ (generate config_args distdir) directories _ -> die syntax_error + "sdist" : dir : distDir : [] -> + doSdist dir distDir _ -> die syntax_error syntax_error :: [String] syntax_error = ["syntax: ghc-cabal configure -- ...", " ghc-cabal install ...", - " ghc-cabal haddock ..."] + " ghc-cabal hscolour ..."] -die :: [String] -> IO () +die :: [String] -> IO a die errs = do mapM_ (hPutStrLn stderr) errs exitWith (ExitFailure 1) @@ -69,6 +73,30 @@ withCurrentDirectory directory io userHooks :: UserHooks userHooks = autoconfUserHooks +runDefaultMain :: IO () +runDefaultMain + = do let verbosity = normal + gpdFile <- defaultPackageDesc verbosity + gpd <- readPackageDescription verbosity gpdFile + case buildType (flattenPackageDescription gpd) of + Just Configure -> defaultMainWithHooks autoconfUserHooks + -- 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 + +doSdist :: FilePath -> FilePath -> IO () +doSdist directory distDir + = withCurrentDirectory directory + $ withArgs (["sdist", "--builddir", distDir]) + runDefaultMain + doCheck :: FilePath -> IO () doCheck directory = withCurrentDirectory directory @@ -83,48 +111,43 @@ doCheck directory where isFailure (PackageDistSuspicious {}) = False isFailure _ = True -runHaddock :: FilePath -> FilePath -> [String] -> IO () -runHaddock distdir directory args +runHsColour :: FilePath -> FilePath -> [String] -> IO () +runHsColour distdir directory args = withCurrentDirectory directory - $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args) - where - hooks = userHooks { - haddockHook = modHook (haddockHook userHooks) - } - modHook f pd lbi us flags - | packageName pd == PackageName "ghc-prim" - = let pd' = case library pd of - Just lib -> - let ghcPrim = fromJust (simpleParse "GHC.Prim") - ems = filter (ghcPrim /=) - (exposedModules lib) - lib' = lib { exposedModules = ems } - in pd { library = Just lib' } - Nothing -> - error "Expected a library, but none found" - pc = withPrograms lbi - pc' = userSpecifyArgs "haddock" - ["dist-install/build/autogen/GHC/Prim.hs"] pc - lbi' = lbi { withPrograms = pc' } - in f pd' lbi' us flags - | otherwise - = f pd lbi us flags + $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args) 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 -> FilePath + -> String -> [String] + -> IO () +doInstall ghc ghcpkg strip topdir directory distDir + myDestDir myPrefix myLibdir myDocdir + relocatableBuildStr args = withCurrentDirectory directory $ do - defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir] - ++ (if null myDestDir then [] - else ["--destdir", myDestDir]) - ++ args) - defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args) - where - hooks = userHooks { - copyHook = noGhcPrimHook (modHook (copyHook userHooks)), - regHook = modHook (regHook userHooks) - } + relocatableBuild <- case relocatableBuildStr of + "YES" -> return True + "NO" -> return False + _ -> die ["Bad relocatableBuildStr: " ++ + show relocatableBuildStr] + let copyArgs = ["copy", "--builddir", distDir] + ++ (if null myDestDir + then [] + else ["--destdir", myDestDir]) + ++ args + regArgs = "register" : "--builddir" : distDir : args + copyHooks = userHooks { + copyHook = noGhcPrimHook + $ modHook False + $ copyHook userHooks + } + regHooks = userHooks { + regHook = modHook relocatableBuild + $ regHook userHooks + } + defaultMainWithHooksArgs copyHooks copyArgs + defaultMainWithHooksArgs regHooks regArgs + where noGhcPrimHook f pd lbi us flags = let pd' | packageName pd == PackageName "ghc-prim" = @@ -138,53 +161,109 @@ doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocd error "Expected a library, but none found" | otherwise = pd in f pd' lbi us flags - modHook f pd lbi us flags - = let idts = installDirTemplates lbi - idts' = idts { prefix = toPathTemplate myPrefix, - libdir = toPathTemplate myLibdir, - libsubdir = toPathTemplate "$pkgid", - docdir = toPathTemplate (myDocdir "$pkg"), - 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 + modHook relocatableBuild f pd lbi us flags + = do let verbosity = normal + idts = installDirTemplates lbi + idts' = idts { + prefix = toPathTemplate $ + if relocatableBuild + then "$topdir" + else myPrefix, + libdir = toPathTemplate $ + if relocatableBuild + then "$topdir" + else myLibdir, + libsubdir = toPathTemplate "$pkgid", + docdir = toPathTemplate $ + if relocatableBuild + then "$topdir/../doc/html/libraries/$pkgid" + else (myDocdir "$pkgid"), + htmldir = toPathTemplate "$docdir" + } + progs = withPrograms lbi + ghcProg = ConfiguredProgram { + programId = programName ghcProgram, + programVersion = Nothing, + programDefaultArgs = ["-B" ++ topdir], + programOverrideArgs = [], + programLocation = UserSpecified ghc + } + ghcpkgconf = topdir "package.conf.d" + ghcPkgProg = ConfiguredProgram { + programId = programName ghcPkgProgram, + programVersion = Nothing, + programDefaultArgs = ["--global-conf", + ghcpkgconf] + ++ if not (null myDestDir) + then ["--force"] + else [], + programOverrideArgs = [], + programLocation = UserSpecified ghcpkg + } + stripProg = ConfiguredProgram { + programId = programName stripProgram, + programVersion = Nothing, + programDefaultArgs = [], + programOverrideArgs = [], + programLocation = UserSpecified strip + } + progs' = updateProgram ghcProg + $ updateProgram ghcPkgProg + $ updateProgram stripProg + progs + instInfos <- dump verbosity ghcPkgProg GlobalPackageDB + let installedPkgs' = PackageIndex.fromList instInfos + let mlc = libraryConfig lbi + mlc' = case mlc of + Just lc -> + let cipds = componentPackageDeps lc + cipds' = [ (fixupPackageId instInfos ipid, pid) + | (ipid,pid) <- cipds ] + in Just $ lc { + componentPackageDeps = 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 = withCurrentDirectory directory $ do let verbosity = normal - gpdFile <- defaultPackageDesc verbosity - gpd <- readPackageDescription verbosity gpdFile - -- XXX We shouldn't just configure with the default flags -- XXX And this, and thus the "getPersistBuildConfig distdir" below, -- aren't going to work when the deps aren't built yet withArgs (["configure", "--distdir", distdir] ++ config_args) - (case buildType (flattenPackageDescription gpd) of - Just Configure -> defaultMainWithHooks autoconfUserHooks - -- 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) + runDefaultMain lbi <- getPersistBuildConfig distdir let pd0 = localPkgDescr lbi @@ -212,7 +291,10 @@ generate config_args distdir directory let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace") let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir pd lib lbi clbi - final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid } + final_ipi = installedPkgInfo { + Installed.installedPackageId = ipid, + Installed.haddockHTMLs = ["../" ++ display (packageId pd)] + } content = Installed.showInstalledPackageInfo final_ipi ++ "\n" writeFileAtomic (distdir "inplace-pkg-config") content _ -> error "Inconsistent lib components; can't happen?" @@ -245,16 +327,26 @@ generate config_args distdir directory -- stricter than gnu ld). Thus we remove the ldOptions for -- GHC's rts package: hackRtsPackage index = - case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of - [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_,[rts])] -> + PackageIndex.insert rts{ + Installed.ldOptions = [], + Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index + -- GHC <= 6.12 had $topdir/gcc-lib in their + -- library-dirs for the rts package, which causes + -- problems when we try to use the in-tree mingw, + -- due to accidentally picking up the incompatible + -- libraries there. So we filter out gcc-lib from + -- the RTS's library-dirs here. _ -> error "No (or multiple) ghc rts package is registered!!" - dep_ids = map (packageId.getLocalPackageInfo lbi) $ - externalPackageDeps lbi + dep_ids = map snd (externalPackageDeps lbi) let variablePrefix = directory ++ '_':distdir let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), variablePrefix ++ "_MODULES = " ++ unwords (map display modules), + variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)), + variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd, variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi), variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids), variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids), @@ -265,21 +357,26 @@ generate config_args distdir directory variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi), variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi), variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))", + variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd), -- XXX This includes things it shouldn't, like: -- -odir dist-bootstrapping/build - variablePrefix ++ "_HC_OPTS = " ++ escape (unwords - (programArgs ghcProg + variablePrefix ++ "_HC_OPTS = " ++ escape (unwords + ( programDefaultArgs ghcProg ++ hcOptions GHC bi - ++ extensionsToFlags (compiler lbi) (extensions bi))), + ++ extensionsToFlags (compiler lbi) (extensions bi) + ++ programOverrideArgs ghcProg)), variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi), variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi), variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi), - variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs), + variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs), variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions), - variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (forDeps Installed.libraryDirs), + variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (wrap $ forDeps Installed.libraryDirs), variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries), variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions)] writeFile (distdir ++ "/package-data.mk") $ unlines xs + writeFile (distdir ++ "/haddock-prologue.txt") $ + if null (description pd) then synopsis pd + else description pd where escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) [] - + wrap = map (\s -> "\'" ++ s ++ "\'")