Tell ghc-cabal what strip program to use
[ghc-hetmet.git] / utils / ghc-cabal / ghc-cabal.hs
index b376950..ef4e989 100644 (file)
@@ -34,14 +34,18 @@ main = do args <- getArgs
                   runHaddock distDir dir args'
               "check" : dir : [] ->
                   doCheck dir
-              "install" : ghc : ghcpkg : topdir : directory : distDir
-                        : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
-                  doInstall ghc ghcpkg topdir directory distDir
-                            myDestDir myPrefix myLibdir myDocdir args'
+              "install" : ghc : ghcpkg : strip : topdir : directory : distDir
+                        : myDestDir : myPrefix : myLibdir : myDocdir
+                        : relocatableBuild : args' ->
+                  doInstall ghc ghcpkg strip topdir directory distDir
+                            myDestDir myPrefix myLibdir myDocdir
+                            relocatableBuild args'
               "configure" : args' -> case break (== "--") args' of
                    (config_args, "--" : distdir : directories) ->
                        mapM_ (generate config_args distdir) directories
                    _ -> die syntax_error
+              "sdist" : dir : distDir : [] ->
+                  doSdist dir distDir
               _ -> die syntax_error
 
 syntax_error :: [String]
@@ -50,7 +54,7 @@ syntax_error =
      "        ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
      "        ghc-cabal haddock <distdir> <directory> <args>..."]
 
-die :: [String] -> IO ()
+die :: [String] -> IO a
 die errs = do mapM_ (hPutStrLn stderr) errs
               exitWith (ExitFailure 1)
 
@@ -69,6 +73,30 @@ withCurrentDirectory directory io
 userHooks :: UserHooks
 userHooks = autoconfUserHooks
 
+runDefaultMain :: IO ()
+runDefaultMain
+ = do let verbosity = normal
+      gpdFile <- defaultPackageDesc verbosity
+      gpd <- readPackageDescription verbosity gpdFile
+      case buildType (flattenPackageDescription gpd) of
+          Just Configure -> defaultMainWithHooks autoconfUserHooks
+          -- time has a "Custom" Setup.hs, but it's actually Configure
+          -- plus a "./Setup test" hook. However, Cabal is also
+          -- "Custom", but doesn't have a configure script.
+          Just Custom ->
+              do configureExists <- doesFileExist "configure"
+                 if configureExists
+                     then defaultMainWithHooks autoconfUserHooks
+                     else defaultMain
+          -- not quite right, but good enough for us:
+          _ -> defaultMain
+
+doSdist :: FilePath -> FilePath -> IO ()
+doSdist directory distDir
+ = withCurrentDirectory directory
+ $ withArgs (["sdist", "--builddir", distDir])
+            runDefaultMain
+
 doCheck :: FilePath -> IO ()
 doCheck directory
  = withCurrentDirectory directory
@@ -111,21 +139,37 @@ runHaddock distdir directory args
           = f pd lbi us flags
 
 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
-          -> FilePath -> FilePath -> FilePath -> FilePath -> [String]
+          -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
+          -> String -> [String]
           -> IO ()
-doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args
+doInstall ghc ghcpkg strip topdir directory distDir
+          myDestDir myPrefix myLibdir myDocdir
+          relocatableBuildStr args
  = withCurrentDirectory directory $ do
-     defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
-                                     ++ (if null myDestDir then []
-                                           else ["--destdir", myDestDir])
-                                     ++ args)
-     defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
-    where
-      hooks = userHooks {
-                  copyHook = noGhcPrimHook (modHook (copyHook userHooks)),
-                  regHook  = modHook (regHook userHooks)
-              }
+     relocatableBuild <- case relocatableBuildStr of
+                         "YES" -> return True
+                         "NO"  -> return False
+                         _ -> die ["Bad relocatableBuildStr: " ++
+                                   show relocatableBuildStr]
+     let copyArgs = ["copy", "--builddir", distDir]
+                 ++ (if null myDestDir
+                     then []
+                     else ["--destdir", myDestDir])
+                 ++ args
+         regArgs = "register" : "--builddir" : distDir : args
+         copyHooks = userHooks {
+                         copyHook = noGhcPrimHook
+                                  $ modHook False
+                                  $ copyHook userHooks
+                     }
+         regHooks = userHooks {
+                        regHook = modHook relocatableBuild
+                                $ regHook userHooks
+                    }
 
+     defaultMainWithHooksArgs copyHooks copyArgs
+     defaultMainWithHooksArgs regHooks  regArgs
+    where
       noGhcPrimHook f pd lbi us flags
               = let pd'
                      | packageName pd == PackageName "ghc-prim" =
@@ -139,14 +183,25 @@ doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocd
                             error "Expected a library, but none found"
                      | otherwise = pd
                 in f pd' lbi us flags
-      modHook f pd lbi us flags
+      modHook relocatableBuild f pd lbi us flags
        = do let verbosity = normal
                 idts = installDirTemplates lbi
-                idts' = idts { prefix    = toPathTemplate myPrefix,
-                               libdir    = toPathTemplate myLibdir,
-                               libsubdir = toPathTemplate "$pkgid",
-                               docdir    = toPathTemplate (myDocdir </> "$pkg"),
-                               htmldir   = toPathTemplate "$docdir" }
+                idts' = idts {
+                            prefix    = toPathTemplate $
+                                            if relocatableBuild
+                                            then "$topdir"
+                                            else myPrefix,
+                            libdir    = toPathTemplate $
+                                            if relocatableBuild
+                                            then "$topdir"
+                                            else myLibdir,
+                            libsubdir = toPathTemplate "$pkgid",
+                            docdir    = toPathTemplate $
+                                            if relocatableBuild
+                                            then "$topdir/$pkg"
+                                            else (myDocdir </> "$pkg"),
+                            htmldir   = toPathTemplate "$docdir"
+                        }
                 progs = withPrograms lbi
                 ghcProg = ConfiguredProgram {
                               programId = programName ghcProgram,
@@ -165,18 +220,26 @@ doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocd
                                                   else [],
                                  programLocation = UserSpecified ghcpkg
                              }
+                stripProg = ConfiguredProgram {
+                              programId = programName stripProgram,
+                              programVersion = Nothing,
+                              programArgs = [],
+                              programLocation = UserSpecified strip
+                          }
                 progs' = updateProgram ghcProg
-                       $ updateProgram ghcPkgProg progs
+                       $ updateProgram ghcPkgProg
+                       $ updateProgram stripProg
+                         progs
             instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
-            let installedPkgs' = PackageIndex.listToInstalledPackageIndex
-                                     instInfos
+            let installedPkgs' = PackageIndex.fromList instInfos
             let mlc = libraryConfig lbi
                 mlc' = case mlc of
                        Just lc ->
-                           let cipds = componentInstalledPackageDeps lc
-                               cipds' = map (fixupPackageId instInfos) cipds
+                           let cipds = componentPackageDeps lc
+                               cipds' = [ (fixupPackageId instInfos ipid, pid)
+                                        | (ipid,pid) <- cipds ]
                            in Just $ lc {
-                                         componentInstalledPackageDeps = cipds'
+                                         componentPackageDeps = cipds'
                                      }
                        Nothing -> Nothing
                 lbi' = lbi {
@@ -215,25 +278,11 @@ generate :: [String] -> FilePath -> FilePath -> IO ()
 generate config_args distdir directory
  = withCurrentDirectory directory
  $ do let verbosity = normal
-      gpdFile <- defaultPackageDesc verbosity
-      gpd <- readPackageDescription verbosity gpdFile
-
       -- XXX We shouldn't just configure with the default flags
       -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
       -- aren't going to work when the deps aren't built yet
       withArgs (["configure", "--distdir", distdir] ++ config_args)
-          (case buildType (flattenPackageDescription gpd) of
-              Just Configure -> defaultMainWithHooks autoconfUserHooks
-              -- time has a "Custom" Setup.hs, but it's actually Configure
-              -- plus a "./Setup test" hook. However, Cabal is also
-              -- "Custom", but doesn't have a configure script.
-              Just Custom ->
-                  do configureExists <- doesFileExist "configure"
-                     if configureExists
-                         then defaultMainWithHooks autoconfUserHooks
-                         else defaultMain
-              -- not quite right, but good enough for us:
-              _ -> defaultMain)
+               runDefaultMain
 
       lbi <- getPersistBuildConfig distdir
       let pd0 = localPkgDescr lbi
@@ -294,12 +343,11 @@ generate config_args distdir directory
           -- stricter than gnu ld). Thus we remove the ldOptions for
           -- GHC's rts package:
           hackRtsPackage index =
-            case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
-              [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
+            case PackageIndex.lookupPackageName index (PackageName "rts") of
+              [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
               _ -> error "No (or multiple) ghc rts package is registered!!"
 
-          dep_ids = map (packageId.getLocalPackageInfo lbi) $
-                       externalPackageDeps lbi
+          dep_ids = map snd (externalPackageDeps lbi)
 
       let variablePrefix = directory ++ '_':distdir
       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
@@ -323,12 +371,12 @@ generate config_args distdir directory
                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
-                variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
+                variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
-                variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
+                variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (wrap $ forDeps Installed.libraryDirs),
                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
       writeFile (distdir ++ "/package-data.mk") $ unlines xs
   where
      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
-
+     wrap = map (\s -> "\'" ++ s ++ "\'")