Make ghc-cabal's `System.Directory` import more robust
[ghc.git] / utils / ghc-cabal / Main.hs
index 3ecae9b..6da7733 100644 (file)
@@ -6,11 +6,15 @@ import Distribution.PackageDescription
 import Distribution.PackageDescription.Check hiding (doesFileExist)
 import Distribution.PackageDescription.Configuration
 import Distribution.PackageDescription.Parse
+import Distribution.Package
+import Distribution.System
 import Distribution.Simple
 import Distribution.Simple.Configure
 import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.GHC
 import Distribution.Simple.Program
 import Distribution.Simple.Program.HcPkg
+import Distribution.Simple.Setup (ConfigFlags(configStripLibs), fromFlag, toFlag)
 import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8)
 import Distribution.Simple.Build (writeAutogenFiles)
 import Distribution.Simple.Register
@@ -19,40 +23,40 @@ import Distribution.Verbosity
 import qualified Distribution.InstalledPackageInfo as Installed
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 
+import Control.Exception (bracket)
 import Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.List
 import Data.Maybe
 import System.IO
-import System.Directory
+import System.Directory (setCurrentDirectory, getCurrentDirectory, doesFileExist)
 import System.Environment
-import System.Exit
+import System.Exit      (exitWith, ExitCode(..))
 import System.FilePath
 
 main :: IO ()
 main = do hSetBuffering stdout LineBuffering
           args <- getArgs
           case args of
-              "hscolour" : distDir : dir : args' ->
-                  runHsColour distDir dir args'
+              "hscolour" : dir : distDir : args' ->
+                  runHsColour dir distDir args'
               "check" : dir : [] ->
                   doCheck dir
-              "copy" : strip : directory : distDir
-                     : myDestDir : myPrefix : myLibdir : myDocdir
-                     : args' ->
-                  doCopy strip directory distDir
-                         myDestDir myPrefix myLibdir myDocdir
+              "copy" : dir : distDir
+                     : strip : myDestDir : myPrefix : myLibdir : myDocdir
+                     : ghcLibWays : args' ->
+                  doCopy dir distDir
+                         strip myDestDir myPrefix myLibdir myDocdir
+                         ("dyn" `elem` words ghcLibWays)
                          args'
-              "register" : ghc : ghcpkg : topdir : directory : distDir
+              "register" : dir : distDir : ghc : ghcpkg : topdir
                          : myDestDir : myPrefix : myLibdir : myDocdir
                          : relocatableBuild : args' ->
-                  doRegister ghc ghcpkg topdir directory distDir
+                  doRegister dir distDir ghc ghcpkg topdir
                              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
+              "configure" : dir : distDir : dll0Modules : config_args ->
+                  generate dir distDir dll0Modules config_args
               "sdist" : dir : distDir : [] ->
                   doSdist dir distDir
               ["--version"] ->
@@ -69,14 +73,10 @@ die :: [String] -> IO a
 die errs = do mapM_ (hPutStrLn stderr) errs
               exitWith (ExitFailure 1)
 
--- XXX Should use bracket
 withCurrentDirectory :: FilePath -> IO a -> IO a
 withCurrentDirectory directory io
- = do curDirectory <- getCurrentDirectory
-      setCurrentDirectory directory
-      r <- io
-      setCurrentDirectory curDirectory
-      return r
+ = bracket (getCurrentDirectory) (setCurrentDirectory)
+           (const (setCurrentDirectory directory >> io))
 
 -- We need to use the autoconfUserHooks, as the packages that use
 -- configure can create a .buildinfo file, and we need any info that
@@ -114,26 +114,25 @@ doCheck directory
  $ do let verbosity = normal
       gpdFile <- defaultPackageDesc verbosity
       gpd <- readPackageDescription verbosity gpdFile
-      case partition isFailure $ checkPackage gpd Nothing of
-          ([],   [])       -> return ()
-          ([],   warnings) -> mapM_ print warnings
-          (errs, _)        -> do mapM_ print errs
-                                 exitWith (ExitFailure 1)
+      case filter isFailure $ checkPackage gpd Nothing of
+          []   -> return ()
+          errs -> mapM_ print errs >> exitWith (ExitFailure 1)
     where isFailure (PackageDistSuspicious {}) = False
+          isFailure (PackageDistSuspiciousWarn {}) = False
           isFailure _ = True
 
 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
-runHsColour distdir directory args
+runHsColour directory distdir args
  = withCurrentDirectory directory
  $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
 
 doCopy :: FilePath -> FilePath
-       -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
+       -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> Bool
        -> [String]
        -> IO ()
-doCopy strip directory distDir
-          myDestDir myPrefix myLibdir myDocdir
-          args
+doCopy directory distDir
+       strip myDestDir myPrefix myLibdir myDocdir withSharedLibs
+       args
  = withCurrentDirectory directory $ do
      let copyArgs = ["copy", "--builddir", distDir]
                  ++ (if null myDestDir
@@ -168,20 +167,30 @@ doCopy strip directory distDir
                                                  (installDirTemplates lbi)
                 progs = withPrograms lbi
                 stripProgram' = stripProgram {
-                    programFindLocation = \_ -> return (Just strip) }
+                    programFindLocation = \_ -> return (Just strip) }
 
             progs' <- configureProgram verbosity stripProgram' progs
             let lbi' = lbi {
                                withPrograms = progs',
-                               installDirTemplates = idts
+                               installDirTemplates = idts,
+                               configFlags = cfg,
+                               stripLibs = fromFlag (configStripLibs cfg),
+                               withSharedLib = withSharedLibs
                            }
+
+                -- This hack allows to interpret the "strip"
+                -- command-line argument being set to ':' to signify
+                -- disabled library stripping
+                cfg | strip == ":" = (configFlags lbi) { configStripLibs = toFlag False }
+                    | otherwise    = configFlags lbi
+
             f pd lbi' us flags
 
 doRegister :: FilePath -> FilePath -> FilePath -> FilePath
            -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
            -> String -> [String]
            -> IO ()
-doRegister ghc ghcpkg topdir directory distDir
+doRegister directory distDir ghc ghcpkg topdir
            myDestDir myPrefix myLibdir myDocdir
            relocatableBuildStr args
  = withCurrentDirectory directory $ do
@@ -206,24 +215,21 @@ doRegister ghc ghcpkg topdir directory distDir
                 progs = withPrograms lbi
                 ghcpkgconf = topdir </> "package.conf.d"
                 ghcProgram' = ghcProgram {
-                    programPostConf = \_ _ -> return ["-B" ++ topdir],
-                    programFindLocation = \_ -> return (Just ghc) }
+                    programPostConf = \_ cp -> return cp { programDefaultArgs = ["-B" ++ topdir] },
+                    programFindLocation = \_ -> return (Just ghc) }
                 ghcPkgProgram' = ghcPkgProgram {
-                    programPostConf = \_ _ -> return $ ["--global-package-db", ghcpkgconf]
-                                                    ++ ["--force" | not (null myDestDir) ],
-                    programFindLocation = \_ -> return (Just ghcpkg) }
+                    programPostConf = \_ cp -> return cp { programDefaultArgs =
+                                                                ["--global-package-db", ghcpkgconf]
+                                                                ++ ["--force" | not (null myDestDir) ] },
+                    programFindLocation = \_ _ -> return (Just ghcpkg) }
                 configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps
 
             progs' <- configurePrograms [ghcProgram', ghcPkgProgram'] progs
-            let Just ghcPkgProg = lookupProgram ghcPkgProgram' progs'
-            instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
+            instInfos <- dump (hcPkgInfo progs') verbosity GlobalPackageDB
             let installedPkgs' = PackageIndex.fromList instInfos
             let updateComponentConfig (cn, clbi, deps)
                     = (cn, updateComponentLocalBuildInfo clbi, deps)
-                updateComponentLocalBuildInfo (ComponentLocalBuildInfo cpds)
-                    = ComponentLocalBuildInfo
-                          [ (fixupPackageId instInfos ipid, pid)
-                          | (ipid,pid) <- cpds ]
+                updateComponentLocalBuildInfo clbi = clbi -- TODO: remove
                 ccs' = map updateComponentConfig (componentsConfigs lbi)
                 lbi' = lbi {
                                componentsConfigs = ccs',
@@ -246,7 +252,7 @@ updateInstallDirTemplates relocatableBuild myPrefix myLibdir myDocdir idts
                           if relocatableBuild
                           then "$topdir"
                           else myLibdir,
-          libsubdir = toPathTemplate "$pkgid",
+          libsubdir = toPathTemplate "$libname",
           docdir    = toPathTemplate $
                           if relocatableBuild
                           then "$topdir/../doc/html/libraries/$pkgid"
@@ -254,43 +260,41 @@ updateInstallDirTemplates relocatableBuild myPrefix myLibdir myDocdir idts
           htmldir   = toPathTemplate "$docdir"
       }
 
--- The packages are built with the package ID ending in "-inplace", but
--- when they're installed they get the package hash appended. We need to
--- fix up the package deps so that they use the hash package IDs, not
--- the inplace package IDs.
-fixupPackageId :: [Installed.InstalledPackageInfo]
-               -> InstalledPackageId
-               -> InstalledPackageId
-fixupPackageId _ x@(InstalledPackageId ipi)
- | "builtin_" `isPrefixOf` ipi = x
-fixupPackageId ipinfos (InstalledPackageId ipi)
- = case stripPrefix (reverse "-inplace") $ reverse ipi of
-   Nothing ->
-       error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
-   Just x ->
-       let ipi' = reverse ('-' : x)
-           f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
-                                   y@(InstalledPackageId ipinfoid)
-                                    | ipi' `isPrefixOf` ipinfoid ->
-                                       y
-                                   _ ->
-                                       f ipinfos'
-           f [] = error ("Installed package ID not registered: " ++ show ipi)
-       in f ipinfos
-
-generate :: [String] -> FilePath -> FilePath -> IO ()
-generate config_args distdir directory
+-- On Windows we need to split the ghc package into 2 pieces, or the
+-- DLL that it makes contains too many symbols (#5987). There are
+-- therefore 2 libraries, not just the 1 that Cabal assumes.
+mangleIPI :: FilePath -> FilePath -> LocalBuildInfo
+          -> Installed.InstalledPackageInfo -> Installed.InstalledPackageInfo
+mangleIPI "compiler" "stage2" lbi ipi
+ | isWindows =
+    -- Cabal currently only ever installs ONE Haskell library, c.f.
+    -- the code in Cabal.Distribution.Simple.Register.  If it
+    -- ever starts installing more we'll have to find the
+    -- library that's too big and split that.
+    let [old_hslib] = Installed.hsLibraries ipi
+    in ipi {
+        Installed.hsLibraries = [old_hslib, old_hslib ++ "-0"]
+    }
+    where isWindows = case hostPlatform lbi of
+                      Platform _ Windows -> True
+                      _                  -> False
+mangleIPI _ _ _ ipi = ipi
+
+generate :: FilePath -> FilePath -> String -> [String] -> IO ()
+generate directory distdir dll0Modules config_args
  = withCurrentDirectory directory
  $ do let verbosity = normal
       -- 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)
+      withArgs (["configure", "--distdir", distdir, "--ipid", "$pkg-$version"] ++ config_args)
                runDefaultMain
 
       lbi <- getPersistBuildConfig distdir
       let pd0 = localPkgDescr lbi
 
+      writePersistBuildConfig distdir lbi
+
       hooked_bi <-
            if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
            then do
@@ -306,33 +310,22 @@ generate config_args distdir directory
       -- generate Paths_<pkg>.hs and cabal-macros.h
       writeAutogenFiles verbosity pd lbi
 
-      let findLibraryConfig []                         = Nothing
-          findLibraryConfig ((CLibName, clbi, _) :  _) = Just clbi
-          findLibraryConfig (_                   : xs) = findLibraryConfig xs
-          mLibraryConfig = findLibraryConfig (componentsConfigs lbi)
-
       -- generate inplace-pkg-config
-      case (library pd, mLibraryConfig) of
-          (Nothing, Nothing) -> return ()
-          (Just lib, Just clbi) -> do
-              cwd <- getCurrentDirectory
-              let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
-              let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
-                                         pd lib lbi clbi
-                  final_ipi = installedPkgInfo {
-                                  Installed.installedPackageId = ipid,
-                                  Installed.haddockHTMLs = []
-                              }
-                  content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
-              writeFileAtomic (distdir </> "inplace-pkg-config") (BS.pack $ toUTF8 content)
-          (Just _, Nothing) ->
-              -- There is a library, but we aren't building it
-              -- Happens e.g. with haddock, which has both a library
-              -- and executable in its .cabal file.
-              return ()
-          (Nothing, Just _) -> die ["Library local build info, but no library in package description"]
+      withLibLBI pd lbi $ \lib clbi ->
+          do cwd <- getCurrentDirectory
+             let ipid = ComponentId (display (packageId pd))
+             let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
+                                        pd (Installed.AbiHash "") lib lbi clbi
+                 final_ipi = mangleIPI directory distdir lbi $ installedPkgInfo {
+                                 Installed.installedComponentId = ipid,
+                                 Installed.compatPackageKey = ipid,
+                                 Installed.haddockHTMLs = []
+                             }
+                 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
+             writeFileAtomic (distdir </> "inplace-pkg-config") (BS.pack $ toUTF8 content)
 
       let
+          comp = compiler lbi
           libBiModules lib = (libBuildInfo lib, libModules lib)
           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
           biModuless = (maybeToList $ fmap libBiModules $ library pd)
@@ -375,10 +368,25 @@ generate config_args distdir directory
 
           dep_ids  = map snd (externalPackageDeps lbi)
           deps     = map display dep_ids
+          dep_direct = map (fromMaybe (error "ghc-cabal: dep_keys failed")
+                           . PackageIndex.lookupComponentId
+                                            (installedPkgs lbi)
+                           . fst)
+                       . externalPackageDeps
+                       $ lbi
+          dep_ipids = map (display . Installed.installedComponentId) dep_direct
+          depLibNames
+            | packageKeySupported comp = dep_ipids
+            | otherwise = deps
           depNames = map (display . packageName) dep_ids
 
           transitive_dep_ids = map Installed.sourcePackageId dep_pkgs
           transitiveDeps = map display transitive_dep_ids
+          transitiveDepLibNames
+            | packageKeySupported comp = map fixupRtsLibName transitiveDeps
+            | otherwise = transitiveDeps
+          fixupRtsLibName "rts-1.0" = "rts"
+          fixupRtsLibName x = x
           transitiveDepNames = map (display . packageName) transitive_dep_ids
 
           libraryDirs = forDeps Installed.libraryDirs
@@ -393,14 +401,24 @@ generate config_args distdir directory
       wrappedLibraryDirs <- wrap libraryDirs
 
       let variablePrefix = directory ++ '_':distdir
+          mods      = map display modules
+          otherMods = map display (otherModules bi)
+          allMods = mods ++ otherMods
       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
-                variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
-                variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
+                -- TODO: move inside withLibLBI
+                variablePrefix ++ "_COMPONENT_ID = " ++ display (localCompatPackageKey lbi),
+                -- copied from mkComponentsLocalBuildInfo
+                variablePrefix ++ "_COMPONENT_ID = " ++ display (localComponentId lbi),
+                variablePrefix ++ "_MODULES = " ++ unwords mods,
+                variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
                 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
                 variablePrefix ++ "_DEPS = " ++ unwords deps,
+                variablePrefix ++ "_DEP_IPIDS = " ++ unwords dep_ipids,
                 variablePrefix ++ "_DEP_NAMES = " ++ unwords depNames,
+                variablePrefix ++ "_DEP_COMPONENT_IDS = " ++ unwords depLibNames,
                 variablePrefix ++ "_TRANSITIVE_DEPS = " ++ unwords transitiveDeps,
+                variablePrefix ++ "_TRANSITIVE_DEP_COMPONENT_IDS = " ++ unwords transitiveDepLibNames,
                 variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords transitiveDepNames,
                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
@@ -425,6 +443,7 @@ generate config_args distdir directory
                 variablePrefix ++ "_DEP_CC_OPTS = "                    ++ unwords (forDeps Installed.ccOptions),
                 variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = "     ++ unwords wrappedLibraryDirs,
                 variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = "        ++ mkSearchPath libraryDirs,
+                variablePrefix ++ "_DEP_LIB_REL_DIRS = "               ++ unwords libraryRelDirs,
                 variablePrefix ++ "_DEP_LIB_REL_DIRS_SEARCHPATH = "    ++ mkSearchPath libraryRelDirs,
                 variablePrefix ++ "_DEP_EXTRA_LIBS = "                 ++ unwords (forDeps Installed.extraLibraries),
                 variablePrefix ++ "_DEP_LD_OPTS = "                    ++ unwords (forDeps Installed.ldOptions),
@@ -435,9 +454,15 @@ generate config_args distdir directory
                 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
                 ]
       writeFile (distdir ++ "/package-data.mk") $ unlines xs
-      writeFile (distdir ++ "/haddock-prologue.txt") $
+
+      writeFileUtf8 (distdir ++ "/haddock-prologue.txt") $
           if null (description pd) then synopsis pd
                                    else description pd
+      unless (null dll0Modules) $
+          do let dll0Mods = words dll0Modules
+                 dllMods = allMods \\ dll0Mods
+                 dllModSets = map unwords [dll0Mods, dllMods]
+             writeFile (distdir ++ "/dll-split") $ unlines dllModSets
   where
      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
      wrap = mapM wrap1
@@ -453,3 +478,8 @@ generate config_args distdir directory
      mkSearchPath = intercalate [searchPathSeparator]
      boolToYesNo True = "YES"
      boolToYesNo False = "NO"
+
+     -- | Version of 'writeFile' that always uses UTF8 encoding
+     writeFileUtf8 f txt = withFile f WriteMode $ \hdl -> do
+         hSetEncoding hdl utf8
+         hPutStr hdl txt