GHC.hs 78.4 KB
Newer Older
1 2
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
tulcod's avatar
tulcod committed
3
{-# LANGUAGE CPP #-}
4

5 6 7
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.GHC
Simon Marlow's avatar
Simon Marlow committed
8
-- Copyright   :  Isaac Jones 2003-2007
9
-- License     :  BSD3
10
--
Duncan Coutts's avatar
Duncan Coutts committed
11
-- Maintainer  :  cabal-devel@haskell.org
12 13
-- Portability :  portable
--
Duncan Coutts's avatar
Duncan Coutts committed
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
-- This is a fairly large module. It contains most of the GHC-specific code for
-- configuring, building and installing packages. It also exports a function
-- for finding out what packages are already installed. Configuring involves
-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions
-- this version of ghc supports and returning a 'Compiler' value.
--
-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out
-- what packages are installed.
--
-- Building is somewhat complex as there is quite a bit of information to take
-- into account. We have to build libs and programs, possibly for profiling and
-- shared libs. We have to support building libraries that will be usable by
-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files
-- using ghc. Linking, especially for @split-objs@ is remarkably complex,
-- partly because there tend to be 1,000's of @.o@ files and this can often be
-- more than we can pass to the @ld@ or @ar@ programs in one go.
--
-- Installing for libs and exes involves finding the right files and copying
-- them to the right places. One of the more tricky things about this module is
-- remembering the layout of files in the build directory (which is not
-- explicitly documented) and thus what search dirs are used for various kinds
-- of files.
36 37

module Distribution.Simple.GHC (
38
        getGhcInfo,
39 40 41 42
        configure,
        getInstalledPackages,
        getInstalledPackagesMonitorFiles,
        getPackageDBContents,
43 44
        buildLib, buildFLib, buildExe,
        replLib, replFLib, replExe,
45
        startInterpreter,
46
        installLib, installFLib, installExe,
47
        libAbiHash,
48
        hcPkgInfo,
49
        registerPackage,
50
        componentGhcOptions,
Edsko de Vries's avatar
Edsko de Vries committed
51
        componentCcGhcOptions,
52 53 54
        getLibDir,
        isDynamic,
        getGlobalPackageDB,
55 56 57 58 59 60 61 62
        pkgRoot,
        -- * Constructing GHC environment files
        Internal.GhcEnvironmentFileEntry(..),
        Internal.simpleGhcEnvironmentFile,
        Internal.writeGhcEnvironmentFile,
        -- * Version-specific implementation quirks
        getImplInfo,
        GhcImplInfo(..)
63 64
 ) where

65 66
import Prelude ()
import Distribution.Compat.Prelude
67

68
import qualified Distribution.Simple.GHC.IPI642 as IPI642
69
import qualified Distribution.Simple.GHC.Internal as Internal
70
import Distribution.Simple.GHC.ImplInfo
71
import Distribution.PackageDescription.Utils (cabalBug)
72
import Distribution.PackageDescription as PD
73
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
74
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
75
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
76
import qualified Distribution.Simple.PackageIndex as PackageIndex
77
import Distribution.Simple.LocalBuildInfo
78
import Distribution.Types.ComponentLocalBuildInfo
79
import qualified Distribution.Simple.Hpc as Hpc
80
import Distribution.Simple.BuildPaths
81
import Distribution.Simple.Utils
82
import Distribution.Package
83
import qualified Distribution.ModuleName as ModuleName
84
import Distribution.ModuleName (ModuleName)
85
import Distribution.Simple.Program
86
import Distribution.Simple.Program.Builtin (runghcProgram)
87
import qualified Distribution.Simple.Program.HcPkg as HcPkg
88 89
import qualified Distribution.Simple.Program.Ar    as Ar
import qualified Distribution.Simple.Program.Ld    as Ld
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
90
import qualified Distribution.Simple.Program.Strip as Strip
91
import Distribution.Simple.Program.GHC
92 93
import Distribution.Simple.Setup
import qualified Distribution.Simple.Setup as Cabal
94
import Distribution.Simple.Compiler hiding (Flag)
95
import Distribution.Version
96
import Distribution.System
97
import Distribution.Verbosity
98
import Distribution.Text
99 100 101
import Distribution.Types.ForeignLib
import Distribution.Types.ForeignLibType
import Distribution.Types.ForeignLibOption
102
import Distribution.Types.UnqualComponentName
103
import Distribution.Utils.NubList
104
import Language.Haskell.Extension
105

106 107
import Control.Monad (msum)
import Data.Char (isLower)
108
import qualified Data.Map as Map
109
import System.Directory
110
         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing
tulcod's avatar
tulcod committed
111
         , canonicalizePath, removeFile, renameFile )
