ghc-cabal.hs 18.3 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1 2 3 4 5

module Main (main) where

import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription
6
import Distribution.PackageDescription.Check hiding (doesFileExist)
Ian Lynagh's avatar
Ian Lynagh committed
7 8 9 10 11 12
import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Parse
import Distribution.Simple
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
Ian Lynagh's avatar
Ian Lynagh committed
13
import Distribution.Simple.Program.HcPkg
Ian Lynagh's avatar
Ian Lynagh committed
14
import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic)
Ian Lynagh's avatar
Ian Lynagh committed
15
import Distribution.Simple.Build (writeAutogenFiles)
Ian Lynagh's avatar
Ian Lynagh committed
16
import Distribution.Simple.Register
Ian Lynagh's avatar
Ian Lynagh committed
17 18 19 20 21
import Distribution.Text
import Distribution.Verbosity
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.Simple.PackageIndex as PackageIndex

22
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
23 24 25 26 27 28 29 30 31 32
import Data.Maybe
import System.IO
import System.Directory
import System.Environment
import System.Exit
import System.FilePath

main :: IO ()
main = do args <- getArgs
          case args of
33 34
              "hscolour" : distDir : dir : args' ->
                  runHsColour distDir dir args'
35 36
              "check" : dir : [] ->
                  doCheck dir
37
              "install" : ghc : ghcpkg : strip : topdir : directory : distDir
38 39
                        : myDestDir : myPrefix : myLibdir : myDocdir
                        : relocatableBuild : args' ->
40
                  doInstall ghc ghcpkg strip topdir directory distDir
41 42
                            myDestDir myPrefix myLibdir myDocdir
                            relocatableBuild args'
Ian Lynagh's avatar
Ian Lynagh committed
43 44 45 46
              "configure" : args' -> case break (== "--") args' of
                   (config_args, "--" : distdir : directories) ->
                       mapM_ (generate config_args distdir) directories
                   _ -> die syntax_error
47 48
              "sdist" : dir : distDir : [] ->
                  doSdist dir distDir
Ian Lynagh's avatar
Ian Lynagh committed
49 50 51 52 53 54
              _ -> die syntax_error

syntax_error :: [String]
syntax_error =
    ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
     "        ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
55
     "        ghc-cabal hscolour <distdir> <directory> <args>..."]
Ian Lynagh's avatar
Ian Lynagh committed
56

57
die :: [String] -> IO a
Ian Lynagh's avatar
Ian Lynagh committed
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
die errs = do mapM_ (hPutStrLn stderr) errs
              exitWith (ExitFailure 1)

-- XXX Should use bracket
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory directory io
 = do curDirectory <- getCurrentDirectory
      setCurrentDirectory directory
      r <- io
      setCurrentDirectory curDirectory
      return r

-- We need to use the autoconfUserHooks, as the packages that use
-- configure can create a .buildinfo file, and we need any info that
-- ends up in it.
userHooks :: UserHooks
userHooks = autoconfUserHooks

76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
runDefaultMain :: IO ()
runDefaultMain
 = do let verbosity = normal
      gpdFile <- defaultPackageDesc verbosity
      gpd <- readPackageDescription verbosity gpdFile
      case buildType (flattenPackageDescription gpd) of
          Just Configure -> defaultMainWithHooks autoconfUserHooks
          -- time has a "Custom" Setup.hs, but it's actually Configure
          -- plus a "./Setup test" hook. However, Cabal is also
          -- "Custom", but doesn't have a configure script.
          Just Custom ->
              do configureExists <- doesFileExist "configure"
                 if configureExists
                     then defaultMainWithHooks autoconfUserHooks
                     else defaultMain
          -- not quite right, but good enough for us:
          _ -> defaultMain

doSdist :: FilePath -> FilePath -> IO ()
doSdist directory distDir
 = withCurrentDirectory directory
 $ withArgs (["sdist", "--builddir", distDir])
            runDefaultMain

100 101 102 103 104 105 106 107 108 109 110 111 112 113
doCheck :: FilePath -> IO ()
doCheck directory
 = withCurrentDirectory directory
 $ do let verbosity = normal
      gpdFile <- defaultPackageDesc verbosity
      gpd <- readPackageDescription verbosity gpdFile
      case partition isFailure $ checkPackage gpd Nothing of
          ([],   [])       -> return ()
          ([],   warnings) -> mapM_ print warnings
          (errs, _)        -> do mapM_ print errs
                                 exitWith (ExitFailure 1)
    where isFailure (PackageDistSuspicious {}) = False
          isFailure _ = True

