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