X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=libraries%2FinstallPackage.hs;h=3ab4f7eb0c2bbb318040a555df445122d0948dde;hp=612b2fed2fa716e552bef744ea3abc933a1c437c;hb=e25d5095e6fd47e0a02404d9532c2f776d3f8a32;hpb=7a51ca4fd60b28a12d7d2a3ee0f66a0e946dbf79 diff --git a/libraries/installPackage.hs b/libraries/installPackage.hs index 612b2fe..3ab4f7e 100644 --- a/libraries/installPackage.hs +++ b/libraries/installPackage.hs @@ -1,62 +1,103 @@ import Distribution.PackageDescription -import Distribution.Program -import Distribution.Setup +import Distribution.PackageDescription.Parse +import Distribution.ReadE import Distribution.Simple import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Setup +import Distribution.Simple.Utils import Distribution.Verbosity import System.Environment main :: IO () -main = do args <- getArgs - case args of - destdir : pref : ghcpkg : ghcpkgconf : args' -> - let verbosity = case args' of - [] -> normal - ['-':'v':v] -> - let m = case v of - "" -> Nothing - _ -> Just v - in flagToVerbosity m - _ -> error ("Bad arguments: " ++ show args) - in doit destdir pref ghcpkg ghcpkgconf verbosity - _ -> - error "Missing arguments" +main + = do args <- getArgs + case args of + "register" : "--inplace" :args' -> + let verbosity = mkVerbosity args' + in doRegisterInplace verbosity + "install" : ghcpkg : ghcpkgconf : destdir : topdir : + iprefix : ibindir : ilibdir : ilibexecdir : idynlibdir : + idatadir : idocdir : ihtmldir : ihaddockdir : + args' -> + let verbosity = mkVerbosity args' + in doInstall verbosity ghcpkg ghcpkgconf destdir topdir + iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir + idocdir ihtmldir ihaddockdir + _ -> + error ("Bad arguments: " ++ show args) -doit :: FilePath -> FilePath -> FilePath -> FilePath -> Verbosity -> IO () -doit destdir pref ghcpkg ghcpkgconf verbosity = +mkVerbosity :: [String] -> Verbosity +mkVerbosity [] = normal +mkVerbosity ['-':'v':v] = readEOrFail flagToVerbosity v +mkVerbosity args = error ("Bad arguments: " ++ show args) + +doRegisterInplace :: Verbosity -> IO () +doRegisterInplace verbosity = + do lbi <- getConfig verbosity + let registerFlags = defaultRegisterFlags { regInPlace = toFlag True } + pd = localPkgDescr lbi + pd_reg = if pkgName (package pd) == "ghc-prim" + then case library pd of + Just lib -> + let ems = "GHC.Prim" : exposedModules lib + lib' = lib { exposedModules = ems } + in pd { library = Just lib' } + Nothing -> + error "Expected a library, but none found" + else pd + (regHook simpleUserHooks) pd_reg lbi simpleUserHooks registerFlags + return () + +doInstall :: Verbosity -> FilePath -> FilePath -> FilePath -> FilePath + -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath + -> FilePath -> FilePath -> FilePath -> FilePath + -> IO () +doInstall verbosity ghcpkg ghcpkgconf destdir topdir + iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir + idocdir ihtmldir ihaddockdir = do let userHooks = simpleUserHooks copyto = if null destdir then NoCopyDest else CopyTo destdir - copyFlags = (emptyCopyFlags copyto) { - copyVerbose = verbosity + copyFlags = defaultCopyFlags { + copyDest = toFlag copyto, + copyVerbosity = toFlag verbosity } - registerFlags = emptyRegisterFlags { - regUser = MaybeUserGlobal, - regVerbose = verbosity, - regGenScript = False, - regInPlace = False + registerFlags = defaultRegisterFlags { + regPackageDB = toFlag GlobalPackageDB, + regVerbosity = toFlag verbosity, + regGenScript = toFlag $ False, + regInPlace = toFlag $ False } - lbi <- getPersistBuildConfig + lbi <- getConfig verbosity let pd = localPkgDescr lbi i = installDirTemplates lbi - -- XXX This is an almighty hack, shadowing the base - -- Setup.hs hack - mkLib filt = case library pd of - Just lib -> - let ems = filter filt $ exposedModules lib - in lib { - exposedModules = ems - } - Nothing -> - error "Expected a library, but none found" - -- There's no files for GHC.Prim, so we will fail if we - -- try to copy them - pd_copy = pd { library = Just (mkLib ("GHC.Prim" /=)) } - pd_reg = pd { library = Just (mkLib (const True)) } + -- This is an almighty hack. We need to register + -- ghc-prim:GHC.Prim, but it doesn't exist, get built, get + -- haddocked, get copied, etc. + pd_reg = if pkgName (package pd) == "ghc-prim" + then case library pd of + Just lib -> + let ems = "GHC.Prim" : exposedModules lib + lib' = lib { exposedModules = ems } + in pd { library = Just lib' } + Nothing -> + error "Expected a library, but none found" + else pd -- When coying, we need to actually give a concrete -- directory to copy to rather than "$topdir" - i_copy = i { prefixDirTemplate = toPathTemplate pref } + toPathTemplate' = toPathTemplate . replaceTopdir topdir + i_copy = i { prefix = toPathTemplate' iprefix, + bindir = toPathTemplate' ibindir, + libdir = toPathTemplate' ilibdir, + dynlibdir = toPathTemplate' idynlibdir, + libexecdir = toPathTemplate' ilibexecdir, + datadir = toPathTemplate' idatadir, + docdir = toPathTemplate' idocdir, + htmldir = toPathTemplate' ihtmldir, + haddockdir = toPathTemplate' ihaddockdir + } lbi_copy = lbi { installDirTemplates = i_copy } -- When we run GHC we give it a $topdir that includes the -- $compiler/lib/ part of libsubdir, so we only want the @@ -66,14 +107,41 @@ doit destdir pref ghcpkg ghcpkgconf verbosity = prog = ConfiguredProgram { programId = programName ghcPkgProgram, programVersion = Nothing, - programArgs = ["--global-conf", ghcpkgconf], + programArgs = ["--force", "--global-conf", ghcpkgconf], programLocation = UserSpecified ghcpkg } progs' = updateProgram prog progs - i_reg = i { libSubdirTemplate = toPathTemplate "$pkgid" } + i_reg = i { prefix = toPathTemplate iprefix, + bindir = toPathTemplate ibindir, + libdir = toPathTemplate ilibdir, + dynlibdir = toPathTemplate idynlibdir, + libexecdir = toPathTemplate ilibexecdir, + datadir = toPathTemplate idatadir, + docdir = toPathTemplate idocdir, + htmldir = toPathTemplate ihtmldir, + haddockdir = toPathTemplate ihaddockdir + } lbi_reg = lbi { installDirTemplates = i_reg, withPrograms = progs' } - (copyHook simpleUserHooks) pd_copy lbi_copy userHooks copyFlags - (regHook simpleUserHooks) pd_reg lbi_reg userHooks registerFlags + (copyHook simpleUserHooks) pd lbi_copy userHooks copyFlags + (regHook simpleUserHooks) pd_reg lbi_reg userHooks registerFlags return () +replaceTopdir :: FilePath -> FilePath -> FilePath +replaceTopdir topdir ('$':'t':'o':'p':'d':'i':'r':p) = topdir ++ p +replaceTopdir topdir ('$':'h':'t':'t':'p':'t':'o':'p':'d':'i':'r':p) + = topdir ++ p +replaceTopdir _ p = p + +-- Get the build info, merging the setup-config and buildinfo files. +getConfig :: Verbosity -> IO LocalBuildInfo +getConfig verbosity = do + lbi <- getPersistBuildConfig + maybe_infoFile <- defaultHookedPackageDesc + case maybe_infoFile of + Nothing -> return lbi + Just infoFile -> do + hbi <- readHookedBuildInfo verbosity infoFile + return lbi { localPkgDescr = updatePackageDescription hbi (localPkgDescr lbi)} + +