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