utils/ghc-cabal/ghc-cabal.hs

   1
   2 module Main (main) where
   3
   4 import qualified Distribution.ModuleName as ModuleName
   5 import Distribution.PackageDescription
   6 import Distribution.PackageDescription.Check hiding (doesFileExist)
   7 import Distribution.PackageDescription.Configuration
   8 import Distribution.PackageDescription.Parse
   9 import Distribution.Simple
  10 import Distribution.Simple.Configure
  11 import Distribution.Simple.LocalBuildInfo
  12 import Distribution.Simple.Program
  13 import Distribution.Simple.Program.HcPkg
  14 import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic)
  15 import Distribution.Simple.Build (writeAutogenFiles)
  16 import Distribution.Simple.Register
  17 import Distribution.Text
  18 import Distribution.Verbosity
  19 import qualified Distribution.InstalledPackageInfo as Installed
  20 import qualified Distribution.Simple.PackageIndex as PackageIndex
  21
  22 import Data.List
  23 import Data.Maybe
  24 import System.IO
  25 import System.Directory
  26 import System.Environment
  27 import System.Exit
  28 import System.FilePath
  29
  30 main :: IO ()
  31 main = do args <- getArgs
  32           case args of
  33               "haddock" : distDir : dir : args' ->
  34                   runHaddock distDir dir args'
  35               "check" : dir : [] ->
  36                   doCheck dir
  37               "install" : ghc : ghcpkg : topdir : directory : distDir
  38                         : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
  39                   doInstall ghc ghcpkg topdir directory distDir
  40                             myDestDir myPrefix myLibdir myDocdir args'
  41               "configure" : args' -> case break (== "--") args' of
  42                    (config_args, "--" : distdir : directories) ->
  43                        mapM_ (generate config_args distdir) directories
  44                    _ -> die syntax_error
  45               "sdist" : dir : distDir : [] ->
  46                   doSdist dir distDir
  47               _ -> die syntax_error
  48
  49 syntax_error :: [String]
  50 syntax_error =
  51     ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
  52      "        ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
  53      "        ghc-cabal haddock <distdir> <directory> <args>..."]
  54
  55 die :: [String] -> IO ()
  56 die errs = do mapM_ (hPutStrLn stderr) errs
  57               exitWith (ExitFailure 1)
  58
  59 -- XXX Should use bracket
  60 withCurrentDirectory :: FilePath -> IO a -> IO a
  61 withCurrentDirectory directory io
  62  = do curDirectory <- getCurrentDirectory
  63       setCurrentDirectory directory
  64       r <- io
  65       setCurrentDirectory curDirectory
  66       return r
  67
  68 -- We need to use the autoconfUserHooks, as the packages that use
  69 -- configure can create a .buildinfo file, and we need any info that
  70 -- ends up in it.
  71 userHooks :: UserHooks
  72 userHooks = autoconfUserHooks
  73
  74 runDefaultMain :: IO ()
  75 runDefaultMain
  76  = do let verbosity = normal
  77       gpdFile <- defaultPackageDesc verbosity
  78       gpd <- readPackageDescription verbosity gpdFile
  79       case buildType (flattenPackageDescription gpd) of
  80           Just Configure -> defaultMainWithHooks autoconfUserHooks
  81           -- time has a "Custom" Setup.hs, but it's actually Configure
  82           -- plus a "./Setup test" hook. However, Cabal is also
  83           -- "Custom", but doesn't have a configure script.
  84           Just Custom ->
  85               do configureExists <- doesFileExist "configure"
  86                  if configureExists
  87                      then defaultMainWithHooks autoconfUserHooks
  88                      else defaultMain
  89           -- not quite right, but good enough for us:
  90           _ -> defaultMain
  91
  92 doSdist :: FilePath -> FilePath -> IO ()
  93 doSdist directory distDir
  94  = withCurrentDirectory directory
  95  $ withArgs (["sdist", "--builddir", distDir])
  96             runDefaultMain
  97
  98 doCheck :: FilePath -> IO ()
  99 doCheck directory
 100  = withCurrentDirectory directory
 101  $ do let verbosity = normal
 102       gpdFile <- defaultPackageDesc verbosity
 103       gpd <- readPackageDescription verbosity gpdFile
 104       case partition isFailure $ checkPackage gpd Nothing of
 105           ([],   [])       -> return ()
 106           ([],   warnings) -> mapM_ print warnings
 107           (errs, _)        -> do mapM_ print errs
 108                                  exitWith (ExitFailure 1)
 109     where isFailure (PackageDistSuspicious {}) = False
 110           isFailure _ = True
 111
 112 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
 113 runHaddock distdir directory args
 114  = withCurrentDirectory directory
 115  $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args)
 116     where
 117       hooks = userHooks {
 118                   haddockHook = modHook (haddockHook userHooks)
 119               }
 120       modHook f pd lbi us flags
 121        | packageName pd == PackageName "ghc-prim"
 122           = let pd' = case library pd of
 123                       Just lib ->
 124                           let ghcPrim = fromJust (simpleParse "GHC.Prim")
 125                               ems = filter (ghcPrim /=)
 126                                            (exposedModules lib)
 127                               lib' = lib { exposedModules = ems }
 128                           in pd { library = Just lib' }
 129                       Nothing ->
 130                           error "Expected a library, but none found"
 131                 pc = withPrograms lbi
 132                 pc' = userSpecifyArgs "haddock"
 133                           ["dist-install/build/autogen/GHC/Prim.hs"] pc
 134                 lbi' = lbi { withPrograms = pc' }
 135             in f pd' lbi' us flags
 136        | otherwise
 137           = f pd lbi us flags
 138
 139 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
 140           -> FilePath -> FilePath -> FilePath -> FilePath -> [String]
 141           -> IO ()
 142 doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args
 143  = withCurrentDirectory directory $ do
 144      defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
 145                                      ++ (if null myDestDir then []
 146                                            else ["--destdir", myDestDir])
 147                                      ++ args)
 148      defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
 149     where
 150       hooks = userHooks {
 151                   copyHook = noGhcPrimHook (modHook (copyHook userHooks)),
 152                   regHook  = modHook (regHook userHooks)
 153               }
 154
 155       noGhcPrimHook f pd lbi us flags
 156               = let pd'
 157                      | packageName pd == PackageName "ghc-prim" =
 158                         case library pd of
 159                         Just lib ->
 160                             let ghcPrim = fromJust (simpleParse "GHC.Prim")
 161                                 ems = filter (ghcPrim /=) (exposedModules lib)
 162                                 lib' = lib { exposedModules = ems }
 163                             in pd { library = Just lib' }
 164                         Nothing ->
 165                             error "Expected a library, but none found"
 166                      | otherwise = pd
 167                 in f pd' lbi us flags
 168       modHook f pd lbi us flags
 169        = do let verbosity = normal
 170                 idts = installDirTemplates lbi
 171                 idts' = idts { prefix    = toPathTemplate myPrefix,
 172                                libdir    = toPathTemplate myLibdir,
 173                                libsubdir = toPathTemplate "$pkgid",
 174                                docdir    = toPathTemplate (myDocdir </> "$pkg"),
 175                                htmldir   = toPathTemplate "$docdir" }
 176                 progs = withPrograms lbi
 177                 ghcProg = ConfiguredProgram {
 178                               programId = programName ghcProgram,
 179                               programVersion = Nothing,
 180                               programArgs = ["-B" ++ topdir],
 181                               programLocation = UserSpecified ghc
 182                           }
 183                 ghcpkgconf = topdir </> "package.conf.d"
 184                 ghcPkgProg = ConfiguredProgram {
 185                                  programId = programName ghcPkgProgram,
 186                                  programVersion = Nothing,
 187                                  programArgs = ["--global-conf",
 188                                                 ghcpkgconf]
 189                                                ++ if not (null myDestDir)
 190                                                   then ["--force"]
 191                                                   else [],
 192                                  programLocation = UserSpecified ghcpkg
 193                              }
 194                 progs' = updateProgram ghcProg
 195                        $ updateProgram ghcPkgProg progs
 196             instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
 197             let installedPkgs' = PackageIndex.listToInstalledPackageIndex
 198                                      instInfos
 199             let mlc = libraryConfig lbi
 200                 mlc' = case mlc of
 201                        Just lc ->
 202                            let cipds = componentInstalledPackageDeps lc
 203                                cipds' = map (fixupPackageId instInfos) cipds
 204                            in Just $ lc {
 205                                          componentInstalledPackageDeps = cipds'
 206                                      }
 207                        Nothing -> Nothing
 208                 lbi' = lbi {
 209                                libraryConfig = mlc',
 210                                installedPkgs = installedPkgs',
 211                                installDirTemplates = idts',
 212                                withPrograms = progs'
 213                            }
 214             f pd lbi' us flags
 215
 216 -- The packages are built with the package ID ending in "-inplace", but
 217 -- when they're installed they get the package hash appended. We need to
 218 -- fix up the package deps so that they use the hash package IDs, not
 219 -- the inplace package IDs.
 220 fixupPackageId :: [Installed.InstalledPackageInfo]
 221                -> InstalledPackageId
 222                -> InstalledPackageId
 223 fixupPackageId _ x@(InstalledPackageId ipi)
 224  | "builtin_" `isPrefixOf` ipi = x
 225 fixupPackageId ipinfos (InstalledPackageId ipi)
 226  = case stripPrefix (reverse "-inplace") $ reverse ipi of
 227    Nothing ->
 228        error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
 229    Just x ->
 230        let ipi' = reverse ('-' : x)
 231            f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
 232                                    y@(InstalledPackageId ipinfoid)
 233                                     | ipi' `isPrefixOf` ipinfoid ->
 234                                        y
 235                                    _ ->
 236                                        f ipinfos'
 237            f [] = error ("Installed package ID not registered: " ++ show ipi)
 238        in f ipinfos
 239
 240 generate :: [String] -> FilePath -> FilePath -> IO ()
 241 generate config_args distdir directory
 242  = withCurrentDirectory directory
 243  $ do let verbosity = normal
 244       -- XXX We shouldn't just configure with the default flags
 245       -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
 246       -- aren't going to work when the deps aren't built yet
 247       withArgs (["configure", "--distdir", distdir] ++ config_args)
 248                runDefaultMain
 249
 250       lbi <- getPersistBuildConfig distdir
 251       let pd0 = localPkgDescr lbi
 252
 253       hooked_bi <-
 254            if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
 255            then do
 256               maybe_infoFile <- defaultHookedPackageDesc
 257               case maybe_infoFile of
 258                   Nothing       -> return emptyHookedBuildInfo
 259                   Just infoFile -> readHookedBuildInfo verbosity infoFile
 260            else
 261               return emptyHookedBuildInfo
 262
 263       let pd = updatePackageDescription hooked_bi pd0
 264
 265       -- generate Paths_<pkg>.hs and cabal-macros.h
 266       writeAutogenFiles verbosity pd lbi
 267
 268       -- generate inplace-pkg-config
 269       case (library pd, libraryConfig lbi) of
 270           (Nothing, Nothing) -> return ()
 271           (Just lib, Just clbi) -> do
 272               cwd <- getCurrentDirectory
 273               let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
 274               let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
 275                                          pd lib lbi clbi
 276                   final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
 277                   content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
 278               writeFileAtomic (distdir </> "inplace-pkg-config") content
 279           _ -> error "Inconsistent lib components; can't happen?"
 280
 281       let
 282           libBiModules lib = (libBuildInfo lib, libModules lib)
 283           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
 284           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 285                     ++ (map exeBiModules $ executables pd)
 286           buildableBiModuless = filter isBuildable biModuless
 287               where isBuildable (bi', _) = buildable bi'
 288           (bi, modules) = case buildableBiModuless of
 289                           [] -> error "No buildable component found"
 290                           [biModules] -> biModules
 291                           _ -> error ("XXX ghc-cabal can't handle " ++
 292                                       "more than one buildinfo yet")
 293           -- XXX Another Just...
 294           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 295
 296           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 297           forDeps f = concatMap f dep_pkgs
 298
 299           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 300           packageHacks = case compilerFlavor (compiler lbi) of
 301             GHC -> hackRtsPackage
 302             _   -> id
 303           -- We don't link in the actual Haskell libraries of our
 304           -- dependencies, so the -u flags in the ldOptions of the rts
 305           -- package mean linking fails on OS X (it's ld is a tad
 306           -- stricter than gnu ld). Thus we remove the ldOptions for
 307           -- GHC's rts package:
 308           hackRtsPackage index =
 309             case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
 310               [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
 311               _ -> error "No (or multiple) ghc rts package is registered!!"
 312
 313           dep_ids = map (packageId.getLocalPackageInfo lbi) $
 314                        externalPackageDeps lbi
 315
 316       let variablePrefix = directory ++ '_':distdir
 317       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 318                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 319                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 320                 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
 321                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
 322                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 323                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 324                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 325                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 326                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 327                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 328                 variablePrefix ++ "_CMM_SRCS  = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
 329                 -- XXX This includes things it shouldn't, like:
 330                 -- -odir dist-bootstrapping/build
 331                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 332                         (programArgs ghcProg
 333                         ++ hcOptions GHC bi
 334                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 335                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 336                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 337                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 338                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
 339                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 340                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
 341                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 342                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 343       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 344   where
 345      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
 346