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               -- time has a "Custom" Setup.hs, but it's actually Configure
 162               -- plus a "./Setup test" hook. However, Cabal is also
 163               -- "Custom", but doesn't have a configure script.
 164               Just Custom ->
 165                   do configureExists <- doesFileExist "configure"
 166                      if configureExists
 167                          then defaultMainWithHooks autoconfUserHooks
 168                          else defaultMain
 169               -- not quite right, but good enough for us:
 170               _ -> defaultMain)
 171
 172       lbi <- getPersistBuildConfig distdir
 173       let pd0 = localPkgDescr lbi
 174
 175       hooked_bi <-
 176            if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
 177            then do
 178               maybe_infoFile <- defaultHookedPackageDesc
 179               case maybe_infoFile of
 180                   Nothing       -> return emptyHookedBuildInfo
 181                   Just infoFile -> readHookedBuildInfo verbosity infoFile
 182            else
 183               return emptyHookedBuildInfo
 184
 185       let pd = updatePackageDescription hooked_bi pd0
 186
 187       -- generate Paths_<pkg>.hs and cabal-macros.h
 188       writeAutogenFiles verbosity pd lbi
 189
 190       -- generate inplace-pkg-config
 191       case (library pd, libraryConfig lbi) of
 192           (Nothing, Nothing) -> return ()
 193           (Just lib, Just clbi) -> do
 194               cwd <- getCurrentDirectory
 195               let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
 196                                          pd lib lbi clbi
 197                   content = Installed.showInstalledPackageInfo installedPkgInfo ++ "\n"
 198               writeFileAtomic (distdir </> "inplace-pkg-config") content
 199           _ -> error "Inconsistent lib components; can't happen?"
 200
 201       let
 202           libBiModules lib = (libBuildInfo lib, libModules lib)
 203           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
 204           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 205                     ++ (map exeBiModules $ executables pd)
 206           buildableBiModuless = filter isBuildable biModuless
 207               where isBuildable (bi', _) = buildable bi'
 208           (bi, modules) = case buildableBiModuless of
 209                           [] -> error "No buildable component found"
 210                           [biModules] -> biModules
 211                           _ -> error ("XXX ghc-cabal can't handle " ++
 212                                       "more than one buildinfo yet")
 213           -- XXX Another Just...
 214           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 215
 216           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 217           forDeps f = concatMap f dep_pkgs
 218
 219           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 220           packageHacks = case compilerFlavor (compiler lbi) of
 221             GHC -> hackRtsPackage
 222             _   -> id
 223           -- We don't link in the actual Haskell libraries of our
 224           -- dependencies, so the -u flags in the ldOptions of the rts
 225           -- package mean linking fails on OS X (it's ld is a tad
 226           -- stricter than gnu ld). Thus we remove the ldOptions for
 227           -- GHC's rts package:
 228           hackRtsPackage index =
 229             case PackageIndex.lookupPackageName index (PackageName "rts") of
 230               [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
 231               _ -> error "No (or multiple) ghc rts package is registered!!"
 232
 233       let variablePrefix = directory ++ '_':distdir
 234       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 235                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 236                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 237                 variablePrefix ++ "_DEPS = " ++ unwords (map display (externalPackageDeps lbi)),
 238                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (externalPackageDeps lbi)),
 239                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 240                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 241                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 242                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 243                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 244                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 245                 variablePrefix ++ "_CMM_SRCS  = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
 246                 -- XXX This includes things it shouldn't, like:
 247                 -- -odir dist-bootstrapping/build
 248                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 249                         (programArgs ghcProg
 250                         ++ hcOptions GHC bi
 251                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 252                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 253                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 254                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 255                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
 256                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 257                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
 258                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 259                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 260       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 261   where
 262      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
 263