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