112
import System.FilePath          ( (</>), (<.>), takeExtension
113 114
                                , takeDirectory, replaceExtension
                                ,isRelative )
115
import qualified System.Info
tulcod's avatar
tulcod committed
116 117 118
#ifndef mingw32_HOST_OS
import System.Posix (createSymbolicLink)
#endif /* mingw32_HOST_OS */
119

120 121 122
-- -----------------------------------------------------------------------------
-- Configuring

123
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
124 125
          -> ProgramDb
          -> IO (Compiler, Maybe Platform, ProgramDb)
126
configure verbosity hcPath hcPkgPath conf0 = do
127

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
128
  (ghcProg, ghcVersion, progdb1) <-
129
    requireProgramVersion verbosity ghcProgram
130
      (orLaterVersion (mkVersion [6,11]))
131
      (userMaybeSpecifyPath "ghc" hcPath conf0)
132
  let implInfo = ghcVersionImplInfo ghcVersion
133 134 135 136

  -- This is slightly tricky, we have to configure ghc first, then we use the
  -- location of ghc to help find ghc-pkg in the case that the user did not
  -- specify the location of ghc-pkg directly:
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
137
  (ghcPkgProg, ghcPkgVersion, progdb2) <-
138 139 140
    requireProgramVersion verbosity ghcPkgProgram {
      programFindLocation = guessGhcPkgFromGhcPath ghcProg
    }
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
141
    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1)
142

143
  when (ghcVersion /= ghcPkgVersion) $ die' verbosity $
144
       "Version mismatch between ghc and ghc-pkg: "
145 146
    ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "
    ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion
147

148
  -- Likewise we try to find the matching hsc2hs and haddock programs.
149 150 151
  let hsc2hsProgram' = hsc2hsProgram {
                           programFindLocation = guessHsc2hsFromGhcPath ghcProg
                       }
152 153 154
      haddockProgram' = haddockProgram {
                           programFindLocation = guessHaddockFromGhcPath ghcProg
                       }
Edward Z. Yang's avatar
Edward Z. Yang committed
155 156 157
      hpcProgram' = hpcProgram {
                        programFindLocation = guessHpcFromGhcPath ghcProg
                    }
158 159 160
      runghcProgram' = runghcProgram {
                        programFindLocation = guessRunghcFromGhcPath ghcProg
                    }
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
161
      progdb3 = addKnownProgram haddockProgram' $
Edward Z. Yang's avatar
Edward Z. Yang committed
162
              addKnownProgram hsc2hsProgram' $
163 164
              addKnownProgram hpcProgram' $
              addKnownProgram runghcProgram' progdb2
165

166
  languages  <- Internal.getLanguages verbosity implInfo ghcProg
167
  extensions0 <- Internal.getExtensions verbosity implInfo ghcProg
168

169
  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg
170
  let ghcInfoMap = Map.fromList ghcInfo
171 172 173 174
      extensions = -- workaround https://ghc.haskell.org/ticket/11214
                   filterExt JavaScriptFFI $
                   -- see 'filterExtTH' comment below
                   filterExtTH $ extensions0
175

176 177 178 179
      -- starting with GHC 8.0, `TemplateHaskell` will be omitted from
      -- `--supported-extensions` when it's not available.
      -- for older GHCs we can use the "Have interpreter" property to
      -- filter out `TemplateHaskell`
180 181 182 183 184 185
      filterExtTH | ghcVersion < mkVersion [8]
                   , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap
                   = filterExt TemplateHaskell
                  | otherwise = id

      filterExt ext = filter ((/= EnableExtension ext) . fst)
