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