--- /dev/null
+
+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 <configure-args> -- <distdir> <directory>...",
+ " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
+ " ghc-cabal hscolour <distdir> <directory> <args>..."]
+
+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_<pkg>.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"
projects / ghc-hetmet.git / blobdiff