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