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