186

187
  let comp = Compiler {
188
        compilerId         = CompilerId GHC ghcVersion,
189 190
        compilerAbiTag     = NoAbiTag,
        compilerCompat     = [],
191 192 193
        compilerLanguages  = languages,
        compilerExtensions = extensions,
        compilerProperties = ghcInfoMap
194
      }
195
      compPlatform = Internal.targetPlatform ghcInfo
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
196
      -- configure gcc and ld
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
197 198
      progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3
  return (comp, compPlatform, progdb4)
199

200 201 202
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find
-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking
-- for a versioned or unversioned ghc-pkg in the same dir, that is:
203
--
204
-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)
205 206 207
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
--
208 209
guessToolFromGhcPath :: Program -> ConfiguredProgram
                     -> Verbosity -> ProgramSearchPath
210
                     -> IO (Maybe (FilePath, [FilePath]))
211 212
guessToolFromGhcPath tool ghcProg verbosity searchpath
  = do let toolname          = programName tool
213 214 215 216 217
           given_path        = programPath ghcProg
           given_dir         = takeDirectory given_path
       real_path <- canonicalizePath given_path
       let real_dir           = takeDirectory real_path
           versionSuffix path = takeVersionSuffix (dropExeExtension path)
218 219
           given_suf = versionSuffix given_path
           real_suf  = versionSuffix real_path
220
           guessNormal       dir = dir </> toolname <.> exeExtension
221 222 223 224 225 226 227 228 229
           guessGhcVersioned dir suf = dir </> (toolname ++ "-ghc" ++ suf)
                                           <.> exeExtension
           guessVersioned    dir suf = dir </> (toolname ++ suf)
                                           <.> exeExtension
           mkGuesses dir suf | null suf  = [guessNormal dir]
                             | otherwise = [guessGhcVersioned dir suf,
                                            guessVersioned dir suf,
                                            guessNormal dir]
           guesses = mkGuesses given_dir given_suf ++
230 231
                            if real_path == given_path
                                then []
232
                                else mkGuesses real_dir real_suf
233
       info verbosity $ "looking for tool " ++ toolname
234
         ++ " near compiler in " ++ given_dir
235
       debug verbosity $ "candidate locations: " ++ show guesses
236
       exists <- traverse doesFileExist guesses
237
       case [ file | (file, True) <- zip guesses exists ] of
refold's avatar
refold committed
238 239
                   -- If we can't find it near ghc, fall back to the usual
                   -- method.
240 241
         []     -> programFindLocation tool verbosity searchpath
         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp
242 243 244 245
                      let lookedAt = map fst
                                   . takeWhile (\(_file, exist) -> not exist)
                                   $ zip guesses exists
                      return (Just (fp, lookedAt))
246 247

  where takeVersionSuffix :: FilePath -> String
248
        takeVersionSuffix = takeWhileEndLE isSuffixChar
249 250 251

        isSuffixChar :: Char -> Bool
        isSuffixChar c = isDigit c || c == '.' || c == '-'
252

253 254 255 256 257 258 259 260
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding ghc-pkg, we try looking for both a versioned and unversioned
-- ghc-pkg in the same dir, that is:
--
-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
--
261
guessGhcPkgFromGhcPath :: ConfiguredProgram
262 263
                       -> Verbosity -> ProgramSearchPath
                       -> IO (Maybe (FilePath, [FilePath]))
264
guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram
265 266 267 268 269 270 271 272 273

-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding hsc2hs, we try looking for both a versioned and unversioned
-- hsc2hs in the same dir, that is:
--
-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs(.exe)
--
274
guessHsc2hsFromGhcPath :: ConfiguredProgram
275 276
                       -> Verbosity -> ProgramSearchPath
                       -> IO (Maybe (FilePath, [FilePath]))
277
guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram
278

