Cabal/src/Distribution/Simple/GHCJS.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE TupleSections #-}
   5
   6 module Distribution.Simple.GHCJS
   7   ( getGhcInfo
   8   , configure
   9   , getInstalledPackages
  10   , getInstalledPackagesMonitorFiles
  11   , getPackageDBContents
  12   , buildLib
  13   , buildFLib
  14   , buildExe
  15   , replLib
  16   , replFLib
  17   , replExe
  18   , startInterpreter
  19   , installLib
  20   , installFLib
  21   , installExe
  22   , libAbiHash
  23   , hcPkgInfo
  24   , registerPackage
  25   , componentGhcOptions
  26   , Internal.componentCcGhcOptions
  27   , getLibDir
  28   , isDynamic
  29   , getGlobalPackageDB
  30   , pkgRoot
  31   , runCmd
  32
  33     -- * Constructing and deconstructing GHC environment files
  34   , Internal.GhcEnvironmentFileEntry (..)
  35   , Internal.simpleGhcEnvironmentFile
  36   , Internal.renderGhcEnvironmentFile
  37   , Internal.writeGhcEnvironmentFile
  38   , Internal.ghcPlatformAndVersionString
  39   , readGhcEnvironmentFile
  40   , parseGhcEnvironmentFile
  41   , ParseErrorExc (..)
  42
  43     -- * Version-specific implementation quirks
  44   , getImplInfo
  45   , GhcImplInfo (..)
  46   ) where
  47
  48 import Distribution.Compat.Prelude
  49 import Prelude ()
  50
  51 import Distribution.CabalSpecVersion
  52 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
  53 import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
  54 import Distribution.ModuleName (ModuleName)
  55 import qualified Distribution.ModuleName as ModuleName
  56 import Distribution.Package
  57 import Distribution.PackageDescription as PD
  58 import Distribution.PackageDescription.Utils (cabalBug)
  59 import Distribution.Pretty
  60 import Distribution.Simple.BuildPaths
  61 import Distribution.Simple.Compiler
  62 import Distribution.Simple.Errors
  63 import Distribution.Simple.Flag
  64 import Distribution.Simple.GHC.EnvironmentParser
  65 import Distribution.Simple.GHC.ImplInfo
  66 import qualified Distribution.Simple.GHC.Internal as Internal
  67 import qualified Distribution.Simple.Hpc as Hpc
  68 import Distribution.Simple.LocalBuildInfo
  69 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  70 import qualified Distribution.Simple.PackageIndex as PackageIndex
  71 import Distribution.Simple.PreProcess.Types
  72 import Distribution.Simple.Program
  73 import Distribution.Simple.Program.GHC
  74 import qualified Distribution.Simple.Program.HcPkg as HcPkg
  75 import qualified Distribution.Simple.Program.Strip as Strip
  76 import Distribution.Simple.Setup.Common
  77 import Distribution.Simple.Utils
  78 import Distribution.System
  79 import Distribution.Types.ComponentLocalBuildInfo
  80 import Distribution.Types.PackageName.Magic
  81 import Distribution.Types.ParStrat
  82 import Distribution.Utils.NubList
  83 import Distribution.Utils.Path
  84 import Distribution.Verbosity (Verbosity)
  85 import Distribution.Version
  86
  87 import Control.Monad (msum)
  88 import Data.Char (isLower)
  89 import qualified Data.Map as Map
  90 import System.Directory
  91   ( canonicalizePath
  92   , createDirectoryIfMissing
  93   , doesFileExist
  94   , getAppUserDataDirectory
  95   , removeFile
  96   , renameFile
  97   )
  98 import System.FilePath
  99   ( isRelative
 100   , replaceExtension
 101   , takeDirectory
 102   , takeExtension
 103   , (<.>)
 104   , (</>)
 105   )
 106 import qualified System.Info
 107
 108 -- -----------------------------------------------------------------------------
 109 -- Configuring
 110
 111 configure
 112   :: Verbosity
 113   -> Maybe FilePath
 114   -> Maybe FilePath
 115   -> ProgramDb
 116   -> IO (Compiler, Maybe Platform, ProgramDb)
 117 configure verbosity hcPath hcPkgPath conf0 = do
 118   (ghcjsProg, ghcjsVersion, progdb1) <-
 119     requireProgramVersion
 120       verbosity
 121       ghcjsProgram
 122       (orLaterVersion (mkVersion [0, 1]))
 123       (userMaybeSpecifyPath "ghcjs" hcPath conf0)
 124
 125   Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)
 126   unless (ghcjsGhcVersion < mkVersion [8, 8]) $
 127     warn verbosity $
 128       "Unknown/unsupported 'ghc' version detected "
 129         ++ "(Cabal "
 130         ++ prettyShow cabalVersion
 131         ++ " supports 'ghc' version < 8.8): "
 132         ++ programPath ghcjsProg
 133         ++ " is based on GHC version "
 134         ++ prettyShow ghcjsGhcVersion
 135
 136   let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion
 137
 138   -- This is slightly tricky, we have to configure ghc first, then we use the
 139   -- location of ghc to help find ghc-pkg in the case that the user did not
 140   -- specify the location of ghc-pkg directly:
 141   (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-
 142     requireProgramVersion
 143       verbosity
 144       ghcjsPkgProgram
 145         { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
 146         }
 147       anyVersion
 148       (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)
 149
 150   Just ghcjsPkgGhcjsVersion <-
 151     findGhcjsPkgGhcjsVersion
 152       verbosity
 153       (programPath ghcjsPkgProg)
 154
 155   when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $
 156     dieWithException verbosity $
 157       VersionMismatchJS
 158         (programPath ghcjsProg)
 159         ghcjsVersion
 160         (programPath ghcjsPkgProg)
 161         ghcjsPkgGhcjsVersion
 162
 163   when (ghcjsGhcVersion /= ghcjsPkgVersion) $
 164     dieWithException verbosity $
 165       VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion
 166
 167   -- Likewise we try to find the matching hsc2hs and haddock programs.
 168   let hsc2hsProgram' =
 169         hsc2hsProgram
 170           { programFindLocation =
 171               guessHsc2hsFromGhcjsPath ghcjsProg
 172           }
 173       haddockProgram' =
 174         haddockProgram
 175           { programFindLocation =
 176               guessHaddockFromGhcjsPath ghcjsProg
 177           }
 178       hpcProgram' =
 179         hpcProgram
 180           { programFindLocation = guessHpcFromGhcjsPath ghcjsProg
 181           }
 182       {-
 183       runghcProgram' = runghcProgram {
 184                         programFindLocation = guessRunghcFromGhcjsPath ghcjsProg
 185                     } -}
 186       progdb3 =
 187         addKnownProgram haddockProgram' $
 188           addKnownProgram hsc2hsProgram' $
 189             addKnownProgram hpcProgram' $
 190               {- addKnownProgram runghcProgram' -} progdb2
 191
 192   languages <- Internal.getLanguages verbosity implInfo ghcjsProg
 193   extensions <- Internal.getExtensions verbosity implInfo ghcjsProg
 194
 195   ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
 196   let ghcInfoMap = Map.fromList ghcjsInfo
 197
 198   let comp =
 199         Compiler
 200           { compilerId = CompilerId GHCJS ghcjsVersion
 201           , compilerAbiTag =
 202               AbiTag $
 203                 "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion)
 204           , compilerCompat = [CompilerId GHC ghcjsGhcVersion]
 205           , compilerLanguages = languages
 206           , compilerExtensions = extensions
 207           , compilerProperties = ghcInfoMap
 208           }
 209       compPlatform = Internal.targetPlatform ghcjsInfo
 210   return (comp, compPlatform, progdb3)
 211
 212 guessGhcjsPkgFromGhcjsPath
 213   :: ConfiguredProgram
 214   -> Verbosity
 215   -> ProgramSearchPath
 216   -> IO (Maybe (FilePath, [FilePath]))
 217 guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram
 218
 219 guessHsc2hsFromGhcjsPath
 220   :: ConfiguredProgram
 221   -> Verbosity
 222   -> ProgramSearchPath
 223   -> IO (Maybe (FilePath, [FilePath]))
 224 guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram
 225
 226 guessHaddockFromGhcjsPath
 227   :: ConfiguredProgram
 228   -> Verbosity
 229   -> ProgramSearchPath
 230   -> IO (Maybe (FilePath, [FilePath]))
 231 guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram
 232
 233 guessHpcFromGhcjsPath
 234   :: ConfiguredProgram
 235   -> Verbosity
 236   -> ProgramSearchPath
 237   -> IO (Maybe (FilePath, [FilePath]))
 238 guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram
 239
 240 guessToolFromGhcjsPath
 241   :: Program
 242   -> ConfiguredProgram
 243   -> Verbosity
 244   -> ProgramSearchPath
 245   -> IO (Maybe (FilePath, [FilePath]))
 246 guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath =
 247   do
 248     let toolname = programName tool
 249         given_path = programPath ghcjsProg
 250         given_dir = takeDirectory given_path
 251     real_path <- canonicalizePath given_path
 252     let real_dir = takeDirectory real_path
 253         versionSuffix path = takeVersionSuffix (dropExeExtension path)
 254         given_suf = versionSuffix given_path
 255         real_suf = versionSuffix real_path
 256         guessNormal dir = dir </> toolname <.> exeExtension buildPlatform
 257         guessGhcjs dir =
 258           dir
 259             </> (toolname ++ "-ghcjs")
 260               <.> exeExtension buildPlatform
 261         guessGhcjsVersioned dir suf =
 262           dir
 263             </> (toolname ++ "-ghcjs" ++ suf)
 264               <.> exeExtension buildPlatform
 265         guessVersioned dir suf =
 266           dir
 267             </> (toolname ++ suf)
 268               <.> exeExtension buildPlatform
 269         mkGuesses dir suf
 270           | null suf = [guessGhcjs dir, guessNormal dir]
 271           | otherwise =
 272               [ guessGhcjsVersioned dir suf
 273               , guessVersioned dir suf
 274               , guessGhcjs dir
 275               , guessNormal dir
 276               ]
 277         guesses =
 278           mkGuesses given_dir given_suf
 279             ++ if real_path == given_path
 280               then []
 281               else mkGuesses real_dir real_suf
 282     info verbosity $
 283       "looking for tool "
 284         ++ toolname
 285         ++ " near compiler in "
 286         ++ given_dir
 287     debug verbosity $ "candidate locations: " ++ show guesses
 288     exists <- traverse doesFileExist guesses
 289     case [file | (file, True) <- zip guesses exists] of
 290       -- If we can't find it near ghc, fall back to the usual
 291       -- method.
 292       [] -> programFindLocation tool verbosity searchpath
 293       (fp : _) -> do
 294         info verbosity $ "found " ++ toolname ++ " in " ++ fp
 295         let lookedAt =
 296               map fst
 297                 . takeWhile (\(_file, exist) -> not exist)
 298                 $ zip guesses exists
 299         return (Just (fp, lookedAt))
 300   where
 301     takeVersionSuffix :: FilePath -> String
 302     takeVersionSuffix = takeWhileEndLE isSuffixChar
 303
 304     isSuffixChar :: Char -> Bool
 305     isSuffixChar c = isDigit c || c == '.' || c == '-'
 306
 307 getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
 308 getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg
 309   where
 310     version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg
 311     implInfo = ghcVersionImplInfo version
 312
 313 -- | Given a single package DB, return all installed packages.
 314 getPackageDBContents
 315   :: Verbosity
 316   -> PackageDB
 317   -> ProgramDb
 318   -> IO InstalledPackageIndex
 319 getPackageDBContents verbosity packagedb progdb = do
 320   pkgss <- getInstalledPackages' verbosity [packagedb] progdb
 321   toPackageIndex verbosity pkgss progdb
 322
 323 -- | Given a package DB stack, return all installed packages.
 324 getInstalledPackages
 325   :: Verbosity
 326   -> PackageDBStack
 327   -> ProgramDb
 328   -> IO InstalledPackageIndex
 329 getInstalledPackages verbosity packagedbs progdb = do
 330   checkPackageDbEnvVar verbosity
 331   checkPackageDbStack verbosity packagedbs
 332   pkgss <- getInstalledPackages' verbosity packagedbs progdb
 333   index <- toPackageIndex verbosity pkgss progdb
 334   return $! index
 335
 336 toPackageIndex
 337   :: Verbosity
 338   -> [(PackageDB, [InstalledPackageInfo])]
 339   -> ProgramDb
 340   -> IO InstalledPackageIndex
 341 toPackageIndex verbosity pkgss progdb = do
 342   -- On Windows, various fields have $topdir/foo rather than full
 343   -- paths. We need to substitute the right value in so that when
 344   -- we, for example, call gcc, we have proper paths to give it.
 345   topDir <- getLibDir' verbosity ghcjsProg
 346   let indices =
 347         [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
 348         | (_, pkgs) <- pkgss
 349         ]
 350   return $! (mconcat indices)
 351   where
 352     ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb
 353
 354 getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
 355 getLibDir verbosity lbi =
 356   dropWhileEndLE isSpace
 357     `fmap` getDbProgramOutput
 358       verbosity
 359       ghcjsProgram
 360       (withPrograms lbi)
 361       ["--print-libdir"]
 362
 363 getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
 364 getLibDir' verbosity ghcjsProg =
 365   dropWhileEndLE isSpace
 366     `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"]
 367
 368 -- | Return the 'FilePath' to the global GHC package database.
 369 getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
 370 getGlobalPackageDB verbosity ghcProg =
 371   dropWhileEndLE isSpace
 372     `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"]
 373
 374 -- | Return the 'FilePath' to the per-user GHC package database.
 375 getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
 376 getUserPackageDB _verbosity ghcjsProg platform = do
 377   -- It's rather annoying that we have to reconstruct this, because ghc
 378   -- hides this information from us otherwise. But for certain use cases
 379   -- like change monitoring it really can't remain hidden.
 380   appdir <- getAppUserDataDirectory "ghcjs"
 381   return (appdir </> platformAndVersion </> packageConfFileName)
 382   where
 383     platformAndVersion =
 384       Internal.ghcPlatformAndVersionString
 385         platform
 386         ghcjsVersion
 387     packageConfFileName = "package.conf.d"
 388     ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg
 389
 390 checkPackageDbEnvVar :: Verbosity -> IO ()
 391 checkPackageDbEnvVar verbosity =
 392   Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH"
 393
 394 checkPackageDbStack :: Verbosity -> PackageDBStack -> IO ()
 395 checkPackageDbStack _ (GlobalPackageDB : rest)
 396   | GlobalPackageDB `notElem` rest = return ()
 397 checkPackageDbStack verbosity rest
 398   | GlobalPackageDB `notElem` rest =
 399       dieWithException verbosity GlobalPackageDBLimitation
 400 checkPackageDbStack verbosity _ =
 401   dieWithException verbosity GlobalPackageDBSpecifiedFirst
 402
 403 getInstalledPackages'
 404   :: Verbosity
 405   -> [PackageDB]
 406   -> ProgramDb
 407   -> IO [(PackageDB, [InstalledPackageInfo])]
 408 getInstalledPackages' verbosity packagedbs progdb =
 409   sequenceA
 410     [ do
 411       pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
 412       return (packagedb, pkgs)
 413     | packagedb <- packagedbs
 414     ]
 415
 416 -- | Get the packages from specific PackageDBs, not cumulative.
 417 getInstalledPackagesMonitorFiles
 418   :: Verbosity
 419   -> Platform
 420   -> ProgramDb
 421   -> [PackageDB]
 422   -> IO [FilePath]
 423 getInstalledPackagesMonitorFiles verbosity platform progdb =
 424   traverse getPackageDBPath
 425   where
 426     getPackageDBPath :: PackageDB -> IO FilePath
 427     getPackageDBPath GlobalPackageDB =
 428       selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg
 429     getPackageDBPath UserPackageDB =
 430       selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform
 431     getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path
 432
 433     -- GHC has old style file dbs, and new style directory dbs.
 434     -- Note that for dir style dbs, we only need to monitor the cache file, not
 435     -- the whole directory. The ghc program itself only reads the cache file
 436     -- so it's safe to only monitor this one file.
 437     selectMonitorFile path = do
 438       isFileStyle <- doesFileExist path
 439       if isFileStyle
 440         then return path
 441         else return (path </> "package.cache")
 442
 443     ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb
 444
 445 toJSLibName :: String -> String
 446 toJSLibName lib
 447   | takeExtension lib `elem` [".dll", ".dylib", ".so"] =
 448       replaceExtension lib "js_so"
 449   | takeExtension lib == ".a" = replaceExtension lib "js_a"
 450   | otherwise = lib <.> "js_a"
 451
 452 -- -----------------------------------------------------------------------------
 453 -- Building a library
 454
 455 buildLib
 456   :: Verbosity
 457   -> Flag ParStrat
 458   -> PackageDescription
 459   -> LocalBuildInfo
 460   -> Library
 461   -> ComponentLocalBuildInfo
 462   -> IO ()
 463 buildLib = buildOrReplLib Nothing
 464
 465 replLib
 466   :: [String]
 467   -> Verbosity
 468   -> Flag ParStrat
 469   -> PackageDescription
 470   -> LocalBuildInfo
 471   -> Library
 472   -> ComponentLocalBuildInfo
 473   -> IO ()
 474 replLib = buildOrReplLib . Just
 475
 476 buildOrReplLib
 477   :: Maybe [String]
 478   -> Verbosity
 479   -> Flag ParStrat
 480   -> PackageDescription
 481   -> LocalBuildInfo
 482   -> Library
 483   -> ComponentLocalBuildInfo
 484   -> IO ()
 485 buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
 486   let uid = componentUnitId clbi
 487       libTargetDir = componentBuildDir lbi clbi
 488       whenVanillaLib forceVanilla =
 489         when (forceVanilla || withVanillaLib lbi)
 490       whenProfLib = when (withProfLib lbi)
 491       whenSharedLib forceShared =
 492         when (forceShared || withSharedLib lbi)
 493       whenStaticLib forceStatic =
 494         when (forceStatic || withStaticLib lbi)
 495       -- whenGHCiLib = when (withGHCiLib lbi)
 496       forRepl = maybe False (const True) mReplFlags
 497       -- ifReplLib = when forRepl
 498       comp = compiler lbi
 499       implInfo = getImplInfo comp
 500       platform@(Platform _hostArch _hostOS) = hostPlatform lbi
 501       has_code = not (componentIsIndefinite clbi)
 502
 503   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
 504   let runGhcjsProg = runGHC verbosity ghcjsProg comp platform
 505
 506   let libBi = libBuildInfo lib
 507
 508   -- fixme flags shouldn't depend on ghcjs being dynamic or not
 509   let isGhcjsDynamic = isDynamic comp
 510       dynamicTooSupported = supportsDynamicToo comp
 511       doingTH = usesTemplateHaskellOrQQ libBi
 512       forceVanillaLib = doingTH && not isGhcjsDynamic
 513       forceSharedLib = doingTH && isGhcjsDynamic
 514   -- TH always needs default libs, even when building for profiling
 515
 516   -- Determine if program coverage should be enabled and if so, what
 517   -- '-hpcdir' should be.
 518   let isCoverageEnabled = libCoverage lbi
 519       hpcdir way
 520         | forRepl = mempty -- HPC is not supported in ghci
 521         | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
 522         | otherwise = mempty
 523
 524   createDirectoryIfMissingVerbose verbosity True libTargetDir
 525   -- TODO: do we need to put hs-boot files into place for mutually recursive
 526   -- modules?
 527   let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi)
 528       jsSrcs = jsSources libBi
 529       cObjs = map (`replaceExtension` objExtension) cLikeFiles
 530       baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
 531       linkJsLibOpts =
 532         mempty
 533           { ghcOptExtra =
 534               [ "-link-js-lib"
 535               , getHSLibraryName uid
 536               , "-js-lib-outputdir"
 537               , libTargetDir
 538               ]
 539                 ++ jsSrcs
 540           }
 541       vanillaOptsNoJsLib =
 542         baseOpts
 543           `mappend` mempty
 544             { ghcOptMode = toFlag GhcModeMake
 545             , ghcOptNumJobs = numJobs
 546             , ghcOptInputModules = toNubListR $ allLibModules lib clbi
 547             , ghcOptHPCDir = hpcdir Hpc.Vanilla
 548             }
 549       vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts
 550
 551       profOpts =
 552         adjustExts "p_hi" "p_o" vanillaOpts
 553           `mappend` mempty
 554             { ghcOptProfilingMode = toFlag True
 555             , ghcOptProfilingAuto =
 556                 Internal.profDetailLevelFlag
 557                   True
 558                   (withProfLibDetail lbi)
 559             , --  ghcOptHiSuffix      = toFlag "p_hi",
 560               --  ghcOptObjSuffix     = toFlag "p_o",
 561               ghcOptExtra = hcProfOptions GHC libBi
 562             , ghcOptHPCDir = hpcdir Hpc.Prof
 563             }
 564
 565       sharedOpts =
 566         adjustExts "dyn_hi" "dyn_o" vanillaOpts
 567           `mappend` mempty
 568             { ghcOptDynLinkMode = toFlag GhcDynamicOnly
 569             , ghcOptFPic = toFlag True
 570             , --  ghcOptHiSuffix    = toFlag "dyn_hi",
 571               --  ghcOptObjSuffix   = toFlag "dyn_o",
 572               ghcOptExtra = hcSharedOptions GHC libBi
 573             , ghcOptHPCDir = hpcdir Hpc.Dyn
 574             }
 575
 576       vanillaSharedOpts =
 577         vanillaOpts
 578           `mappend` mempty
 579             { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
 580             , ghcOptDynHiSuffix = toFlag "js_dyn_hi"
 581             , ghcOptDynObjSuffix = toFlag "js_dyn_o"
 582             , ghcOptHPCDir = hpcdir Hpc.Dyn
 583             }
 584
 585   unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $
 586     do
 587       let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)
 588           shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts)
 589           useDynToo =
 590             dynamicTooSupported
 591               && (forceVanillaLib || withVanillaLib lbi)
 592               && (forceSharedLib || withSharedLib lbi)
 593               && null (hcSharedOptions GHC libBi)
 594       if not has_code
 595         then vanilla
 596         else
 597           if useDynToo
 598             then do
 599               runGhcjsProg vanillaSharedOpts
 600               case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
 601                 (Flag dynDir, Flag vanillaDir) ->
 602                   -- When the vanilla and shared library builds are done
 603                   -- in one pass, only one set of HPC module interfaces
 604                   -- are generated. This set should suffice for both
 605                   -- static and dynamically linked executables. We copy
 606                   -- the modules interfaces so they are available under
 607                   -- both ways.
 608                   copyDirectoryRecursive verbosity dynDir vanillaDir
 609                 _ -> return ()
 610             else
 611               if isGhcjsDynamic
 612                 then do shared; vanilla
 613                 else do vanilla; shared
 614       whenProfLib (runGhcjsProg profOpts)
 615
 616   -- Build any C++ sources separately.
 617   {-
 618     unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do
 619       info verbosity "Building C++ Sources..."
 620       sequence_
 621         [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo
 622                                   lbi libBi clbi libTargetDir filename
 623                  vanillaCxxOpts = if isGhcjsDynamic
 624                                   then baseCxxOpts { ghcOptFPic = toFlag True }
 625                                   else baseCxxOpts
 626                  profCxxOpts    = vanillaCxxOpts `mappend` mempty {
 627                                     ghcOptProfilingMode = toFlag True,
 628                                     ghcOptObjSuffix     = toFlag "p_o"
 629                                   }
 630                  sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {
 631                                    ghcOptFPic        = toFlag True,
 632                                    ghcOptDynLinkMode = toFlag GhcDynamicOnly,
 633                                    ghcOptObjSuffix   = toFlag "dyn_o"
 634                                  }
 635                  odir           = fromFlag (ghcOptObjDir vanillaCxxOpts)
 636              createDirectoryIfMissingVerbose verbosity True odir
 637              let runGhcProgIfNeeded cxxOpts = do
 638                    needsRecomp <- checkNeedsRecompilation filename cxxOpts
 639                    when needsRecomp $ runGhcjsProg cxxOpts
 640              runGhcProgIfNeeded vanillaCxxOpts
 641              unless forRepl $
 642                whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)
 643              unless forRepl $ whenProfLib   (runGhcProgIfNeeded   profCxxOpts)
 644         | filename <- cxxSources libBi]
 645
 646     ifReplLib $ do
 647       when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"
 648       ifReplLib (runGhcjsProg replOpts)
 649   -}
 650   -- build any C sources
 651   -- TODO: Add support for S and CMM files.
 652   {-
 653     unless (not has_code || null (cSources libBi) || not nativeToo) $ do
 654       info verbosity "Building C Sources..."
 655       sequence_
 656         [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo
 657                                  lbi libBi clbi libTargetDir filename
 658                  vanillaCcOpts = if isGhcjsDynamic
 659                                  -- Dynamic GHC requires C sources to be built
 660                                  -- with -fPIC for REPL to work. See #2207.
 661                                  then baseCcOpts { ghcOptFPic = toFlag True }
 662                                  else baseCcOpts
 663                  profCcOpts    = vanillaCcOpts `mappend` mempty {
 664                                    ghcOptProfilingMode = toFlag True,
 665                                    ghcOptObjSuffix     = toFlag "p_o"
 666                                  }
 667                  sharedCcOpts  = vanillaCcOpts `mappend` mempty {
 668                                    ghcOptFPic        = toFlag True,
 669                                    ghcOptDynLinkMode = toFlag GhcDynamicOnly,
 670                                    ghcOptObjSuffix   = toFlag "dyn_o"
 671                                  }
 672                  odir          = fromFlag (ghcOptObjDir vanillaCcOpts)
 673              createDirectoryIfMissingVerbose verbosity True odir
 674              let runGhcProgIfNeeded ccOpts = do
 675                    needsRecomp <- checkNeedsRecompilation filename ccOpts
 676                    when needsRecomp $ runGhcjsProg ccOpts
 677              runGhcProgIfNeeded vanillaCcOpts
 678              unless forRepl $
 679                whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
 680              unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
 681         | filename <- cSources libBi]
 682   -}
 683   -- TODO: problem here is we need the .c files built first, so we can load them
 684   -- with ghci, but .c files can depend on .h files generated by ghc by ffi
 685   -- exports.
 686
 687   -- link:
 688
 689   when has_code . when False {- fixme nativeToo -} . unless forRepl $ do
 690     info verbosity "Linking..."
 691     let cSharedObjs =
 692           map
 693             (`replaceExtension` ("dyn_" ++ objExtension))
 694             (cSources libBi ++ cxxSources libBi)
 695         compiler_id = compilerId (compiler lbi)
 696         sharedLibFilePath = libTargetDir </> mkSharedLibName (hostPlatform lbi) compiler_id uid
 697         staticLibFilePath = libTargetDir </> mkStaticLibName (hostPlatform lbi) compiler_id uid
 698
 699     let stubObjs = []
 700         stubSharedObjs = []
 701
 702     {-
 703         stubObjs <- catMaybes <$> sequenceA
 704           [ findFileWithExtension [objExtension] [libTargetDir]
 705               (ModuleName.toFilePath x ++"_stub")
 706           | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
 707           , x <- allLibModules lib clbi ]
 708         stubProfObjs <- catMaybes <$> sequenceA
 709           [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
 710               (ModuleName.toFilePath x ++"_stub")
 711           | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
 712           , x <- allLibModules lib clbi ]
 713         stubSharedObjs <- catMaybes <$> sequenceA
 714           [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
 715               (ModuleName.toFilePath x ++"_stub")
 716           | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
 717           , x <- allLibModules lib clbi ]
 718     -}
 719     hObjs <-
 720       Internal.getHaskellObjects
 721         implInfo
 722         lib
 723         lbi
 724         clbi
 725         libTargetDir
 726         objExtension
 727         True
 728     hSharedObjs <-
 729       if withSharedLib lbi
 730         then
 731           Internal.getHaskellObjects
 732             implInfo
 733             lib
 734             lbi
 735             clbi
 736             libTargetDir
 737             ("dyn_" ++ objExtension)
 738             False
 739         else return []
 740
 741     unless (null hObjs && null cObjs && null stubObjs) $ do
 742       rpaths <- getRPaths lbi clbi
 743
 744       let staticObjectFiles =
 745             hObjs
 746               ++ map (libTargetDir </>) cObjs
 747               ++ stubObjs
 748           dynamicObjectFiles =
 749             hSharedObjs
 750               ++ map (libTargetDir </>) cSharedObjs
 751               ++ stubSharedObjs
 752           -- After the relocation lib is created we invoke ghc -shared
 753           -- with the dependencies spelled out as -package arguments
 754           -- and ghc invokes the linker with the proper library paths
 755           ghcSharedLinkArgs =
 756             mempty
 757               { ghcOptShared = toFlag True
 758               , ghcOptDynLinkMode = toFlag GhcDynamicOnly
 759               , ghcOptInputFiles = toNubListR dynamicObjectFiles
 760               , ghcOptOutputFile = toFlag sharedLibFilePath
 761               , ghcOptExtra = hcSharedOptions GHC libBi
 762               , -- For dynamic libs, Mac OS/X needs to know the install location
 763                 -- at build time. This only applies to GHC < 7.8 - see the
 764                 -- discussion in #1660.
 765                 {-
 766                     ghcOptDylibName          = if hostOS == OSX
 767                                                   && ghcVersion < mkVersion [7,8]
 768                                                 then toFlag sharedLibInstallPath
 769                                                 else mempty, -}
 770                 ghcOptHideAllPackages = toFlag True
 771               , ghcOptNoAutoLinkPackages = toFlag True
 772               , ghcOptPackageDBs = withPackageDB lbi
 773               , ghcOptThisUnitId = case clbi of
 774                   LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
 775                     toFlag pk
 776                   _ -> mempty
 777               , ghcOptThisComponentId = case clbi of
 778                   LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
 779                     if null insts
 780                       then mempty
 781                       else toFlag (componentComponentId clbi)
 782                   _ -> mempty
 783               , ghcOptInstantiatedWith = case clbi of
 784                   LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
 785                     insts
 786                   _ -> []
 787               , ghcOptPackages =
 788                   toNubListR $
 789                     Internal.mkGhcOptPackages mempty clbi
 790               , ghcOptLinkLibs = extraLibs libBi
 791               , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
 792               , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
 793               , ghcOptLinkFrameworkDirs =
 794                   toNubListR $ PD.extraFrameworkDirs libBi
 795               , ghcOptRPaths = rpaths
 796               }
 797           ghcStaticLinkArgs =
 798             mempty
 799               { ghcOptStaticLib = toFlag True
 800               , ghcOptInputFiles = toNubListR staticObjectFiles
 801               , ghcOptOutputFile = toFlag staticLibFilePath
 802               , ghcOptExtra = hcStaticOptions GHC libBi
 803               , ghcOptHideAllPackages = toFlag True
 804               , ghcOptNoAutoLinkPackages = toFlag True
 805               , ghcOptPackageDBs = withPackageDB lbi
 806               , ghcOptThisUnitId = case clbi of
 807                   LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
 808                     toFlag pk
 809                   _ -> mempty
 810               , ghcOptThisComponentId = case clbi of
 811                   LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
 812                     if null insts
 813                       then mempty
 814                       else toFlag (componentComponentId clbi)
 815                   _ -> mempty
 816               , ghcOptInstantiatedWith = case clbi of
 817                   LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
 818                     insts
 819                   _ -> []
 820               , ghcOptPackages =
 821                   toNubListR $
 822                     Internal.mkGhcOptPackages mempty clbi
 823               , ghcOptLinkLibs = extraLibs libBi
 824               , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
 825               }
 826
 827       info verbosity (show (ghcOptPackages ghcSharedLinkArgs))
 828       {-
 829             whenVanillaLib False $ do
 830               Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
 831               whenGHCiLib $ do
 832                 (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
 833                 Ld.combineObjectFiles verbosity lbi ldProg
 834                   ghciLibFilePath staticObjectFiles
 835                   -}
 836       {-
 837             whenProfLib $ do
 838               Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
 839               whenGHCiLib $ do
 840                 (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
 841                 Ld.combineObjectFiles verbosity lbi ldProg
 842                   ghciProfLibFilePath profObjectFiles
 843       -}
 844       whenSharedLib False $
 845         runGhcjsProg ghcSharedLinkArgs
 846
 847       whenStaticLib False $
 848         runGhcjsProg ghcStaticLinkArgs
 849
 850 -- | Start a REPL without loading any source files.
 851 startInterpreter
 852   :: Verbosity
 853   -> ProgramDb
 854   -> Compiler
 855   -> Platform
 856   -> PackageDBStack
 857   -> IO ()
 858 startInterpreter verbosity progdb comp platform packageDBs = do
 859   let replOpts =
 860         mempty
 861           { ghcOptMode = toFlag GhcModeInteractive
 862           , ghcOptPackageDBs = packageDBs
 863           }
 864   checkPackageDbStack verbosity packageDBs
 865   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb
 866   runGHC verbosity ghcjsProg comp platform replOpts
 867
 868 -- -----------------------------------------------------------------------------
 869 -- Building an executable or foreign library
 870
 871 -- | Build a foreign library
 872 buildFLib
 873   :: Verbosity
 874   -> Flag ParStrat
 875   -> PackageDescription
 876   -> LocalBuildInfo
 877   -> ForeignLib
 878   -> ComponentLocalBuildInfo
 879   -> IO ()
 880 buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib
 881
 882 replFLib
 883   :: [String]
 884   -> Verbosity
 885   -> Flag ParStrat
 886   -> PackageDescription
 887   -> LocalBuildInfo
 888   -> ForeignLib
 889   -> ComponentLocalBuildInfo
 890   -> IO ()
 891 replFLib replFlags v njobs pkg lbi =
 892   gbuild v njobs pkg lbi . GReplFLib replFlags
 893
 894 -- | Build an executable with GHC.
 895 buildExe
 896   :: Verbosity
 897   -> Flag ParStrat
 898   -> PackageDescription
 899   -> LocalBuildInfo
 900   -> Executable
 901   -> ComponentLocalBuildInfo
 902   -> IO ()
 903 buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe
 904
 905 replExe
 906   :: [String]
 907   -> Verbosity
 908   -> Flag ParStrat
 909   -> PackageDescription
 910   -> LocalBuildInfo
 911   -> Executable
 912   -> ComponentLocalBuildInfo
 913   -> IO ()
 914 replExe replFlags v njobs pkg lbi =
 915   gbuild v njobs pkg lbi . GReplExe replFlags
 916
 917 -- | Building an executable, starting the REPL, and building foreign
 918 -- libraries are all very similar and implemented in 'gbuild'. The
 919 -- 'GBuildMode' distinguishes between the various kinds of operation.
 920 data GBuildMode
 921   = GBuildExe Executable
 922   | GReplExe [String] Executable
 923   | GBuildFLib ForeignLib
 924   | GReplFLib [String] ForeignLib
 925
 926 gbuildInfo :: GBuildMode -> BuildInfo
 927 gbuildInfo (GBuildExe exe) = buildInfo exe
 928 gbuildInfo (GReplExe _ exe) = buildInfo exe
 929 gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib
 930 gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib
 931
 932 gbuildName :: GBuildMode -> String
 933 gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe
 934 gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe
 935 gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib
 936 gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib
 937
 938 gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String
 939 gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe
 940 gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe
 941 gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib
 942 gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib
 943
 944 exeTargetName :: Platform -> Executable -> String
 945 exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform
 946
 947 -- | Target name for a foreign library (the actual file name)
 948 --
 949 -- We do not use mkLibName and co here because the naming for foreign libraries
 950 -- is slightly different (we don't use "_p" or compiler version suffices, and we
 951 -- don't want the "lib" prefix on Windows).
 952 --
 953 -- TODO: We do use `dllExtension` and co here, but really that's wrong: they
 954 -- use the OS used to build cabal to determine which extension to use, rather
 955 -- than the target OS (but this is wrong elsewhere in Cabal as well).
 956 flibTargetName :: LocalBuildInfo -> ForeignLib -> String
 957 flibTargetName lbi flib =
 958   case (os, foreignLibType flib) of
 959     (Windows, ForeignLibNativeShared) -> nm <.> "dll"
 960     (Windows, ForeignLibNativeStatic) -> nm <.> "lib"
 961     (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt
 962     (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi)
 963     (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)
 964     (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"
 965   where
 966     nm :: String
 967     nm = unUnqualComponentName $ foreignLibName flib
 968
 969     os :: OS
 970     os =
 971       let (Platform _ os') = hostPlatform lbi
 972        in os'
 973
 974     -- If a foreign lib foo has lib-version-info 5:1:2 or
 975     -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1
 976     -- Libtool's version-info data is translated into library versions in a
 977     -- nontrivial way: so refer to libtool documentation.
 978     versionedExt :: String
 979     versionedExt =
 980       let nums = foreignLibVersion flib os
 981        in foldl (<.>) "so" (map show nums)
 982
 983 -- | Name for the library when building.
 984 --
 985 -- If the `lib-version-info` field or the `lib-version-linux` field of
 986 -- a foreign library target is set, we need to incorporate that
 987 -- version into the SONAME field.
 988 --
 989 -- If a foreign library foo has lib-version-info 5:1:2, it should be
 990 -- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.
 991 -- However, GHC does not allow overriding soname by setting linker
 992 -- options, as it sets a soname of its own (namely the output
 993 -- filename), after the user-supplied linker options.  Hence, we have
 994 -- to compile the library with the soname as its filename.  We rename
 995 -- the compiled binary afterwards.
 996 --
 997 -- This method allows to adjust the name of the library at build time
 998 -- such that the correct soname can be set.
 999 flibBuildName :: LocalBuildInfo -> ForeignLib -> String
1000 flibBuildName lbi flib
1001   -- On linux, if a foreign-library has version data, the first digit is used
1002   -- to produce the SONAME.
1003   | (os, foreignLibType flib)
1004       == (Linux, ForeignLibNativeShared) =
1005       let nums = foreignLibVersion flib os
1006        in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))
1007   | otherwise = flibTargetName lbi flib
1008   where
1009     os :: OS
1010     os =
1011       let (Platform _ os') = hostPlatform lbi
1012        in os'
1013
1014     nm :: String
1015     nm = unUnqualComponentName $ foreignLibName flib
1016
1017 gbuildIsRepl :: GBuildMode -> Bool
1018 gbuildIsRepl (GBuildExe _) = False
1019 gbuildIsRepl (GReplExe _ _) = True
1020 gbuildIsRepl (GBuildFLib _) = False
1021 gbuildIsRepl (GReplFLib _ _) = True
1022
1023 gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool
1024 gbuildNeedDynamic lbi bm =
1025   case bm of
1026     GBuildExe _ -> withDynExe lbi
1027     GReplExe _ _ -> withDynExe lbi
1028     GBuildFLib flib -> withDynFLib flib
1029     GReplFLib _ flib -> withDynFLib flib
1030   where
1031     withDynFLib flib =
1032       case foreignLibType flib of
1033         ForeignLibNativeShared ->
1034           ForeignLibStandalone `notElem` foreignLibOptions flib
1035         ForeignLibNativeStatic ->
1036           False
1037         ForeignLibTypeUnknown ->
1038           cabalBug "unknown foreign lib type"
1039
1040 gbuildModDefFiles :: GBuildMode -> [FilePath]
1041 gbuildModDefFiles (GBuildExe _) = []
1042 gbuildModDefFiles (GReplExe _ _) = []
1043 gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib
1044 gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib
1045
1046 -- | "Main" module name when overridden by @ghc-options: -main-is ...@
1047 -- or 'Nothing' if no @-main-is@ flag could be found.
1048 --
1049 -- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.
1050 exeMainModuleName :: Executable -> Maybe ModuleName
1051 exeMainModuleName Executable{buildInfo = bnfo} =
1052   -- GHC honors the last occurrence of a module name updated via -main-is
1053   --
1054   -- Moreover, -main-is when parsed left-to-right can update either
1055   -- the "Main" module name, or the "main" function name, or both,
1056   -- see also 'decodeMainIsArg'.
1057   msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts
1058   where
1059     ghcopts = hcOptions GHC bnfo
1060
1061     findIsMainArgs [] = []
1062     findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest
1063     findIsMainArgs (_ : rest) = findIsMainArgs rest
1064
1065 -- | Decode argument to '-main-is'
1066 --
1067 -- Returns 'Nothing' if argument set only the function name.
1068 --
1069 -- This code has been stolen/refactored from GHC's DynFlags.setMainIs
1070 -- function. The logic here is deliberately imperfect as it is
1071 -- intended to be bug-compatible with GHC's parser. See discussion in
1072 -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
1073 decodeMainIsArg :: String -> Maybe ModuleName
1074 decodeMainIsArg arg
1075   | headOf main_fn isLower =
1076       -- The arg looked like "Foo.Bar.baz"
1077       Just (ModuleName.fromString main_mod)
1078   | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
1079     =
1080       Just (ModuleName.fromString arg)
1081   | otherwise -- The arg looked like "baz"
1082     =
1083       Nothing
1084   where
1085     headOf :: String -> (Char -> Bool) -> Bool
1086     headOf str pred' = any pred' (safeHead str)
1087
1088     (main_mod, main_fn) = splitLongestPrefix arg (== '.')
1089
1090     splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
1091     splitLongestPrefix str pred'
1092       | null r_pre = (str, [])
1093       | otherwise = (reverse (safeTail r_pre), reverse r_suf)
1094       where
1095         -- 'safeTail' drops the char satisfying 'pred'
1096         (r_suf, r_pre) = break pred' (reverse str)
1097
1098 -- | A collection of:
1099 --    * C input files
1100 --    * C++ input files
1101 --    * GHC input files
1102 --    * GHC input modules
1103 --
1104 -- Used to correctly build and link sources.
1105 data BuildSources = BuildSources
1106   { cSourcesFiles :: [FilePath]
1107   , cxxSourceFiles :: [FilePath]
1108   , inputSourceFiles :: [FilePath]
1109   , inputSourceModules :: [ModuleName]
1110   }
1111
1112 -- | Locate and return the 'BuildSources' required to build and link.
1113 gbuildSources
1114   :: Verbosity
1115   -> PackageId
1116   -> CabalSpecVersion
1117   -> FilePath
1118   -> GBuildMode
1119   -> IO BuildSources
1120 gbuildSources verbosity pkgId specVer tmpDir bm =
1121   case bm of
1122     GBuildExe exe -> exeSources exe
1123     GReplExe _ exe -> exeSources exe
1124     GBuildFLib flib -> return $ flibSources flib
1125     GReplFLib _ flib -> return $ flibSources flib
1126   where
1127     exeSources :: Executable -> IO BuildSources
1128     exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do
1129       main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath
1130       let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe
1131           otherModNames = exeModules exe
1132
1133       -- Scripts have fakePackageId and are always Haskell but can have any extension.
1134       if isHaskell main || pkgId == fakePackageId
1135         then
1136           if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames)
1137             then do
1138               -- The cabal manual clearly states that `other-modules` is
1139               -- intended for non-main modules.  However, there's at least one
1140               -- important package on Hackage (happy-1.19.5) which
1141               -- violates this. We workaround this here so that we don't
1142               -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which
1143               -- would result in GHC complaining about duplicate Main
1144               -- modules.
1145               --
1146               -- Finally, we only enable this workaround for
1147               -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
1148               -- have no excuse anymore to keep doing it wrong... ;-)
1149               warn verbosity $
1150                 "Enabling workaround for Main module '"
1151                   ++ prettyShow mainModName
1152                   ++ "' listed in 'other-modules' illegally!"
1153
1154               return
1155                 BuildSources
1156                   { cSourcesFiles = cSources bnfo
1157                   , cxxSourceFiles = cxxSources bnfo
1158                   , inputSourceFiles = [main]
1159                   , inputSourceModules = filter (/= mainModName) $ exeModules exe
1160                   }
1161             else
1162               return
1163                 BuildSources
1164                   { cSourcesFiles = cSources bnfo
1165                   , cxxSourceFiles = cxxSources bnfo
1166                   , inputSourceFiles = [main]
1167                   , inputSourceModules = exeModules exe
1168                   }
1169         else
1170           let (csf, cxxsf)
1171                 | isCxx main = (cSources bnfo, main : cxxSources bnfo)
1172                 -- if main is not a Haskell source
1173                 -- and main is not a C++ source
1174                 -- then we assume that it is a C source
1175                 | otherwise = (main : cSources bnfo, cxxSources bnfo)
1176            in return
1177                 BuildSources
1178                   { cSourcesFiles = csf
1179                   , cxxSourceFiles = cxxsf
1180                   , inputSourceFiles = []
1181                   , inputSourceModules = exeModules exe
1182                   }
1183
1184     flibSources :: ForeignLib -> BuildSources
1185     flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =
1186       BuildSources
1187         { cSourcesFiles = cSources bnfo
1188         , cxxSourceFiles = cxxSources bnfo
1189         , inputSourceFiles = []
1190         , inputSourceModules = foreignLibModules flib
1191         }
1192
1193     isCxx :: FilePath -> Bool
1194     isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"]
1195
1196 -- | FilePath has a Haskell extension: .hs or .lhs
1197 isHaskell :: FilePath -> Bool
1198 isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]
1199
1200 -- | Generic build function. See comment for 'GBuildMode'.
1201 gbuild
1202   :: Verbosity
1203   -> Flag ParStrat
1204   -> PackageDescription
1205   -> LocalBuildInfo
1206   -> GBuildMode
1207   -> ComponentLocalBuildInfo
1208   -> IO ()
1209 gbuild verbosity numJobs pkg_descr lbi bm clbi = do
1210   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
1211   let replFlags = case bm of
1212         GReplExe flags _ -> flags
1213         GReplFLib flags _ -> flags
1214         GBuildExe{} -> mempty
1215         GBuildFLib{} -> mempty
1216       comp = compiler lbi
1217       platform = hostPlatform lbi
1218       runGhcProg = runGHC verbosity ghcjsProg comp platform
1219
1220   let (bnfo, threaded) = case bm of
1221         GBuildFLib _ -> popThreadedFlag (gbuildInfo bm)
1222         _ -> (gbuildInfo bm, False)
1223
1224   -- the name that GHC really uses (e.g., with .exe on Windows for executables)
1225   let targetName = gbuildTargetName lbi bm
1226   let targetDir = buildDir lbi </> (gbuildName bm)
1227   let tmpDir = targetDir </> (gbuildName bm ++ "-tmp")
1228   createDirectoryIfMissingVerbose verbosity True targetDir
1229   createDirectoryIfMissingVerbose verbosity True tmpDir
1230
1231   -- TODO: do we need to put hs-boot files into place for mutually recursive
1232   -- modules?  FIX: what about exeName.hi-boot?
1233
1234   -- Determine if program coverage should be enabled and if so, what
1235   -- '-hpcdir' should be.
1236   let isCoverageEnabled = exeCoverage lbi
1237       hpcdir way
1238         | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
1239         | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
1240         | otherwise = mempty
1241
1242   rpaths <- getRPaths lbi clbi
1243   buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm
1244
1245   let cSrcs = cSourcesFiles buildSources
1246       cxxSrcs = cxxSourceFiles buildSources
1247       inputFiles = inputSourceFiles buildSources
1248       inputModules = inputSourceModules buildSources
1249       isGhcDynamic = isDynamic comp
1250       dynamicTooSupported = supportsDynamicToo comp
1251       cObjs = map (`replaceExtension` objExtension) cSrcs
1252       cxxObjs = map (`replaceExtension` objExtension) cxxSrcs
1253       needDynamic = gbuildNeedDynamic lbi bm
1254       needProfiling = withProfExe lbi
1255
1256       -- build executables
1257       buildRunner = case clbi of
1258         LibComponentLocalBuildInfo{} -> False
1259         FLibComponentLocalBuildInfo{} -> False
1260         ExeComponentLocalBuildInfo{} -> True
1261         TestComponentLocalBuildInfo{} -> True
1262         BenchComponentLocalBuildInfo{} -> True
1263       baseOpts =
1264         (componentGhcOptions verbosity lbi bnfo clbi tmpDir)
1265           `mappend` mempty
1266             { ghcOptMode = toFlag GhcModeMake
1267             , ghcOptInputFiles =
1268                 toNubListR $
1269                   if package pkg_descr == fakePackageId
1270                     then filter isHaskell inputFiles
1271                     else inputFiles
1272             , ghcOptInputScripts =
1273                 toNubListR $
1274                   if package pkg_descr == fakePackageId
1275                     then filter (not . isHaskell) inputFiles
1276                     else []
1277             , ghcOptInputModules = toNubListR inputModules
1278             , -- for all executable components (exe/test/bench),
1279               -- GHCJS must be passed the "-build-runner" option
1280               ghcOptExtra =
1281                 if buildRunner
1282                   then ["-build-runner"]
1283                   else mempty
1284             }
1285       staticOpts =
1286         baseOpts
1287           `mappend` mempty
1288             { ghcOptDynLinkMode = toFlag GhcStaticOnly
1289             , ghcOptHPCDir = hpcdir Hpc.Vanilla
1290             }
1291       profOpts =
1292         baseOpts
1293           `mappend` mempty
1294             { ghcOptProfilingMode = toFlag True
1295             , ghcOptProfilingAuto =
1296                 Internal.profDetailLevelFlag
1297                   False
1298                   (withProfExeDetail lbi)
1299             , ghcOptHiSuffix = toFlag "p_hi"
1300             , ghcOptObjSuffix = toFlag "p_o"
1301             , ghcOptExtra = hcProfOptions GHC bnfo
1302             , ghcOptHPCDir = hpcdir Hpc.Prof
1303             }
1304       dynOpts =
1305         baseOpts
1306           `mappend` mempty
1307             { ghcOptDynLinkMode = toFlag GhcDynamicOnly
1308             , -- TODO: Does it hurt to set -fPIC for executables?
1309               ghcOptFPic = toFlag True
1310             , ghcOptHiSuffix = toFlag "dyn_hi"
1311             , ghcOptObjSuffix = toFlag "dyn_o"
1312             , ghcOptExtra = hcSharedOptions GHC bnfo
1313             , ghcOptHPCDir = hpcdir Hpc.Dyn
1314             }
1315       dynTooOpts =
1316         staticOpts
1317           `mappend` mempty
1318             { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
1319             , ghcOptDynHiSuffix = toFlag "dyn_hi"
1320             , ghcOptDynObjSuffix = toFlag "dyn_o"
1321             , ghcOptHPCDir = hpcdir Hpc.Dyn
1322             }
1323       linkerOpts =
1324         mempty
1325           { ghcOptLinkOptions = PD.ldOptions bnfo
1326           , ghcOptLinkLibs = extraLibs bnfo
1327           , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo
1328           , ghcOptLinkFrameworks =
1329               toNubListR $
1330                 PD.frameworks bnfo
1331           , ghcOptLinkFrameworkDirs =
1332               toNubListR $
1333                 PD.extraFrameworkDirs bnfo
1334           , ghcOptInputFiles =
1335               toNubListR
1336                 [tmpDir </> x | x <- cObjs ++ cxxObjs]
1337           }
1338       dynLinkerOpts =
1339         mempty
1340           { ghcOptRPaths = rpaths
1341           }
1342       replOpts =
1343         baseOpts
1344           { ghcOptExtra =
1345               Internal.filterGhciFlags
1346                 (ghcOptExtra baseOpts)
1347                 <> replFlags
1348           }
1349           -- For a normal compile we do separate invocations of ghc for
1350           -- compiling as for linking. But for repl we have to do just
1351           -- the one invocation, so that one has to include all the
1352           -- linker stuff too, like -l flags and any .o files from C
1353           -- files etc.
1354           `mappend` linkerOpts
1355           `mappend` mempty
1356             { ghcOptMode = toFlag GhcModeInteractive
1357             , ghcOptOptimisation = toFlag GhcNoOptimisation
1358             }
1359       commonOpts
1360         | needProfiling = profOpts
1361         | needDynamic = dynOpts
1362         | otherwise = staticOpts
1363       compileOpts
1364         | useDynToo = dynTooOpts
1365         | otherwise = commonOpts
1366       withStaticExe = not needProfiling && not needDynamic
1367
1368       -- For building exe's that use TH with -prof or -dynamic we actually have
1369       -- to build twice, once without -prof/-dynamic and then again with
1370       -- -prof/-dynamic. This is because the code that TH needs to run at
1371       -- compile time needs to be the vanilla ABI so it can be loaded up and run
1372       -- by the compiler.
1373       -- With dynamic-by-default GHC the TH object files loaded at compile-time
1374       -- need to be .dyn_o instead of .o.
1375       doingTH = usesTemplateHaskellOrQQ bnfo
1376       -- Should we use -dynamic-too instead of compiling twice?
1377       useDynToo =
1378         dynamicTooSupported
1379           && isGhcDynamic
1380           && doingTH
1381           && withStaticExe
1382           && null (hcSharedOptions GHC bnfo)
1383       compileTHOpts
1384         | isGhcDynamic = dynOpts
1385         | otherwise = staticOpts
1386       compileForTH
1387         | gbuildIsRepl bm = False
1388         | useDynToo = False
1389         | isGhcDynamic = doingTH && (needProfiling || withStaticExe)
1390         | otherwise = doingTH && (needProfiling || needDynamic)
1391
1392   -- Build static/dynamic object files for TH, if needed.
1393   when compileForTH $
1394     runGhcProg
1395       compileTHOpts
1396         { ghcOptNoLink = toFlag True
1397         , ghcOptNumJobs = numJobs
1398         }
1399
1400   -- Do not try to build anything if there are no input files.
1401   -- This can happen if the cabal file ends up with only cSrcs
1402   -- but no Haskell modules.
1403   unless
1404     ( (null inputFiles && null inputModules)
1405         || gbuildIsRepl bm
1406     )
1407     $ runGhcProg
1408       compileOpts
1409         { ghcOptNoLink = toFlag True
1410         , ghcOptNumJobs = numJobs
1411         }
1412
1413   -- build any C++ sources
1414   unless (null cxxSrcs) $ do
1415     info verbosity "Building C++ Sources..."
1416     sequence_
1417       [ do
1418         let baseCxxOpts =
1419               Internal.componentCxxGhcOptions
1420                 verbosity
1421                 lbi
1422                 bnfo
1423                 clbi
1424                 tmpDir
1425                 filename
1426             vanillaCxxOpts =
1427               if isGhcDynamic
1428                 then -- Dynamic GHC requires C++ sources to be built
1429                 -- with -fPIC for REPL to work. See #2207.
1430                   baseCxxOpts{ghcOptFPic = toFlag True}
1431                 else baseCxxOpts
1432             profCxxOpts =
1433               vanillaCxxOpts
1434                 `mappend` mempty
1435                   { ghcOptProfilingMode = toFlag True
1436                   }
1437             sharedCxxOpts =
1438               vanillaCxxOpts
1439                 `mappend` mempty
1440                   { ghcOptFPic = toFlag True
1441                   , ghcOptDynLinkMode = toFlag GhcDynamicOnly
1442                   }
1443             opts
1444               | needProfiling = profCxxOpts
1445               | needDynamic = sharedCxxOpts
1446               | otherwise = vanillaCxxOpts
1447             -- TODO: Placing all Haskell, C, & C++ objects in a single directory
1448             --       Has the potential for file collisions. In general we would
1449             --       consider this a user error. However, we should strive to
1450             --       add a warning if this occurs.
1451             odir = fromFlag (ghcOptObjDir opts)
1452         createDirectoryIfMissingVerbose verbosity True odir
1453         needsRecomp <- checkNeedsRecompilation filename opts
1454         when needsRecomp $
1455           runGhcProg opts
1456       | filename <- cxxSrcs
1457       ]
1458
1459   -- build any C sources
1460   unless (null cSrcs) $ do
1461     info verbosity "Building C Sources..."
1462     sequence_
1463       [ do
1464         let baseCcOpts =
1465               Internal.componentCcGhcOptions
1466                 verbosity
1467                 lbi
1468                 bnfo
1469                 clbi
1470                 tmpDir
1471                 filename
1472             vanillaCcOpts =
1473               if isGhcDynamic
1474                 then -- Dynamic GHC requires C sources to be built
1475                 -- with -fPIC for REPL to work. See #2207.
1476                   baseCcOpts{ghcOptFPic = toFlag True}
1477                 else baseCcOpts
1478             profCcOpts =
1479               vanillaCcOpts
1480                 `mappend` mempty
1481                   { ghcOptProfilingMode = toFlag True
1482                   }
1483             sharedCcOpts =
1484               vanillaCcOpts
1485                 `mappend` mempty
1486                   { ghcOptFPic = toFlag True
1487                   , ghcOptDynLinkMode = toFlag GhcDynamicOnly
1488                   }
1489             opts
1490               | needProfiling = profCcOpts
1491               | needDynamic = sharedCcOpts
1492               | otherwise = vanillaCcOpts
1493             odir = fromFlag (ghcOptObjDir opts)
1494         createDirectoryIfMissingVerbose verbosity True odir
1495         needsRecomp <- checkNeedsRecompilation filename opts
1496         when needsRecomp $
1497           runGhcProg opts
1498       | filename <- cSrcs
1499       ]
1500
1501   -- TODO: problem here is we need the .c files built first, so we can load them
1502   -- with ghci, but .c files can depend on .h files generated by ghc by ffi
1503   -- exports.
1504   case bm of
1505     GReplExe _ _ -> runGhcProg replOpts
1506     GReplFLib _ _ -> runGhcProg replOpts
1507     GBuildExe _ -> do
1508       let linkOpts =
1509             commonOpts
1510               `mappend` linkerOpts
1511               `mappend` mempty
1512                 { ghcOptLinkNoHsMain = toFlag (null inputFiles)
1513                 }
1514               `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)
1515
1516       info verbosity "Linking..."
1517       -- Work around old GHCs not relinking in this
1518       -- situation, see #3294
1519       let target = targetDir </> targetName
1520       when (compilerVersion comp < mkVersion [7, 7]) $ do
1521         e <- doesFileExist target
1522         when e (removeFile target)
1523       runGhcProg linkOpts{ghcOptOutputFile = toFlag target}
1524     GBuildFLib flib -> do
1525       let rtsInfo = extractRtsInfo lbi
1526           rtsOptLinkLibs =
1527             [ if needDynamic
1528                 then
1529                   if threaded
1530                     then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)
1531                     else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)
1532                 else
1533                   if threaded
1534                     then statRtsThreadedLib (rtsStaticInfo rtsInfo)
1535                     else statRtsVanillaLib (rtsStaticInfo rtsInfo)
1536             ]
1537           linkOpts = case foreignLibType flib of
1538             ForeignLibNativeShared ->
1539               commonOpts
1540                 `mappend` linkerOpts
1541                 `mappend` dynLinkerOpts
1542                 `mappend` mempty
1543                   { ghcOptLinkNoHsMain = toFlag True
1544                   , ghcOptShared = toFlag True
1545                   , ghcOptLinkLibs = rtsOptLinkLibs
1546                   , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo
1547                   , ghcOptFPic = toFlag True
1548                   , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm
1549                   }
1550             ForeignLibNativeStatic ->
1551               -- this should be caught by buildFLib
1552               -- (and if we do implement this, we probably don't even want to call
1553               -- ghc here, but rather Ar.createArLibArchive or something)
1554               cabalBug "static libraries not yet implemented"
1555             ForeignLibTypeUnknown ->
1556               cabalBug "unknown foreign lib type"
1557       -- We build under a (potentially) different filename to set a
1558       -- soname on supported platforms.  See also the note for
1559       -- @flibBuildName@.
1560       info verbosity "Linking..."
1561       let buildName = flibBuildName lbi flib
1562       runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir </> buildName)}
1563       renameFile (targetDir </> buildName) (targetDir </> targetName)
1564
1565 data DynamicRtsInfo = DynamicRtsInfo
1566   { dynRtsVanillaLib :: FilePath
1567   , dynRtsThreadedLib :: FilePath
1568   , dynRtsDebugLib :: FilePath
1569   , dynRtsEventlogLib :: FilePath
1570   , dynRtsThreadedDebugLib :: FilePath
1571   , dynRtsThreadedEventlogLib :: FilePath
1572   }
1573
1574 data StaticRtsInfo = StaticRtsInfo
1575   { statRtsVanillaLib :: FilePath
1576   , statRtsThreadedLib :: FilePath
1577   , statRtsDebugLib :: FilePath
1578   , statRtsEventlogLib :: FilePath
1579   , statRtsThreadedDebugLib :: FilePath
1580   , statRtsThreadedEventlogLib :: FilePath
1581   , statRtsProfilingLib :: FilePath
1582   , statRtsThreadedProfilingLib :: FilePath
1583   }
1584
1585 data RtsInfo = RtsInfo
1586   { rtsDynamicInfo :: DynamicRtsInfo
1587   , rtsStaticInfo :: StaticRtsInfo
1588   , rtsLibPaths :: [FilePath]
1589   }
1590
1591 -- | Extract (and compute) information about the RTS library
1592 --
1593 -- TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can
1594 -- find this information somewhere. We can lookup the 'hsLibraries' field of
1595 -- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which
1596 -- doesn't really help.
1597 extractRtsInfo :: LocalBuildInfo -> RtsInfo
1598 extractRtsInfo lbi =
1599   case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of
1600     [(_, [rts])] -> aux rts
1601     _otherwise -> error "No (or multiple) ghc rts package is registered"
1602   where
1603     aux :: InstalledPackageInfo -> RtsInfo
1604     aux rts =
1605       RtsInfo
1606         { rtsDynamicInfo =
1607             DynamicRtsInfo
1608               { dynRtsVanillaLib = withGhcVersion "HSrts"
1609               , dynRtsThreadedLib = withGhcVersion "HSrts_thr"
1610               , dynRtsDebugLib = withGhcVersion "HSrts_debug"
1611               , dynRtsEventlogLib = withGhcVersion "HSrts_l"
1612               , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"
1613               , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"
1614               }
1615         , rtsStaticInfo =
1616             StaticRtsInfo
1617               { statRtsVanillaLib = "HSrts"
1618               , statRtsThreadedLib = "HSrts_thr"
1619               , statRtsDebugLib = "HSrts_debug"
1620               , statRtsEventlogLib = "HSrts_l"
1621               , statRtsThreadedDebugLib = "HSrts_thr_debug"
1622               , statRtsThreadedEventlogLib = "HSrts_thr_l"
1623               , statRtsProfilingLib = "HSrts_p"
1624               , statRtsThreadedProfilingLib = "HSrts_thr_p"
1625               }
1626         , rtsLibPaths = InstalledPackageInfo.libraryDirs rts
1627         }
1628     withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))
1629
1630 -- | Returns True if the modification date of the given source file is newer than
1631 -- the object file we last compiled for it, or if no object file exists yet.
1632 checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
1633 checkNeedsRecompilation filename opts = filename `moreRecentFile` oname
1634   where
1635     oname = getObjectFileName filename opts
1636
1637 -- | Finds the object file name of the given source file
1638 getObjectFileName :: FilePath -> GhcOptions -> FilePath
1639 getObjectFileName filename opts = oname
1640   where
1641     odir = fromFlag (ghcOptObjDir opts)
1642     oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)
1643     oname = odir </> replaceExtension filename oext
1644
1645 -- | Calculate the RPATHs for the component we are building.
1646 --
1647 -- Calculates relative RPATHs when 'relocatable' is set.
1648 getRPaths
1649   :: LocalBuildInfo
1650   -> ComponentLocalBuildInfo
1651   -- ^ Component we are building
1652   -> IO (NubListR FilePath)
1653 getRPaths lbi clbi | supportRPaths hostOS = do
1654   libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
1655   let hostPref = case hostOS of
1656         OSX -> "@loader_path"
1657         _ -> "$ORIGIN"
1658       relPath p = if isRelative p then hostPref </> p else p
1659       rpaths = toNubListR (map relPath libraryPaths)
1660   return rpaths
1661   where
1662     (Platform _ hostOS) = hostPlatform lbi
1663     compid = compilerId . compiler $ lbi
1664
1665     -- The list of RPath-supported operating systems below reflects the
1666     -- platforms on which Cabal's RPATH handling is tested. It does _NOT_
1667     -- reflect whether the OS supports RPATH.
1668
1669     -- E.g. when this comment was written, the *BSD operating systems were
1670     -- untested with regards to Cabal RPATH handling, and were hence set to
1671     -- 'False', while those operating systems themselves do support RPATH.
1672     supportRPaths Linux = True
1673     supportRPaths Windows = False
1674     supportRPaths OSX = True
1675     supportRPaths FreeBSD =
1676       case compid of
1677         CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True
1678         _ -> False
1679     supportRPaths OpenBSD = False
1680     supportRPaths NetBSD = False
1681     supportRPaths DragonFly = False
1682     supportRPaths Solaris = False
1683     supportRPaths AIX = False
1684     supportRPaths HPUX = False
1685     supportRPaths IRIX = False
1686     supportRPaths HaLVM = False
1687     supportRPaths IOS = False
1688     supportRPaths Android = False
1689     supportRPaths Ghcjs = False
1690     supportRPaths Wasi = False
1691     supportRPaths Hurd = True
1692     supportRPaths Haiku = False
1693     supportRPaths (OtherOS _) = False
1694 -- Do _not_ add a default case so that we get a warning here when a new OS
1695 -- is added.
1696
1697 getRPaths _ _ = return mempty
1698
1699 -- | Remove the "-threaded" flag when building a foreign library, as it has no
1700 --   effect when used with "-shared". Returns the updated 'BuildInfo', along
1701 --   with whether or not the flag was present, so we can use it to link against
1702 --   the appropriate RTS on our own.
1703 popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)
1704 popThreadedFlag bi =
1705   ( bi{options = filterHcOptions (/= "-threaded") (options bi)}
1706   , hasThreaded (options bi)
1707   )
1708   where
1709     filterHcOptions
1710       :: (String -> Bool)
1711       -> PerCompilerFlavor [String]
1712       -> PerCompilerFlavor [String]
1713     filterHcOptions p (PerCompilerFlavor ghc ghcjs) =
1714       PerCompilerFlavor (filter p ghc) ghcjs
1715
1716     hasThreaded :: PerCompilerFlavor [String] -> Bool
1717     hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc
1718
1719 -- | Extracts a String representing a hash of the ABI of a built
1720 -- library.  It can fail if the library has not yet been built.
1721 libAbiHash
1722   :: Verbosity
1723   -> PackageDescription
1724   -> LocalBuildInfo
1725   -> Library
1726   -> ComponentLocalBuildInfo
1727   -> IO String
1728 libAbiHash verbosity _pkg_descr lbi lib clbi = do
1729   let
1730     libBi = libBuildInfo lib
1731     comp = compiler lbi
1732     platform = hostPlatform lbi
1733     vanillaArgs =
1734       (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))
1735         `mappend` mempty
1736           { ghcOptMode = toFlag GhcModeAbiHash
1737           , ghcOptInputModules = toNubListR $ exposedModules lib
1738           }
1739     sharedArgs =
1740       vanillaArgs
1741         `mappend` mempty
1742           { ghcOptDynLinkMode = toFlag GhcDynamicOnly
1743           , ghcOptFPic = toFlag True
1744           , ghcOptHiSuffix = toFlag "js_dyn_hi"
1745           , ghcOptObjSuffix = toFlag "js_dyn_o"
1746           , ghcOptExtra = hcSharedOptions GHC libBi
1747           }
1748     profArgs =
1749       vanillaArgs
1750         `mappend` mempty
1751           { ghcOptProfilingMode = toFlag True
1752           , ghcOptProfilingAuto =
1753               Internal.profDetailLevelFlag
1754                 True
1755                 (withProfLibDetail lbi)
1756           , ghcOptHiSuffix = toFlag "js_p_hi"
1757           , ghcOptObjSuffix = toFlag "js_p_o"
1758           , ghcOptExtra = hcProfOptions GHC libBi
1759           }
1760     ghcArgs
1761       | withVanillaLib lbi = vanillaArgs
1762       | withSharedLib lbi = sharedArgs
1763       | withProfLib lbi = profArgs
1764       | otherwise = error "libAbiHash: Can't find an enabled library way"
1765
1766   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
1767   hash <-
1768     getProgramInvocationOutput
1769       verbosity
1770       =<< ghcInvocation verbosity ghcjsProg comp platform ghcArgs
1771   return (takeWhile (not . isSpace) hash)
1772
1773 componentGhcOptions
1774   :: Verbosity
1775   -> LocalBuildInfo
1776   -> BuildInfo
1777   -> ComponentLocalBuildInfo
1778   -> FilePath
1779   -> GhcOptions
1780 componentGhcOptions verbosity lbi bi clbi odir =
1781   let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir
1782    in opts
1783         { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi
1784         }
1785
1786 -- -----------------------------------------------------------------------------
1787 -- Installing
1788
1789 -- | Install executables for GHCJS.
1790 installExe
1791   :: Verbosity
1792   -> LocalBuildInfo
1793   -> FilePath
1794   -- ^ Where to copy the files to
1795   -> FilePath
1796   -- ^ Build location
1797   -> (FilePath, FilePath)
1798   -- ^ Executable (prefix,suffix)
1799   -> PackageDescription
1800   -> Executable
1801   -> IO ()
1802 installExe
1803   verbosity
1804   lbi
1805   binDir
1806   buildPref
1807   (progprefix, progsuffix)
1808   _pkg
1809   exe = do
1810     createDirectoryIfMissingVerbose verbosity True binDir
1811     let exeName' = unUnqualComponentName $ exeName exe
1812         exeFileName = exeName'
1813         fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
1814         installBinary dest = do
1815           runDbProgram verbosity ghcjsProgram (withPrograms lbi) $
1816             [ "--install-executable"
1817             , buildPref </> exeName' </> exeFileName
1818             , "-o"
1819             , dest
1820             ]
1821               ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of
1822                 (True, Just strip) -> ["-strip-program", programPath strip]
1823                 _ -> []
1824     installBinary (binDir </> fixedExeBaseName)
1825
1826 -- | Install foreign library for GHC.
1827 installFLib
1828   :: Verbosity
1829   -> LocalBuildInfo
1830   -> FilePath
1831   -- ^ install location
1832   -> FilePath
1833   -- ^ Build location
1834   -> PackageDescription
1835   -> ForeignLib
1836   -> IO ()
1837 installFLib verbosity lbi targetDir builtDir _pkg flib =
1838   install
1839     (foreignLibIsShared flib)
1840     builtDir
1841     targetDir
1842     (flibTargetName lbi flib)
1843   where
1844     install _isShared srcDir dstDir name = do
1845       let src = srcDir </> name
1846           dst = dstDir </> name
1847       createDirectoryIfMissingVerbose verbosity True targetDir
1848       installOrdinaryFile verbosity src dst
1849
1850 -- | Install for ghc, .hi, .a and, if --with-ghci given, .o
1851 installLib
1852   :: Verbosity
1853   -> LocalBuildInfo
1854   -> FilePath
1855   -- ^ install location
1856   -> FilePath
1857   -- ^ install location for dynamic libraries
1858   -> FilePath
1859   -- ^ Build location
1860   -> PackageDescription
1861   -> Library
1862   -> ComponentLocalBuildInfo
1863   -> IO ()
1864 installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do
1865   whenVanilla $ copyModuleFiles $ Suffix "js_hi"
1866   whenProf $ copyModuleFiles $ Suffix "js_p_hi"
1867   whenShared $ copyModuleFiles $ Suffix "js_dyn_hi"
1868
1869   -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName
1870   -- whenProf    $ installOrdinary builtDir targetDir $ toJSLibName profileLibName
1871   -- whenShared  $ installShared   builtDir dynlibTargetDir $ toJSLibName sharedLibName
1872   -- fixme do these make the correct lib names?
1873   whenHasCode $ do
1874     whenVanilla $ do
1875       sequence_
1876         [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f))
1877         | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib))
1878         , f <- "" : extraLibFlavours (libBuildInfo lib)
1879         ]
1880     -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)
1881     whenProf $ do
1882       installOrdinary builtDir' targetDir (toJSLibName profileLibName)
1883     -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName)
1884     whenShared $
1885       sequence_
1886         [ installShared
1887           builtDir'
1888           dynlibTargetDir
1889           (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f))
1890         | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
1891         , f <- "" : extraDynLibFlavours (libBuildInfo lib)
1892         ]
1893   where
1894     builtDir' = componentBuildDir lbi clbi
1895
1896     install isShared isJS srcDir dstDir name = do
1897       let src = srcDir </> name
1898           dst = dstDir </> name
1899       createDirectoryIfMissingVerbose verbosity True dstDir
1900
1901       if isShared
1902         then installExecutableFile verbosity src dst
1903         else installOrdinaryFile verbosity src dst
1904
1905       when (stripLibs lbi && not isJS) $
1906         Strip.stripLib
1907           verbosity
1908           (hostPlatform lbi)
1909           (withPrograms lbi)
1910           dst
1911
1912     installOrdinary = install False True
1913     installShared = install True True
1914
1915     copyModuleFiles ext =
1916       findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi)
1917         >>= installOrdinaryFiles verbosity targetDir
1918
1919     compiler_id = compilerId (compiler lbi)
1920     platform = hostPlatform lbi
1921     uid = componentUnitId clbi
1922     -- vanillaLibName = mkLibName              uid
1923     profileLibName = mkProfLibName uid
1924     -- sharedLibName  = (mkSharedLibName (hostPlatform lbi) compiler_id)  uid
1925
1926     hasLib =
1927       not $
1928         null (allLibModules lib clbi)
1929           && null (cSources (libBuildInfo lib))
1930           && null (cxxSources (libBuildInfo lib))
1931           && null (jsSources (libBuildInfo lib))
1932     has_code = not (componentIsIndefinite clbi)
1933     whenHasCode = when has_code
1934     whenVanilla = when (hasLib && withVanillaLib lbi)
1935     whenProf = when (hasLib && withProfLib lbi && has_code)
1936     -- whenGHCi    = when (hasLib && withGHCiLib    lbi && has_code)
1937     whenShared = when (hasLib && withSharedLib lbi && has_code)
1938
1939 adjustExts :: String -> String -> GhcOptions -> GhcOptions
1940 adjustExts hiSuf objSuf opts =
1941   opts
1942     `mappend` mempty
1943       { ghcOptHiSuffix = toFlag hiSuf
1944       , ghcOptObjSuffix = toFlag objSuf
1945       }
1946
1947 isDynamic :: Compiler -> Bool
1948 isDynamic = Internal.ghcLookupProperty "GHC Dynamic"
1949
1950 supportsDynamicToo :: Compiler -> Bool
1951 supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
1952
1953 withExt :: FilePath -> String -> FilePath
1954 withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else ""
1955
1956 findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)
1957 findGhcjsGhcVersion verbosity pgm =
1958   findProgramVersion "--numeric-ghc-version" id verbosity pgm
1959
1960 findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)
1961 findGhcjsPkgGhcjsVersion verbosity pgm =
1962   findProgramVersion "--numeric-ghcjs-version" id verbosity pgm
1963
1964 -- -----------------------------------------------------------------------------
1965 -- Registering
1966
1967 hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
1968 hcPkgInfo progdb =
1969   HcPkg.HcPkgInfo
1970     { HcPkg.hcPkgProgram = ghcjsPkgProg
1971     , HcPkg.noPkgDbStack = False
1972     , HcPkg.noVerboseFlag = False
1973     , HcPkg.flagPackageConf = False
1974     , HcPkg.supportsDirDbs = True
1975     , HcPkg.requiresDirDbs = ver >= v7_10
1976     , HcPkg.nativeMultiInstance = ver >= v7_10
1977     , HcPkg.recacheMultiInstance = True
1978     , HcPkg.suppressFilesCheck = True
1979     }
1980   where
1981     v7_10 = mkVersion [7, 10]
1982     ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb
1983     ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg
1984
1985 registerPackage
1986   :: Verbosity
1987   -> ProgramDb
1988   -> PackageDBStack
1989   -> InstalledPackageInfo
1990   -> HcPkg.RegisterOptions
1991   -> IO ()
1992 registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
1993   HcPkg.register
1994     (hcPkgInfo progdb)
1995     verbosity
1996     packageDbs
1997     installedPkgInfo
1998     registerOptions
1999
2000 pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
2001 pkgRoot verbosity lbi = pkgRoot'
2002   where
2003     pkgRoot' GlobalPackageDB =
2004       let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)
2005        in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)
2006     pkgRoot' UserPackageDB = do
2007       appDir <- getAppUserDataDirectory "ghcjs"
2008       -- fixme correct this version
2009       let ver = compilerVersion (compiler lbi)
2010           subdir =
2011             System.Info.arch
2012               ++ '-'
2013               : System.Info.os
2014               ++ '-'
2015               : prettyShow ver
2016           rootDir = appDir </> subdir
2017       -- We must create the root directory for the user package database if it
2018       -- does not yet exists. Otherwise '${pkgroot}' will resolve to a
2019       -- directory at the time of 'ghc-pkg register', and registration will
2020       -- fail.
2021       createDirectoryIfMissing True rootDir
2022       return rootDir
2023     pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)
2024
2025 -- | Get the JavaScript file name and command and arguments to run a
2026 --   program compiled by GHCJS
2027 --   the exe should be the base program name without exe extension
2028 runCmd
2029   :: ProgramDb
2030   -> FilePath
2031   -> (FilePath, FilePath, [String])
2032 runCmd progdb exe =
2033   ( script
2034   , programPath ghcjsProg
2035   , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]
2036   )
2037   where
2038     script = exe <.> "jsexe" </> "all" <.> "js"
2039     ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb