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