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