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