X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=libraries%2FinstallPackage.hs;h=5946a6b3dbfce2a9d4c6add784245a7dafc08d4f;hb=6cc7a2957040c2d751a14c3776cf144152be4dd0;hp=31d9ed1a2de33b374ed5bbbb0d8ad0422897bcef;hpb=d4a7ecf4b2d70e89557b4de7c621b6b3ec0caa22;p=ghc-hetmet.git diff --git a/libraries/installPackage.hs b/libraries/installPackage.hs index 31d9ed1..5946a6b 100644 --- a/libraries/installPackage.hs +++ b/libraries/installPackage.hs @@ -1,42 +1,55 @@ import Distribution.PackageDescription -import Distribution.Program -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 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 + destdir : ipref : ibindir : ilibdir : ilibexecdir + : idatadir : idocdir : ihtmldir_copy : ihtmldir_reg + : 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 ipref ibindir ilibdir + ilibexecdir idatadir idocdir + ihtmldir_copy ihtmldir_reg + ghcpkg ghcpkgconf verbosity + _ -> + error "Missing arguments" -doit :: FilePath -> FilePath -> FilePath -> FilePath -> Verbosity -> IO () -doit destdir pref ghcpkg ghcpkgconf verbosity = +doit :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath + -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath + -> FilePath + -> Verbosity + -> IO () +doit destdir ipref ibindir ilibdir ilibexecdir idatadir idocdir + ihtmldir_copy ihtmldir_reg ghcpkg ghcpkgconf verbosity = do let userHooks = simpleUserHooks - copyFlags = (emptyCopyFlags (CopyTo destdir)) { + copyto = if null destdir then NoCopyDest else CopyTo destdir + copyFlags = (emptyCopyFlags copyto) { copyVerbose = verbosity } registerFlags = emptyRegisterFlags { - regUser = MaybeUserGlobal, + regPackageDB = Just GlobalPackageDB, regVerbose = verbosity, regGenScript = False, regInPlace = False } - lbi <- getPersistBuildConfig + lbi <- getConfig verbosity let pd = localPkgDescr lbi i = installDirTemplates lbi -- XXX This is an almighty hack, shadowing the base @@ -55,7 +68,14 @@ doit destdir pref ghcpkg ghcpkgconf verbosity = pd_reg = pd { library = Just (mkLib (const True)) } -- When coying, we need to actually give a concrete -- directory to copy to rather than "$topdir" - i_copy = i { prefixDirTemplate = toPathTemplate pref } + i_copy = i { prefixDirTemplate = toPathTemplate ipref, + binDirTemplate = toPathTemplate ibindir, + libDirTemplate = toPathTemplate ilibdir, + libexecDirTemplate = toPathTemplate ilibexecdir, + dataDirTemplate = toPathTemplate idatadir, + docDirTemplate = toPathTemplate idocdir, + htmlDirTemplate = toPathTemplate ihtmldir_copy + } 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 @@ -65,14 +85,33 @@ 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 { prefixDirTemplate = toPathTemplate ipref, + binDirTemplate = toPathTemplate ibindir, + libDirTemplate = toPathTemplate ilibdir, + libexecDirTemplate = toPathTemplate ilibexecdir, + dataDirTemplate = toPathTemplate idatadir, + docDirTemplate = toPathTemplate idocdir, + htmlDirTemplate = toPathTemplate ihtmldir_reg + } lbi_reg = lbi { installDirTemplates = i_reg, withPrograms = progs' } (copyHook simpleUserHooks) pd_copy lbi_copy userHooks copyFlags (regHook simpleUserHooks) pd_reg lbi_reg userHooks registerFlags return () +-- 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)} + +