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