279 280 281 282 283 284 285 286 287
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding haddock, we try looking for both a versioned and unversioned
-- haddock in the same dir, that is:
--
-- > /usr/local/bin/haddock-ghc-6.6.1(.exe)
-- > /usr/local/bin/haddock-6.6.1(.exe)
-- > /usr/local/bin/haddock(.exe)
--
guessHaddockFromGhcPath :: ConfiguredProgram
288 289
                       -> Verbosity -> ProgramSearchPath
                       -> IO (Maybe (FilePath, [FilePath]))
290 291
guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram

Edward Z. Yang's avatar
Edward Z. Yang committed
292 293 294 295 296
guessHpcFromGhcPath :: ConfiguredProgram
                       -> Verbosity -> ProgramSearchPath
                       -> IO (Maybe (FilePath, [FilePath]))
guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram

297 298 299 300 301
guessRunghcFromGhcPath :: ConfiguredProgram
                       -> Verbosity -> ProgramSearchPath
                       -> IO (Maybe (FilePath, [FilePath]))
guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram

Edward Z. Yang's avatar
Edward Z. Yang committed
302

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
303
getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
304 305 306 307
getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg
  where
    Just version = programVersion ghcProg
    implInfo = ghcVersionImplInfo version
308

309
-- | Given a single package DB, return all installed packages.
310
getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb
311
                        -> IO InstalledPackageIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
312 313 314
getPackageDBContents verbosity packagedb progdb = do
  pkgss <- getInstalledPackages' verbosity [packagedb] progdb
  toPackageIndex verbosity pkgss progdb
315 316

-- | Given a package DB stack, return all installed packages.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
317
getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack
318
                     -> ProgramDb
319
                     -> IO InstalledPackageIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
320
getInstalledPackages verbosity comp packagedbs progdb = do
321 322
  checkPackageDbEnvVar verbosity
  checkPackageDbStack verbosity comp packagedbs
ttuegel's avatar
ttuegel committed
323
  pkgss <- getInstalledPackages' verbosity packagedbs progdb
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
324
  index <- toPackageIndex verbosity pkgss progdb
325
  return $! hackRtsPackage index
326 327 328

  where
    hackRtsPackage index =
329
      case PackageIndex.lookupPackageName index (mkPackageName "rts") of
330 331
        [(_,[rts])]
           -> PackageIndex.insert (removeMingwIncludeDir rts) index
332
        _  -> index -- No (or multiple) ghc rts package is registered!!
Ian D. Bollinger's avatar
Ian D. Bollinger committed
333
                    -- Feh, whatever, the ghc test suite does some crazy stuff.
334

335 336 337 338 339
-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
-- @PackageIndex@. Helper function used by 'getPackageDBContents' and
-- 'getInstalledPackages'.
toPackageIndex :: Verbosity
               -> [(PackageDB, [InstalledPackageInfo])]
340
               -> ProgramDb
341
               -> IO InstalledPackageIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
342
toPackageIndex verbosity pkgss progdb = do
343 344 345
  -- On Windows, various fields have $topdir/foo rather than full
  -- paths. We need to substitute the right value in so that when
  -- we, for example, call gcc, we have proper paths to give it.
346
  topDir <- getLibDir' verbosity ghcProg
347
  let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
348
                | (_, pkgs) <- pkgss ]
349
  return $! mconcat indices
350 351

  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
352
    Just ghcProg = lookupProgram ghcProgram progdb
353

354 355
getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir verbosity lbi =
356
    dropWhileEndLE isSpace `fmap`
357
     getDbProgramOutput verbosity ghcProgram
refold's avatar
refold committed
358
     (withPrograms lbi) ["--print-libdir"]
359

360 361
getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' verbosity ghcProg =
362
    dropWhileEndLE isSpace `fmap`
363
     getProgramOutput verbosity ghcProg ["--print-libdir"]
364

365

366
-- | Return the 'FilePath' to the global GHC package database.
367 368
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB verbosity ghcProg =
369
    dropWhileEndLE isSpace `fmap`
370
     getProgramOutput verbosity ghcProg ["--print-global-package-db"]
371

372
-- | Return the 'FilePath' to the per-user GHC package database.
373
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> NoCallStackIO FilePath
374
getUserPackageDB _verbosity ghcProg platform = do
375 376 377
    -- It's rather annoying that we have to reconstruct this, because ghc
    -- hides this information from us otherwise. But for certain use cases
    -- like change monitoring it really can't remain hidden.