114 115
runHsColour :: FilePath -> FilePath -> [String] -> IO ()
runHsColour distdir directory args
Ian Lynagh's avatar
Ian Lynagh committed
116
 = withCurrentDirectory directory
117
 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
Ian Lynagh's avatar
Ian Lynagh committed
118 119

doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
120 121
          -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
          -> String -> [String]
122
          -> IO ()
123
doInstall ghc ghcpkg strip topdir directory distDir
124 125
          myDestDir myPrefix myLibdir myDocdir
          relocatableBuildStr args
Ian Lynagh's avatar
Ian Lynagh committed
126
 = withCurrentDirectory directory $ do
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
     relocatableBuild <- case relocatableBuildStr of
                         "YES" -> return True
                         "NO"  -> return False
                         _ -> die ["Bad relocatableBuildStr: " ++
                                   show relocatableBuildStr]
     let copyArgs = ["copy", "--builddir", distDir]
                 ++ (if null myDestDir
                     then []
                     else ["--destdir", myDestDir])
                 ++ args
         regArgs = "register" : "--builddir" : distDir : args
         copyHooks = userHooks {
                         copyHook = noGhcPrimHook
                                  $ modHook False
                                  $ copyHook userHooks
                     }
         regHooks = userHooks {
                        regHook = modHook relocatableBuild
                                $ regHook userHooks
                    }
Ian Lynagh's avatar
Ian Lynagh committed
147

148 149 150
     defaultMainWithHooksArgs copyHooks copyArgs
     defaultMainWithHooksArgs regHooks  regArgs
    where
151 152
      noGhcPrimHook f pd lbi us flags
              = let pd'
Ian Lynagh's avatar
Ian Lynagh committed
153 154 155 156 157 158 159 160 161 162
                     | packageName pd == PackageName "ghc-prim" =
                        case library pd of
                        Just lib ->
                            let ghcPrim = fromJust (simpleParse "GHC.Prim")
                                ems = filter (ghcPrim /=) (exposedModules lib)
                                lib' = lib { exposedModules = ems }
                            in pd { library = Just lib' }
                        Nothing ->
                            error "Expected a library, but none found"
                     | otherwise = pd
163
                in f pd' lbi us flags
164
      modHook relocatableBuild f pd lbi us flags
Ian Lynagh's avatar
Ian Lynagh committed
165 166
       = do let verbosity = normal
                idts = installDirTemplates lbi
167 168 169 170 171 172 173 174 175 176 177 178
                idts' = idts {
                            prefix    = toPathTemplate $
                                            if relocatableBuild
                                            then "$topdir"
                                            else myPrefix,
                            libdir    = toPathTemplate $
                                            if relocatableBuild
                                            then "$topdir"
                                            else myLibdir,
                            libsubdir = toPathTemplate "$pkgid",
                            docdir    = toPathTemplate $
                                            if relocatableBuild
Ian Lynagh's avatar
Ian Lynagh committed
179
                                            then "$topdir/../doc/html/libraries/$pkgid"
180
                                            else (myDocdir </> "$pkgid"),
181 182
                            htmldir   = toPathTemplate "$docdir"
                        }
Ian Lynagh's avatar
Ian Lynagh committed
183 184 185 186
                progs = withPrograms lbi
                ghcProg = ConfiguredProgram {
                              programId = programName ghcProgram,
                              programVersion = Nothing,
Ian Lynagh's avatar
Ian Lynagh committed
187 188
                              programDefaultArgs = ["-B" ++ topdir],
                              programOverrideArgs = [],
Ian Lynagh's avatar
Ian Lynagh committed
189 190
                              programLocation = UserSpecified ghc
                          }
191
                ghcpkgconf = topdir </> "package.conf.d"
Ian Lynagh's avatar
Ian Lynagh committed
192 193 194
                ghcPkgProg = ConfiguredProgram {
                                 programId = programName ghcPkgProgram,
                                 programVersion = Nothing,
Ian Lynagh's avatar
Ian Lynagh committed
195 196
                                 programDefaultArgs = ["--global-conf",
                                                       ghcpkgconf]
Ian Lynagh's avatar
Ian Lynagh committed
197 198 199
                                               ++ if not (null myDestDir)
                                                  then ["--force"]
                                                  else [],
Ian Lynagh's avatar
Ian Lynagh committed
200
                                 programOverrideArgs = [],
Ian Lynagh's avatar
Ian Lynagh committed
201 202
                                 programLocation = UserSpecified ghcpkg
                             }
