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 : strip : topdir : directory : distDir
  38                         : myDestDir : myPrefix : myLibdir : myDocdir
  39                         : relocatableBuild : args' ->
  40                   doInstall ghc ghcpkg strip 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 -> FilePath
 143           -> String -> [String]
 144           -> IO ()
 145 doInstall ghc ghcpkg strip 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                 stripProg = ConfiguredProgram {
 224                               programId = programName stripProgram,
 225                               programVersion = Nothing,
 226                               programArgs = [],
 227                               programLocation = UserSpecified strip
 228                           }
 229                 progs' = updateProgram ghcProg
 230                        $ updateProgram ghcPkgProg
 231                        $ updateProgram stripProg
 232                          progs
 233             instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
 234             let installedPkgs' = PackageIndex.fromList instInfos
 235             let mlc = libraryConfig lbi
 236                 mlc' = case mlc of
 237                        Just lc ->
 238                            let cipds = componentPackageDeps lc
 239                                cipds' = [ (fixupPackageId instInfos ipid, pid)
 240                                         | (ipid,pid) <- cipds ]
 241                            in Just $ lc {
 242                                          componentPackageDeps = cipds'
 243                                      }
 244                        Nothing -> Nothing
 245                 lbi' = lbi {
 246                                libraryConfig = mlc',
 247                                installedPkgs = installedPkgs',
 248                                installDirTemplates = idts',
 249                                withPrograms = progs'
 250                            }
 251             f pd lbi' us flags
 252
 253 -- The packages are built with the package ID ending in "-inplace", but
 254 -- when they're installed they get the package hash appended. We need to
 255 -- fix up the package deps so that they use the hash package IDs, not
 256 -- the inplace package IDs.
 257 fixupPackageId :: [Installed.InstalledPackageInfo]
 258                -> InstalledPackageId
 259                -> InstalledPackageId
 260 fixupPackageId _ x@(InstalledPackageId ipi)
 261  | "builtin_" `isPrefixOf` ipi = x
 262 fixupPackageId ipinfos (InstalledPackageId ipi)
 263  = case stripPrefix (reverse "-inplace") $ reverse ipi of
 264    Nothing ->
 265        error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
 266    Just x ->
 267        let ipi' = reverse ('-' : x)
 268            f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
 269                                    y@(InstalledPackageId ipinfoid)
 270                                     | ipi' `isPrefixOf` ipinfoid ->
 271                                        y
 272                                    _ ->
 273                                        f ipinfos'
 274            f [] = error ("Installed package ID not registered: " ++ show ipi)
 275        in f ipinfos
 276
 277 generate :: [String] -> FilePath -> FilePath -> IO ()
 278 generate config_args distdir directory
 279  = withCurrentDirectory directory
 280  $ do let verbosity = normal
 281       -- XXX We shouldn't just configure with the default flags
 282       -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
 283       -- aren't going to work when the deps aren't built yet
 284       withArgs (["configure", "--distdir", distdir] ++ config_args)
 285                runDefaultMain
 286
 287       lbi <- getPersistBuildConfig distdir
 288       let pd0 = localPkgDescr lbi
 289
 290       hooked_bi <-
 291            if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
 292            then do
 293               maybe_infoFile <- defaultHookedPackageDesc
 294               case maybe_infoFile of
 295                   Nothing       -> return emptyHookedBuildInfo
 296                   Just infoFile -> readHookedBuildInfo verbosity infoFile
 297            else
 298               return emptyHookedBuildInfo
 299
 300       let pd = updatePackageDescription hooked_bi pd0
 301
 302       -- generate Paths_<pkg>.hs and cabal-macros.h
 303       writeAutogenFiles verbosity pd lbi
 304
 305       -- generate inplace-pkg-config
 306       case (library pd, libraryConfig lbi) of
 307           (Nothing, Nothing) -> return ()
 308           (Just lib, Just clbi) -> do
 309               cwd <- getCurrentDirectory
 310               let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
 311               let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
 312                                          pd lib lbi clbi
 313                   final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
 314                   content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
 315               writeFileAtomic (distdir </> "inplace-pkg-config") content
 316           _ -> error "Inconsistent lib components; can't happen?"
 317
 318       let
 319           libBiModules lib = (libBuildInfo lib, libModules lib)
 320           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
 321           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 322                     ++ (map exeBiModules $ executables pd)
 323           buildableBiModuless = filter isBuildable biModuless
 324               where isBuildable (bi', _) = buildable bi'
 325           (bi, modules) = case buildableBiModuless of
 326                           [] -> error "No buildable component found"
 327                           [biModules] -> biModules
 328                           _ -> error ("XXX ghc-cabal can't handle " ++
 329                                       "more than one buildinfo yet")
 330           -- XXX Another Just...
 331           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 332
 333           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 334           forDeps f = concatMap f dep_pkgs
 335
 336           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 337           packageHacks = case compilerFlavor (compiler lbi) of
 338             GHC -> hackRtsPackage
 339             _   -> id
 340           -- We don't link in the actual Haskell libraries of our
 341           -- dependencies, so the -u flags in the ldOptions of the rts
 342           -- package mean linking fails on OS X (it's ld is a tad
 343           -- stricter than gnu ld). Thus we remove the ldOptions for
 344           -- GHC's rts package:
 345           hackRtsPackage index =
 346             case PackageIndex.lookupPackageName index (PackageName "rts") of
 347               [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
 348               _ -> error "No (or multiple) ghc rts package is registered!!"
 349
 350           dep_ids = map snd (externalPackageDeps lbi)
 351
 352       let variablePrefix = directory ++ '_':distdir
 353       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 354                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 355                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 356                 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
 357                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
 358                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 359                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 360                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 361                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 362                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 363                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 364                 variablePrefix ++ "_CMM_SRCS  = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
 365                 -- XXX This includes things it shouldn't, like:
 366                 -- -odir dist-bootstrapping/build
 367                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 368                         (programArgs ghcProg
 369                         ++ hcOptions GHC bi
 370                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 371                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 372                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 373                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 374                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
 375                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 376                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (wrap $ forDeps Installed.libraryDirs),
 377                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 378                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 379       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 380   where
 381      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
 382      wrap = map (\s -> "\'" ++ s ++ "\'")