378 379 380
    appdir <- getAppUserDataDirectory "ghc"
    return (appdir </> platformAndVersion </> packageConfFileName)
  where
381 382
    platformAndVersion = Internal.ghcPlatformAndVersionString
                           platform ghcVersion
383
    packageConfFileName
384
      | ghcVersion >= mkVersion [6,12]   = "package.conf.d"
385 386 387
      | otherwise                        = "package.conf"
    Just ghcVersion = programVersion ghcProg

388 389 390
checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar verbosity =
    Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH"
ttuegel's avatar
ttuegel committed
391

392 393 394 395 396
checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO ()
checkPackageDbStack verbosity comp =
    if flagPackageConf implInfo
      then checkPackageDbStackPre76 verbosity
      else checkPackageDbStackPost76 verbosity
397
  where implInfo = ghcVersionImplInfo (compilerVersion comp)
398

399 400
checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO ()
checkPackageDbStackPost76 _ (GlobalPackageDB:rest)
401
  | GlobalPackageDB `notElem` rest = return ()
402
checkPackageDbStackPost76 verbosity rest
403
  | GlobalPackageDB `elem` rest =
404
  die' verbosity $ "If the global package db is specified, it must be "
405
     ++ "specified first and cannot be specified multiple times"
406
checkPackageDbStackPost76 _ _ = return ()
407

408 409
checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO ()
checkPackageDbStackPre76 _ (GlobalPackageDB:rest)
410
  | GlobalPackageDB `notElem` rest = return ()
411
checkPackageDbStackPre76 verbosity rest
412
  | GlobalPackageDB `notElem` rest =
413
  die' verbosity $ "With current ghc versions the global package db is always used "
414 415
     ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"
     ++ "see http://hackage.haskell.org/trac/ghc/ticket/5977"
416 417
checkPackageDbStackPre76 verbosity _ =
  die' verbosity $ "If the global package db is specified, it must be "
418 419
     ++ "specified first and cannot be specified multiple times"

420 421 422 423 424 425 426 427
-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This
-- breaks when you want to use a different gcc, so we need to filter
-- it out.
removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir pkg =
    let ids = InstalledPackageInfo.includeDirs pkg
        ids' = filter (not . ("mingw" `isSuffixOf`)) ids
    in pkg { InstalledPackageInfo.includeDirs = ids' }
428

429 430
-- | Get the packages from specific PackageDBs, not cumulative.
--
431
getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb
432
                     -> IO [(PackageDB, [InstalledPackageInfo])]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
433
getInstalledPackages' verbosity packagedbs progdb
434
  | ghcVersion >= mkVersion [6,9] =
435
  sequenceA
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
436
    [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
437
         return (packagedb, pkgs)
438
    | packagedb <- packagedbs ]
439

440
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
441
    Just ghcProg    = lookupProgram ghcProgram progdb
442 443
    Just ghcVersion = programVersion ghcProg

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
444 445
getInstalledPackages' verbosity packagedbs progdb = do
    str <- getDbProgramOutput verbosity ghcPkgProgram progdb ["list"]
446 447
    let pkgFiles = [ init line | line <- lines str, last line == ':' ]
        dbFile packagedb = case (packagedb, pkgFiles) of
448 449 450 451
          (GlobalPackageDB, global:_)      -> return $ Just global
          (UserPackageDB,  _global:user:_) -> return $ Just user
          (UserPackageDB,  _global:_)      -> return $ Nothing
          (SpecificPackageDB specific, _)  -> return $ Just specific
452
          _ -> die' verbosity "cannot read ghc-pkg package listing"
453 454
    pkgFiles' <- traverse dbFile packagedbs
    sequenceA [ withFileContents file $ \content -> do
455 456
                  pkgs <- readPackages file content
                  return (db, pkgs)
457
              | (db , Just file) <- zip packagedbs pkgFiles' ]
458 459 460 461 462
  where
    -- Depending on the version of ghc we use a different type's Read
    -- instance to parse the package file and then convert.
    -- It's a bit yuck. But that's what we get for using Read/Show.
    readPackages
463
      | ghcVersion >= mkVersion [6,4,2]
464 465 466
      = \file content -> case reads content of
          [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)
          _           -> failToRead file
467
      -- We dropped support for 6.4.2 and earlier.
468
      | otherwise
469
      = \file _ -> failToRead file
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
470
    Just ghcProg = lookupProgram ghcProgram progdb
471
    Just ghcVersion = programVersion ghcProg
472
    failToRead file = die' verbosity $ "cannot read ghc package database " ++ file
473

474
getInstalledPackagesMonitorFiles :: Verbosity -> Platform
475
                                 -> ProgramDb
476 477 478
                                 -> [PackageDB]
                                 -> IO [FilePath]
getInstalledPackagesMonitorFiles verbosity platform progdb =
479
    traverse getPackageDBPath
480 481 482 483 484 485 486 487 488 489 490
  where
    getPackageDBPath :: PackageDB -> IO FilePath
    getPackageDBPath GlobalPackageDB =
      selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg

    getPackageDBPath UserPackageDB =
      selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform

    getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path

    -- GHC has old style file dbs, and new style directory dbs.
491 492 493
    -- Note that for dir style dbs, we only need to monitor the cache file, not
    -- the whole directory. The ghc program itself only reads the cache file
    -- so it's safe to only monitor this one file.
494 495 496 497 498 499 500 501
    selectMonitorFile path = do
      isFileStyle <- doesFileExist path
      if isFileStyle then return path
                     else return (path </> "package.cache")

    Just ghcProg = lookupProgram ghcProgram progdb


502
-- -----------------------------------------------------------------------------
503
-- Building a library
504

505
buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)
506 507 508 509 510
                  -> PackageDescription -> LocalBuildInfo
                  -> Library            -> ComponentLocalBuildInfo -> IO ()
buildLib = buildOrReplLib False
replLib  = buildOrReplLib True

511
buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)
512 513
               -> PackageDescription -> LocalBuildInfo
               -> Library            -> ComponentLocalBuildInfo -> IO ()
514
buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
515
  let uid = componentUnitId clbi
516
      libTargetDir = componentBuildDir lbi clbi
517
      whenVanillaLib forceVanilla =
518 519
        when (forceVanilla || withVanillaLib lbi)
      whenProfLib = when (withProfLib lbi)
520
      whenSharedLib forceShared =
521
        when (forceShared || withSharedLib lbi)
Moritz Angermann's avatar
Moritz Angermann committed
522 523
      whenStaticLib forceStatic =
        when (forceStatic || withStaticLib lbi)
524
      whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)
525
      ifReplLib = when forRepl
526
      comp = compiler lbi
527
      ghcVersion = compilerVersion comp
528
      implInfo  = getImplInfo comp
529
      platform@(Platform _hostArch hostOS) = hostPlatform lbi
530
      has_code = not (componentIsIndefinite clbi)
531

532
  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
533
  let runGhcProg = runGHC verbosity ghcProg comp platform
534

535
  libBi <- hackThreadedFlag verbosity
536
             comp (withProfLib lbi) (libBuildInfo lib)
537

538 539
  let isGhcDynamic        = isDynamic comp
      dynamicTooSupported = supportsDynamicToo comp
540
      doingTH = usesTemplateHaskellOrQQ libBi
refold's avatar
refold committed
541 542
      forceVanillaLib = doingTH && not isGhcDynamic
      forceSharedLib  = doingTH &&     isGhcDynamic
543
      -- TH always needs default libs, even when building for profiling
544

545 546
  -- Determine if program coverage should be enabled and if so, what
  -- '-hpcdir' should be.
547
  let isCoverageEnabled = libCoverage lbi
548 549 550 551
      -- TODO: Historically HPC files have been put into a directory which
      -- has the package name.  I'm going to avoid changing this for
      -- now, but it would probably be better for this to be the
      -- component ID instead...
552
      pkg_name = display (PD.package pkg_descr)
553
      distPref = fromFlag $ configDistPref $ configFlags lbi
554
      hpcdir way
555
        | forRepl = mempty  -- HPC is not supported in ghci
556
        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
557
        | otherwise = mempty
558

559
  createDirectoryIfMissingVerbose verbosity True libTargetDir
refold's avatar
refold committed
560 561
  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?
562
  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)
563
      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir
564
      vanillaOpts = baseOpts `mappend` mempty {
565
                      ghcOptMode         = toFlag GhcModeMake,
566
                      ghcOptNumJobs      = numJobs,
567
                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,
568
                      ghcOptHPCDir       = hpcdir Hpc.Vanilla
569 570
                    }

571 572
      profOpts    = vanillaOpts `mappend` mempty {
                      ghcOptProfilingMode = toFlag True,
573 574
                      ghcOptProfilingAuto = Internal.profDetailLevelFlag True
                                              (withProfLibDetail lbi),
575 576 577 578 579
                      ghcOptHiSuffix      = toFlag "p_hi",
                      ghcOptObjSuffix     = toFlag "p_o",
                      ghcOptExtra         = toNubListR $ hcProfOptions GHC libBi,
                      ghcOptHPCDir        = hpcdir Hpc.Prof
                    }
580

581
      sharedOpts  = vanillaOpts `mappend` mempty {
582 583 584 585
                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                      ghcOptFPic        = toFlag True,
                      ghcOptHiSuffix    = toFlag "dyn_hi",
                      ghcOptObjSuffix   = toFlag "dyn_o",
586 587
                      ghcOptExtra       = toNubListR $ hcSharedOptions GHC libBi,
                      ghcOptHPCDir      = hpcdir Hpc.Dyn
588
                    }
589
      linkerOpts = mempty {
590 591 592 593 594 595
                      ghcOptLinkOptions       = toNubListR $ PD.ldOptions libBi,
                      ghcOptLinkLibs          = toNubListR $ extraLibs libBi,
                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs libBi,
                      ghcOptLinkFrameworks    = toNubListR $
                                                PD.frameworks libBi,
                      ghcOptLinkFrameworkDirs = toNubListR $
596
                                                PD.extraFrameworkDirs libBi,
597 598
                      ghcOptInputFiles     = toNubListR
                                             [libTargetDir </> x | x <- cObjs]
599
                   }
600
      replOpts    = vanillaOpts {
601 602
                      ghcOptExtra        = overNubListR
                                           Internal.filterGhciFlags $
603
                                           ghcOptExtra vanillaOpts,
604
                      ghcOptNumJobs      = mempty
605
                    }
606
                    `mappend` linkerOpts
607
                    `mappend` mempty {
608 609 610
                      ghcOptMode         = toFlag GhcModeInteractive,
                      ghcOptOptimisation = toFlag GhcNoOptimisation
                    }
611

612
      vanillaSharedOpts = vanillaOpts `mappend` mempty {
613 614
                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,
                      ghcOptDynHiSuffix  = toFlag "dyn_hi",
615 616
                      ghcOptDynObjSuffix = toFlag "dyn_o",
                      ghcOptHPCDir       = hpcdir Hpc.Dyn
617
                    }
618

619
  unless (forRepl || null (allLibModules lib clbi)) $
620 621
    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)
622 623 624
           useDynToo = dynamicTooSupported &&
                       (forceVanillaLib || withVanillaLib lbi) &&
                       (forceSharedLib  || withSharedLib  lbi) &&
625
                       null (hcSharedOptions GHC libBi)
626 627 628 629
       if not has_code
        then vanilla
        else
         if useDynToo
630 631 632
          then do
              runGhcProg vanillaSharedOpts
              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
633
                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) ->
634 635 636 637 638 639 640 641 642 643 644
                    -- When the vanilla and shared library builds are done
                    -- in one pass, only one set of HPC module interfaces
                    -- are generated. This set should suffice for both
                    -- static and dynamically linked executables. We copy
                    -- the modules interfaces so they are available under
                    -- both ways.
                    copyDirectoryRecursive verbosity dynDir vanillaDir
                _ -> return ()
          else if isGhcDynamic
            then do shared;  vanilla
            else do vanilla; shared
645
       whenProfLib (runGhcProg profOpts)
646 647

  -- build any C sources
648
  unless (not has_code || null (cSources libBi)) $ do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
649 650
    info verbosity "Building C Sources..."
    sequence_
651 652
      [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo
                               lbi libBi clbi libTargetDir filename
653 654 655 656 657
               vanillaCcOpts = if isGhcDynamic
                               -- Dynamic GHC requires C sources to be built
                               -- with -fPIC for REPL to work. See #2207.
                               then baseCcOpts { ghcOptFPic = toFlag True }
                               else baseCcOpts
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
658 659 660 661 662 663 664 665 666 667 668
               profCcOpts    = vanillaCcOpts `mappend` mempty {
                                 ghcOptProfilingMode = toFlag True,
                                 ghcOptObjSuffix     = toFlag "p_o"
                               }
               sharedCcOpts  = vanillaCcOpts `mappend` mempty {
                                 ghcOptFPic        = toFlag True,
                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                                 ghcOptObjSuffix   = toFlag "dyn_o"
                               }
               odir          = fromFlag (ghcOptObjDir vanillaCcOpts)
           createDirectoryIfMissingVerbose verbosity True odir
669 670 671 672 673 674 675
           let runGhcProgIfNeeded ccOpts = do
                 needsRecomp <- checkNeedsRecompilation filename ccOpts
                 when needsRecomp $ runGhcProg ccOpts
           runGhcProgIfNeeded vanillaCcOpts
           unless forRepl $
             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
676
      | filename <- cSources libBi]
677

678 679 680
  -- TODO: problem here is we need the .c files built first, so we can load them
  -- with ghci, but .c files can depend on .h files generated by ghc by ffi
  -- exports.
681

682
  when has_code . ifReplLib $ do
683
    when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"
684
    ifReplLib (runGhcProg replOpts)
685

686
  -- link:
687
  when has_code . unless forRepl $ do
688 689 690 691 692
    info verbosity "Linking..."
    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))
                      (cSources libBi)
        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
                      (cSources libBi)
693 694 695 696
        compiler_id = compilerId (compiler lbi)
        vanillaLibFilePath = libTargetDir </> mkLibName uid
        profileLibFilePath = libTargetDir </> mkProfLibName uid
        sharedLibFilePath  = libTargetDir </> mkSharedLibName compiler_id uid
Moritz Angermann's avatar
Moritz Angermann committed
697
        staticLibFilePath  = libTargetDir </> mkStaticLibName compiler_id uid
698
        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName uid
699
        libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest
700
        sharedLibInstallPath = libInstallPath </> mkSharedLibName compiler_id uid
701

702
    stubObjs <- catMaybes <$> sequenceA
703 704
      [ findFileWithExtension [objExtension] [libTargetDir]
          (ModuleName.toFilePath x ++"_stub")
705
      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
706
      , x <- allLibModules lib clbi ]
707
    stubProfObjs <- catMaybes <$> sequenceA
708 709
      [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
          (ModuleName.toFilePath x ++"_stub")
710
      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
711
      , x <- allLibModules lib clbi ]
712
    stubSharedObjs <- catMaybes <$> sequenceA
713 714
      [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
          (ModuleName.toFilePath x ++"_stub")
715
      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
716
      , x <- allLibModules lib clbi ]
717

718
    hObjs     <- Internal.getHaskellObjects implInfo lib lbi clbi
719 720
                      libTargetDir objExtension True
    hProfObjs <-
721
      if withProfLib lbi
722
              then Internal.getHaskellObjects implInfo lib lbi clbi
723 724 725
                      libTargetDir ("p_" ++ objExtension) True
              else return []
    hSharedObjs <-
726
      if withSharedLib lbi
727
              then Internal.getHaskellObjects implInfo lib lbi clbi
728 729 730 731
                      libTargetDir ("dyn_" ++ objExtension) False
              else return []

    unless (null hObjs && null cObjs && null stubObjs) $ do
732
      rpaths <- getRPaths lbi clbi
733 734 735 736 737 738 739 740 741 742 743 744