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.Text
  16 import Distribution.Verbosity
  17 import qualified Distribution.InstalledPackageInfo as Installed
  18          ( InstalledPackageInfo_(..) )
  19 import qualified Distribution.Simple.PackageIndex as PackageIndex
  20          ( topologicalOrder, lookupPackageName, insert )
  21
  22 import Control.Monad
  23 import Data.Maybe
  24 import System.IO
  25 import System.Directory
  26 import System.Environment
  27 import System.Exit
  28 import System.FilePath
  29
  30 main :: IO ()
  31 main = do args <- getArgs
  32           case args of
  33               "haddock" : distDir : dir : args' ->
  34                   runHaddock distDir dir args'
  35               "install" : ghcpkg : ghcpkgconfig : directory : distDir
  36                         : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
  37                   doInstall ghcpkg ghcpkgconfig directory distDir
  38                             myDestDir myPrefix myLibdir myDocdir args'
  39               "configure" : args' -> case break (== "--") args' of
  40                    (config_args, "--" : distdir : directories) ->
  41                        mapM_ (generate config_args distdir) directories
  42                    _ -> die syntax_error
  43               _ -> die syntax_error
  44
  45 syntax_error :: [String]
  46 syntax_error =
  47     ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
  48      "        ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
  49      "        ghc-cabal haddock <distdir> <directory> <args>..."]
  50
  51 die :: [String] -> IO ()
  52 die errs = do mapM_ (hPutStrLn stderr) errs
  53               exitWith (ExitFailure 1)
  54
  55 -- XXX Should use bracket
  56 withCurrentDirectory :: FilePath -> IO a -> IO a
  57 withCurrentDirectory directory io
  58  = do curDirectory <- getCurrentDirectory
  59       setCurrentDirectory directory
  60       r <- io
  61       setCurrentDirectory curDirectory
  62       return r
  63
  64 -- We need to use the autoconfUserHooks, as the packages that use
  65 -- configure can create a .buildinfo file, and we need any info that
  66 -- ends up in it.
  67 userHooks :: UserHooks
  68 userHooks = autoconfUserHooks
  69
  70 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
  71 runHaddock distdir directory args
  72  = withCurrentDirectory directory
  73  $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args)
  74     where
  75       hooks = userHooks {
  76                   haddockHook = modHook (haddockHook userHooks)
  77               }
  78       modHook f pd lbi us flags
  79        | packageName pd == PackageName "ghc-prim"
  80           = let pd' = case library pd of
  81                       Just lib ->
  82                           let ghcPrim = fromJust (simpleParse "GHC.Prim")
  83                               ems = filter (ghcPrim /=)
  84                                            (exposedModules lib)
  85                               lib' = lib { exposedModules = ems }
  86                           in pd { library = Just lib' }
  87                       Nothing ->
  88                           error "Expected a library, but none found"
  89                 pc = withPrograms lbi
  90                 pc' = userSpecifyArgs "haddock"
  91                           ["dist-install/build/autogen/GHC/Prim.hs"] pc
  92                 lbi' = lbi { withPrograms = pc' }
  93             in f pd' lbi' us flags
  94        | otherwise
  95           = f pd lbi us flags
  96
  97 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
  98           -> FilePath -> FilePath -> FilePath -> [String] -> IO ()
  99 doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocdir args
 100  = withCurrentDirectory directory $ do
 101      defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
 102                                      ++ (if null myDestDir then []
 103                                            else ["--destdir", myDestDir])
 104                                      ++ args)
 105      defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
 106     where
 107       hooks = userHooks {
 108                   copyHook = modHook (copyHook userHooks),
 109                   regHook  = modHook (regHook userHooks)
 110               }
 111
 112       modHook f pd lbi us flags
 113               = let
 114                     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                     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 = verbose
 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)
 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       when (isJust $ library pd) $
 184           writeInstalledConfig distdir pd lbi True Nothing
 185
 186       let
 187           libBiModules lib = (libBuildInfo lib, libModules pd)
 188           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules pd)
 189           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 190                     ++ (map exeBiModules $ executables pd)
 191           buildableBiModuless = filter isBuildable biModuless
 192               where isBuildable (bi', _) = buildable bi'
 193           (bi, modules) = case buildableBiModuless of
 194                           [] -> error "No buildable component found"
 195                           [biModules] -> biModules
 196                           _ -> error ("XXX ghc-cabal can't handle " ++
 197                                       "more than one buildinfo yet")
 198           -- XXX Another Just...
 199           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 200
 201           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 202           forDeps f = concatMap f dep_pkgs
 203
 204           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 205           packageHacks = case compilerFlavor (compiler lbi) of
 206             GHC -> hackRtsPackage
 207             _   -> id
 208           -- We don't link in the actual Haskell libraries of our
 209           -- dependencies, so the -u flags in the ldOptions of the rts
 210           -- package mean linking fails on OS X (it's ld is a tad
 211           -- stricter than gnu ld). Thus we remove the ldOptions for
 212           -- GHC's rts package:
 213           hackRtsPackage index =
 214             case PackageIndex.lookupPackageName index (PackageName "rts") of
 215               [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
 216               _ -> error "No (or multiple) ghc rts package is registered!!"
 217
 218       let variablePrefix = directory ++ '_':distdir
 219       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 220                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 221                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 222                 variablePrefix ++ "_DEPS = " ++ unwords (map display (packageDeps lbi)),
 223                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (packageDeps lbi)),
 224                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 225                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 226                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 227                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 228                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 229                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 230                 -- XXX This includes things it shouldn't, like:
 231                 -- -odir dist-bootstrapping/build
 232                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 233                         (programArgs ghcProg
 234                         ++ hcOptions GHC bi
 235                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 236                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 237                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 238                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 239                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
 240                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 241                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
 242                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 243                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 244       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 245   where
 246      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []