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