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