X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=libraries%2FinstallPackage.hs;h=3ab4f7eb0c2bbb318040a555df445122d0948dde;hp=dcba287ddff46567912754e96f325cc5a524a85a;hb=e25d5095e6fd47e0a02404d9532c2f776d3f8a32;hpb=2f181d8ddcd9a88f487a50d64ef682efd55da462 diff --git a/libraries/installPackage.hs b/libraries/installPackage.hs index dcba287..3ab4f7e 100644 --- a/libraries/installPackage.hs +++ b/libraries/installPackage.hs @@ -1,60 +1,147 @@ import Distribution.PackageDescription -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 - let verbosity = case args of - [] -> normal - ['-':'v':v] -> - let m = case v of - "" -> Nothing - _ -> Just v - in flagToVerbosity m - _ -> error ("Bad arguments: " ++ show args) - userHooks = simpleUserHooks - installFlags = InstallFlags { - installUserFlags = MaybeUserGlobal, - installVerbose = verbosity - } - pdFile <- defaultPackageDesc verbosity - pd <- readPackageDescription verbosity pdFile - lbi <- getPersistBuildConfig - let -- XXX This is an almighty hack, shadowing the base Setup.hs hack - lib' = case library pd of - Just lib -> - lib { - exposedModules = filter (("GHC.Prim" /=)) - $ exposedModules lib - } - Nothing -> - error "Expected a library, but none found" - pd' = pd { library = Just lib' } - -- When installing we need to use the non-inplace ghc-pkg. - -- We also set the compiler to be non-inplace, but that - -- probably doesn't matter. - c = compiler lbi - c' = c { compilerPath = dropInPlace (compilerPath c), - compilerPkgTool = dropInPlace (compilerPkgTool c) +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) + +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 = defaultCopyFlags { + copyDest = toFlag copyto, + copyVerbosity = toFlag verbosity + } + registerFlags = defaultRegisterFlags { + regPackageDB = toFlag GlobalPackageDB, + regVerbosity = toFlag verbosity, + regGenScript = toFlag $ False, + regInPlace = toFlag $ False + } + lbi <- getConfig verbosity + let pd = localPkgDescr lbi + i = installDirTemplates lbi + -- 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" + 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 + -- $pkgid part in the package.conf file. This is a bit of + -- a hack, really. + progs = withPrograms lbi + prog = ConfiguredProgram { + programId = programName ghcPkgProgram, + programVersion = Nothing, + programArgs = ["--force", "--global-conf", ghcpkgconf], + programLocation = UserSpecified ghcpkg } - lbi' = lbi { compiler = c' } - (instHook simpleUserHooks) pd' lbi' userHooks installFlags - -dropInPlace :: FilePath -> FilePath -dropInPlace "" = "" -dropInPlace xs@(x:xs') = case dropPrefix "-inplace" xs of - Nothing -> x : dropInPlace xs' - Just xs'' -> dropInPlace xs'' - -dropPrefix :: Eq a => [a] -> [a] -> Maybe [a] -dropPrefix [] ys = Just ys -dropPrefix (x:xs) (y:ys) - | x == y = dropPrefix xs ys -dropPrefix _ _ = Nothing + progs' = updateProgram prog progs + 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 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)} +