X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-cabal%2Fghc-cabal.hs;fp=utils%2Fghc-cabal%2Fghc-cabal.hs;h=0000000000000000000000000000000000000000;hb=e65048e372f1aa3a9a891847ca83ba537cc448b1;hp=81b47db65945adc2289a64ef384824a1de717852;hpb=8224f948f403886d76b98b1c91924485c9318388;p=ghc-hetmet.git diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs deleted file mode 100644 index 81b47db..0000000 --- a/utils/ghc-cabal/ghc-cabal.hs +++ /dev/null @@ -1,385 +0,0 @@ - -module Main (main) where - -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.Program.HcPkg -import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic) -import Distribution.Simple.Build (writeAutogenFiles) -import Distribution.Simple.Register -import Distribution.Text -import Distribution.Verbosity -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.Simple.PackageIndex as PackageIndex - -import Data.List -import Data.Maybe -import System.IO -import System.Directory -import System.Environment -import System.Exit -import System.FilePath - -main :: IO () -main = do args <- getArgs - case args of - "hscolour" : distDir : dir : args' -> - runHsColour distDir dir args' - "check" : dir : [] -> - doCheck dir - "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 hscolour ..."] - -die :: [String] -> IO a -die errs = do mapM_ (hPutStrLn stderr) errs - exitWith (ExitFailure 1) - --- XXX Should use bracket -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory directory io - = do curDirectory <- getCurrentDirectory - setCurrentDirectory directory - r <- io - setCurrentDirectory curDirectory - return r - --- We need to use the autoconfUserHooks, as the packages that use --- configure can create a .buildinfo file, and we need any info that --- ends up in it. -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 - $ 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 - -runHsColour :: FilePath -> FilePath -> [String] -> IO () -runHsColour distdir directory args - = withCurrentDirectory directory - $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args) - -doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath - -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath - -> String -> [String] - -> IO () -doInstall ghc ghcpkg strip topdir directory distDir - myDestDir myPrefix myLibdir myDocdir - relocatableBuildStr args - = withCurrentDirectory directory $ do - 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" = - 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" - | otherwise = pd - in f pd' lbi us flags - 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' - } - 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 - -- 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) - runDefaultMain - - lbi <- getPersistBuildConfig distdir - let pd0 = localPkgDescr lbi - - hooked_bi <- - if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom) - then do - maybe_infoFile <- defaultHookedPackageDesc - case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo - Just infoFile -> readHookedBuildInfo verbosity infoFile - else - return emptyHookedBuildInfo - - let pd = updatePackageDescription hooked_bi pd0 - - -- generate Paths_.hs and cabal-macros.h - writeAutogenFiles verbosity pd lbi - - -- generate inplace-pkg-config - 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, - Installed.haddockHTMLs = ["../" ++ display (packageId pd)] - } - 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 lib) - exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe) - biModuless = (maybeToList $ fmap libBiModules $ library pd) - ++ (map exeBiModules $ executables pd) - buildableBiModuless = filter isBuildable biModuless - where isBuildable (bi', _) = buildable bi' - (bi, modules) = case buildableBiModuless of - [] -> error "No buildable component found" - [biModules] -> biModules - _ -> error ("XXX ghc-cabal can't handle " ++ - "more than one buildinfo yet") - -- XXX Another Just... - Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) - - dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) - forDeps f = concatMap f dep_pkgs - - -- copied from Distribution.Simple.PreProcess.ppHsc2Hs - packageHacks = case compilerFlavor (compiler lbi) of - GHC -> hackRtsPackage - _ -> id - -- We don't link in the actual Haskell libraries of our - -- dependencies, so the -u flags in the ldOptions of the rts - -- package mean linking fails on OS X (it's ld is a tad - -- 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 = [], - 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 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), - 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)))", - variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd), - -- XXX This includes things it shouldn't, like: - -- -odir dist-bootstrapping/build - variablePrefix ++ "_HC_OPTS = " ++ escape (unwords - ( programDefaultArgs ghcProg - ++ hcOptions GHC bi - ++ extensionsToFlags (compiler lbi) (usedExtensions 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 (wrap $ forDeps Installed.includeDirs), - variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions), - 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), - variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi)] - 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 ++ "\'") - boolToYesNo True = "YES" - boolToYesNo False = "NO"