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