203 204 205
                stripProg = ConfiguredProgram {
                              programId = programName stripProgram,
                              programVersion = Nothing,
Ian Lynagh's avatar
Ian Lynagh committed
206 207
                              programDefaultArgs = [],
                              programOverrideArgs = [],
208 209
                              programLocation = UserSpecified strip
                          }
Ian Lynagh's avatar
Ian Lynagh committed
210
                progs' = updateProgram ghcProg
211 212 213
                       $ updateProgram ghcPkgProg
                       $ updateProgram stripProg
                         progs
Ian Lynagh's avatar
Ian Lynagh committed
214
            instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
215
            let installedPkgs' = PackageIndex.fromList instInfos
Ian Lynagh's avatar
Ian Lynagh committed
216 217 218
            let mlc = libraryConfig lbi
                mlc' = case mlc of
                       Just lc ->
219 220 221
                           let cipds = componentPackageDeps lc
                               cipds' = [ (fixupPackageId instInfos ipid, pid)
                                        | (ipid,pid) <- cipds ]
Ian Lynagh's avatar
Ian Lynagh committed
222
                           in Just $ lc {
223
                                         componentPackageDeps = cipds'
Ian Lynagh's avatar
Ian Lynagh committed
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
                                     }
                       Nothing -> Nothing
                lbi' = lbi {
                               libraryConfig = mlc',
                               installedPkgs = installedPkgs',
                               installDirTemplates = idts',
                               withPrograms = progs'
                           }
            f pd lbi' us flags

-- The packages are built with the package ID ending in "-inplace", but
-- when they're installed they get the package hash appended. We need to
-- fix up the package deps so that they use the hash package IDs, not
-- the inplace package IDs.
fixupPackageId :: [Installed.InstalledPackageInfo]
               -> InstalledPackageId
               -> InstalledPackageId
fixupPackageId _ x@(InstalledPackageId ipi)
242
 | "builtin_" `isPrefixOf` ipi = x
Ian Lynagh's avatar
Ian Lynagh committed
243 244 245 246 247 248 249 250 251 252 253 254 255 256
fixupPackageId ipinfos (InstalledPackageId ipi)
 = case stripPrefix (reverse "-inplace") $ reverse ipi of
   Nothing ->
       error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
   Just x ->
       let ipi' = reverse ('-' : x)
           f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
                                   y@(InstalledPackageId ipinfoid)
                                    | ipi' `isPrefixOf` ipinfoid ->
                                       y
                                   _ ->
                                       f ipinfos'
           f [] = error ("Installed package ID not registered: " ++ show ipi)
       in f ipinfos
Ian Lynagh's avatar
Ian Lynagh committed
257 258 259 260

generate :: [String] -> FilePath -> FilePath -> IO ()
generate config_args distdir directory
 = withCurrentDirectory directory
Ian Lynagh's avatar
Ian Lynagh committed
261
 $ do let verbosity = normal
Ian Lynagh's avatar
Ian Lynagh committed
262 263 264 265
      -- XXX We shouldn't just configure with the default flags
      -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
      -- aren't going to work when the deps aren't built yet
      withArgs (["configure", "--distdir", distdir] ++ config_args)
266
               runDefaultMain
Ian Lynagh's avatar
Ian Lynagh committed
267 268 269 270 271

      lbi <- getPersistBuildConfig distdir
      let pd0 = localPkgDescr lbi

      hooked_bi <-
Ian Lynagh's avatar
Ian Lynagh committed
272
           if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
Ian Lynagh's avatar
Ian Lynagh committed
273 274 275 276 277 278 279 280 281 282 283 284 285 286
           then do
              maybe_infoFile <- defaultHookedPackageDesc
              case maybe_infoFile of
                  Nothing       -> return emptyHookedBuildInfo
                  Just infoFile -> readHookedBuildInfo verbosity infoFile
           else
              return emptyHookedBuildInfo

      let pd = updatePackageDescription hooked_bi pd0

      -- generate Paths_<pkg>.hs and cabal-macros.h
      writeAutogenFiles verbosity pd lbi

      -- generate inplace-pkg-config
Ian Lynagh's avatar
Ian Lynagh committed
287 288 289 290
      case (library pd, libraryConfig lbi) of
          (Nothing, Nothing) -> return ()
          (Just lib, Just clbi) -> do
              cwd <- getCurrentDirectory
291
              let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
Ian Lynagh's avatar
Ian Lynagh committed
292 293
              let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
                                         pd lib lbi clbi
294 295 296 297
                  final_ipi = installedPkgInfo {
                                  Installed.installedPackageId = ipid,
                                  Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
                              }
298
                  content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
Ian Lynagh's avatar
Ian Lynagh committed
299 300
              writeFileAtomic (distdir </> "inplace-pkg-config") content
          _ -> error "Inconsistent lib components; can't happen?"
Ian Lynagh's avatar
Ian Lynagh committed
301 302

      let
Ian Lynagh's avatar
Ian Lynagh committed
303 304
          libBiModules lib = (libBuildInfo lib, libModules lib)
          exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
Ian Lynagh's avatar
Ian Lynagh committed
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
          biModuless = (maybeToList $ fmap libBiModules $ library pd)
                    ++ (map exeBiModules $ executables pd)
          buildableBiModuless = filter isBuildable biModuless
              where isBuildable (bi', _) = buildable bi'
          (bi, modules) = case buildableBiModuless of
                          [] -> error "No buildable component found"
                          [biModules] -> biModules
                          _ -> error ("XXX ghc-cabal can't handle " ++
                                      "more than one buildinfo yet")
          -- XXX Another Just...
          Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)

          dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
          forDeps f = concatMap f dep_pkgs

          -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
          packageHacks = case compilerFlavor (compiler lbi) of
            GHC -> hackRtsPackage
            _   -> id
          -- We don't link in the actual Haskell libraries of our
          -- dependencies, so the -u flags in the ldOptions of the rts
          -- package mean linking fails on OS X (it's ld is a tad
          -- stricter than gnu ld). Thus we remove the ldOptions for
          -- GHC's rts package:
          hackRtsPackage index =
330
            case PackageIndex.lookupPackageName index (PackageName "rts") of
331 332 333 334 335 336 337 338 339 340
              [(_,[rts])] ->
                 PackageIndex.insert rts{
                     Installed.ldOptions = [],
                     Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
                        -- GHC <= 6.12 had $topdir/gcc-lib in their
                        -- library-dirs for the rts package, which causes
                        -- problems when we try to use the in-tree mingw,
                        -- due to accidentally picking up the incompatible
                        -- libraries there.  So we filter out gcc-lib from
                        -- the RTS's library-dirs here.
Ian Lynagh's avatar
Ian Lynagh committed
341 342
              _ -> error "No (or multiple) ghc rts package is registered!!"

343
          dep_ids = map snd (externalPackageDeps lbi)
344

Ian Lynagh's avatar
Ian Lynagh committed
345 346 347
      let variablePrefix = directory ++ '_':distdir
      let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
                variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
348
                variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
349
                variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
Ian Lynagh's avatar
Ian Lynagh committed
350
                variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
351 352
                variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
                variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
Ian Lynagh's avatar
Ian Lynagh committed
353 354 355 356 357 358
                variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
                variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
                variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
                variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
                variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
                variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
359
                variablePrefix ++ "_CMM_SRCS  = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
360
                variablePrefix ++ "_DATA_FILES = "    ++ unwords (dataFiles pd),
Ian Lynagh's avatar
Ian Lynagh committed
361 362
                -- XXX This includes things it shouldn't, like:
                -- -odir dist-bootstrapping/build
Ian Lynagh's avatar
Ian Lynagh committed
363 364
                variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
                       (   programDefaultArgs ghcProg
Ian Lynagh's avatar
Ian Lynagh committed
365
                        ++ hcOptions GHC bi
366
                        ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
Ian Lynagh's avatar
Ian Lynagh committed
367
                        ++ programOverrideArgs ghcProg)),
Ian Lynagh's avatar
Ian Lynagh committed
368 369 370
                variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
                variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
                variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
371
                variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
Ian Lynagh's avatar
Ian Lynagh committed
372
                variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
373
                variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (wrap $ forDeps Installed.libraryDirs),
Ian Lynagh's avatar
Ian Lynagh committed
374
                variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
375 376
                variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions),
                variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi)]
Ian Lynagh's avatar
Ian Lynagh committed
377
      writeFile (distdir ++ "/package-data.mk") $ unlines xs
378 379 380
      writeFile (distdir ++ "/haddock-prologue.txt") $ 
          if null (description pd) then synopsis pd
                                   else description pd
Ian Lynagh's avatar
Ian Lynagh committed
381 382
  where
     escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
383
     wrap = map (\s -> "\'" ++ s ++ "\'")
384 385
     boolToYesNo True = "YES"
     boolToYesNo False = "NO"