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