X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=libraries%2FinstallPackage.hs;h=decf2d4b81be1b9dfb8842ace71f56050eb59ff9;hb=a9f9a7544a9605d0af16adf79abdfe8d99b0bb3d;hp=5c83e7ac257b3ea5ae07a75426bb83cf0e8a6753;hpb=916a1cabd18ccd9ffee4e9cc279aefb20f531fbf;p=ghc-hetmet.git diff --git a/libraries/installPackage.hs b/libraries/installPackage.hs index 5c83e7a..decf2d4 100644 --- a/libraries/installPackage.hs +++ b/libraries/installPackage.hs @@ -1,81 +1,145 @@ import Distribution.PackageDescription -import Distribution.Setup 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 -import System.Info main :: IO () -main = do args <- getArgs - case args of - pref : ghcpkg : 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 pref ghcpkg 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 : + idatadir : idocdir : ihtmldir : iinterfacedir : + args' -> + let verbosity = mkVerbosity args' + in doInstall verbosity ghcpkg ghcpkgconf destdir topdir + iprefix ibindir ilibdir ilibexecdir idatadir + idocdir ihtmldir iinterfacedir + _ -> + error ("Bad arguments: " ++ show args) -doit :: FilePath -> FilePath -> Verbosity -> IO () -doit pref ghcpkg verbosity = +mkVerbosity :: [String] -> Verbosity +mkVerbosity [] = normal +mkVerbosity ['-':'v':v] = let m = case v of + "" -> Nothing + _ -> Just v + in flagToVerbosity m +mkVerbosity args = error ("Bad arguments: " ++ show args) + +doRegisterInplace :: Verbosity -> IO () +doRegisterInplace verbosity = + do lbi <- getConfig verbosity + let registerFlags = emptyRegisterFlags { regInPlace = True } + pd = localPkgDescr lbi + pd_reg = if pkgName (package pd) == "base" + 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 + -> IO () +doInstall verbosity ghcpkg ghcpkgconf destdir topdir + iprefix ibindir ilibdir ilibexecdir idatadir + idocdir ihtmldir iinterfacedir = do let userHooks = simpleUserHooks - copyFlags = CopyFlags { - copyDest = NoCopyDest, + copyto = if null destdir then NoCopyDest else CopyTo destdir + copyFlags = (emptyCopyFlags copyto) { copyVerbose = verbosity } - registerFlags = RegisterFlags { - regUser = MaybeUserGlobal, + registerFlags = emptyRegisterFlags { + regPackageDB = Just GlobalPackageDB, + regVerbose = verbosity, regGenScript = False, - regInPlace = False, - regWithHcPkg = Just ghcpkg, - regVerbose = verbosity + regInPlace = False } - pdFile <- defaultPackageDesc verbosity - pd <- readPackageDescription verbosity pdFile - lbi <- getPersistBuildConfig - let -- XXX These are almighty hacks, shadowing the base - -- Setup.hs hacks - extraExtraLibs = if (os == "mingw32") && - (pkgName (package pd) == "base") - then ["wsock32", "msvcrt", "kernel32", - "user32", "shell32"] - else [] - mkLib filt = case library pd of - Just lib -> - let ems = filter filt $ exposedModules lib - lib_bi = libBuildInfo lib - lib_bi' = lib_bi { - extraLibs = extraExtraLibs - ++ extraLibs lib_bi - } - in lib { - exposedModules = ems, - libBuildInfo = lib_bi' - } - 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)) } + lbi <- getConfig verbosity + let pd = localPkgDescr lbi + i = installDirTemplates lbi + -- This is an almighty hack. We need to register + -- base:GHC.Prim, but it doesn't exist, get built, get + -- haddocked, get copied, etc. + pd_reg = if pkgName (package pd) == "base" + 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" - lbi_copy = lbi { prefix = pref } + toPathTemplate' = toPathTemplate . replaceTopdir topdir + i_copy = i { prefixDirTemplate = toPathTemplate' iprefix, + binDirTemplate = toPathTemplate' ibindir, + libDirTemplate = toPathTemplate' ilibdir, + libexecDirTemplate = toPathTemplate' ilibexecdir, + dataDirTemplate = toPathTemplate' idatadir, + docDirTemplate = toPathTemplate' idocdir, + htmlDirTemplate = toPathTemplate' ihtmldir, + interfaceDirTemplate = toPathTemplate' iinterfacedir + } + 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 -- $pkgid part in the package.conf file. This is a bit of -- a hack, really. - lbi_reg = lbi { libsubdir = "$pkgid" } - (copyHook simpleUserHooks) pd_copy lbi_copy userHooks copyFlags - (regHook simpleUserHooks) pd_reg lbi_reg userHooks registerFlags + progs = withPrograms lbi + prog = ConfiguredProgram { + programId = programName ghcPkgProgram, + programVersion = Nothing, + programArgs = ["--force", "--global-conf", ghcpkgconf], + programLocation = UserSpecified ghcpkg + } + progs' = updateProgram prog progs + i_reg = i { prefixDirTemplate = toPathTemplate iprefix, + binDirTemplate = toPathTemplate ibindir, + libDirTemplate = toPathTemplate ilibdir, + libexecDirTemplate = toPathTemplate ilibexecdir, + dataDirTemplate = toPathTemplate idatadir, + docDirTemplate = toPathTemplate idocdir, + htmlDirTemplate = toPathTemplate ihtmldir, + interfaceDirTemplate = toPathTemplate iinterfacedir + } + lbi_reg = lbi { installDirTemplates = i_reg, + withPrograms = progs' } + (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)} + +