X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=libraries%2FinstallPackage.hs;h=8c6600952eb20d3d61681890cf44a92bc9ebfbb8;hb=a11bb49b97eaba892730baf1565e922715dbc07f;hp=decf2d4b81be1b9dfb8842ace71f56050eb59ff9;hpb=90cc2d2bbe13e3421977013cdfa49630c4817f88;p=ghc-hetmet.git diff --git a/libraries/installPackage.hs b/libraries/installPackage.hs index decf2d4..8c66009 100644 --- a/libraries/installPackage.hs +++ b/libraries/installPackage.hs @@ -1,5 +1,7 @@ import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.ReadE import Distribution.Simple import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo @@ -9,74 +11,56 @@ import Distribution.Simple.Utils import Distribution.Verbosity import System.Environment +-- XXX This will need to be changed +distPref :: FilePath +distPref = defaultDistPref + main :: IO () 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 : + 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 idatadir - idocdir ihtmldir iinterfacedir + iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir + idocdir ihtmldir ihaddockdir _ -> error ("Bad arguments: " ++ show args) mkVerbosity :: [String] -> Verbosity mkVerbosity [] = normal -mkVerbosity ['-':'v':v] = let m = case v of - "" -> Nothing - _ -> Just v - in flagToVerbosity m +mkVerbosity ['-':'v':v] = readEOrFail flagToVerbosity v 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 + -> FilePath -> FilePath -> FilePath -> FilePath -> IO () doInstall verbosity ghcpkg ghcpkgconf destdir topdir - iprefix ibindir ilibdir ilibexecdir idatadir - idocdir ihtmldir iinterfacedir = + 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 { - regPackageDB = Just GlobalPackageDB, - regVerbose = verbosity, - regGenScript = False, - regInPlace = False + 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 - -- base:GHC.Prim, but it doesn't exist, get built, get + -- ghc-prim:GHC.Prim, but it doesn't exist, get built, get -- haddocked, get copied, etc. - pd_reg = if pkgName (package pd) == "base" + pd_reg = if packageName pd == PackageName "ghc-prim" then case library pd of Just lib -> let ems = "GHC.Prim" : exposedModules lib @@ -88,14 +72,15 @@ doInstall verbosity ghcpkg ghcpkgconf destdir topdir -- When coying, we need to actually give a concrete -- directory to copy to rather than "$topdir" 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 + 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 @@ -110,14 +95,15 @@ doInstall verbosity ghcpkg ghcpkgconf destdir topdir 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 + 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' } @@ -134,7 +120,7 @@ replaceTopdir _ p = p -- Get the build info, merging the setup-config and buildinfo files. getConfig :: Verbosity -> IO LocalBuildInfo getConfig verbosity = do - lbi <- getPersistBuildConfig + lbi <- getPersistBuildConfig distPref maybe_infoFile <- defaultHookedPackageDesc case maybe_infoFile of Nothing -> return lbi