GHCJS.hs 38.8 KB
Newer Older
1 2 3
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
module Distribution.Simple.GHCJS (
        configure, getInstalledPackages, getPackageDBContents,
        buildLib, buildExe,
        replLib, replExe,
        startInterpreter,
        installLib, installExe,
        libAbiHash,
        hcPkgInfo,
        registerPackage,
        componentGhcOptions,
        getLibDir,
        isDynamic,
        getGlobalPackageDB,
        runCmd
  ) where

20 21 22
import Prelude ()
import Distribution.Compat.Prelude

23
import Distribution.Simple.GHC.ImplInfo
24 25 26
import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.PackageDescription as PD
import Distribution.InstalledPackageInfo
27
import Distribution.Package
28 29 30 31 32 33 34 35 36 37 38 39
import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
import qualified Distribution.Simple.Hpc as Hpc
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Simple.Program
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Ar    as Ar
import qualified Distribution.Simple.Program.Ld    as Ld
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Simple.Program.GHC
40
import Distribution.Simple.Setup hiding ( Flag )
41
import qualified Distribution.Simple.Setup as Cabal
42
import Distribution.Simple.Compiler hiding ( Flag )
43 44 45 46
import Distribution.Version
import Distribution.System
import Distribution.Verbosity
import Distribution.Utils.NubList
47 48
import Distribution.Text
import Language.Haskell.Extension
49

50
import qualified Data.Map as Map
51
import System.Directory         ( doesFileExist )
52
import System.FilePath          ( (</>), (<.>), takeExtension
ttuegel's avatar
ttuegel committed
53
                                , takeDirectory, replaceExtension )
54 55

configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
56 57 58 59
          -> ProgramDb
          -> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity hcPath hcPkgPath progdb0 = do
  (ghcjsProg, ghcjsVersion, progdb1) <-
60
    requireProgramVersion verbosity ghcjsProgram
61
      (orLaterVersion (mkVersion [0,1]))
62
      (userMaybeSpecifyPath "ghcjs" hcPath progdb0)
63 64 65 66 67 68
  Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)
  let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion

  -- This is slightly tricky, we have to configure ghcjs first, then we use the
  -- location of ghcjs to help find ghcjs-pkg in the case that the user did not
  -- specify the location of ghc-pkg directly:
69
  (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-
70 71 72
    requireProgramVersion verbosity ghcjsPkgProgram {
      programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
    }
73
    anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)
74

75 76
  Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion
                                  verbosity (programPath ghcjsPkgProg)
77

78
  when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $
79 80
       "Version mismatch between ghcjs and ghcjs-pkg: "
    ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " "
81
    ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion
82

83
  when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $
84 85 86 87
       "Version mismatch between ghcjs and ghcjs-pkg: "
    ++ programPath ghcjsProg
    ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " "
    ++ programPath ghcjsPkgProg
88
    ++ " was built with GHC version " ++ display ghcjsPkgVersion
89 90 91 92 93 94 95 96 97 98 99 100

  -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc
  let hsc2hsProgram' =
        hsc2hsProgram { programFindLocation =
                          guessHsc2hsFromGhcjsPath ghcjsProg }
      c2hsProgram' =
        c2hsProgram { programFindLocation =
                          guessC2hsFromGhcjsPath ghcjsProg }

      haddockProgram' =
        haddockProgram { programFindLocation =
                          guessHaddockFromGhcjsPath ghcjsProg }
101
      progdb3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] progdb2
102 103 104 105 106

  languages  <- Internal.getLanguages  verbosity implInfo ghcjsProg
  extensions <- Internal.getExtensions verbosity implInfo ghcjsProg

  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
107
  let ghcInfoMap = Map.fromList ghcInfo
108 109 110 111

  let comp = Compiler {
        compilerId         = CompilerId GHCJS ghcjsVersion,
        compilerAbiTag     = AbiTag $
112
          "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion),
113 114 115 116 117 118 119
        compilerCompat     = [CompilerId GHC ghcjsGhcVersion],
        compilerLanguages  = languages,
        compilerExtensions = extensions,
        compilerProperties = ghcInfoMap
      }
      compPlatform = Internal.targetPlatform ghcInfo
  -- configure gcc and ld
120
  let progdb4 = if ghcjsNativeToo comp
121
                     then Internal.configureToolchain implInfo
122 123 124
                            ghcjsProg ghcInfoMap progdb3
                     else progdb3
  return (comp, compPlatform, progdb4)
125 126 127 128 129

ghcjsNativeToo :: Compiler -> Bool
ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"

guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity
130
                           -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
131 132 133
guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram

guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
134
                         -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
135 136 137
guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram

guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
138
                       -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
139 140 141
guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram

guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity
142
                          -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
143 144 145 146
guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram

guessToolFromGhcjsPath :: Program -> ConfiguredProgram
                       -> Verbosity -> ProgramSearchPath
147
                       -> IO (Maybe (FilePath, [FilePath]))
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath
  = do let toolname          = programName tool
           path              = programPath ghcjsProg
           dir               = takeDirectory path
           versionSuffix     = takeVersionSuffix (dropExeExtension path)
           guessNormal       = dir </> toolname <.> exeExtension
           guessGhcjsVersioned = dir </> (toolname ++ "-ghcjs" ++ versionSuffix)
                                 <.> exeExtension
           guessGhcjs        = dir </> (toolname ++ "-ghcjs")
                               <.> exeExtension
           guessVersioned    = dir </> (toolname ++ versionSuffix) <.> exeExtension
           guesses | null versionSuffix = [guessGhcjs, guessNormal]
                   | otherwise          = [guessGhcjsVersioned,
                                           guessGhcjs,
                                           guessVersioned,
                                           guessNormal]
       info verbosity $ "looking for tool " ++ toolname
         ++ " near compiler in " ++ dir
166
       exists <- traverse doesFileExist guesses
167 168 169 170 171
       case [ file | (file, True) <- zip guesses exists ] of
                   -- If we can't find it near ghc, fall back to the usual
                   -- method.
         []     -> programFindLocation tool verbosity searchpath
         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp
172 173 174 175
                      let lookedAt = map fst
                                   . takeWhile (\(_file, exist) -> not exist)
                                   $ zip guesses exists
                      return (Just (fp, lookedAt))
176 177 178 179 180 181

  where takeVersionSuffix :: FilePath -> String
        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .
                            reverse

-- | Given a single package DB, return all installed packages.
182
getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb
183
                     -> IO InstalledPackageIndex
184 185 186
getPackageDBContents verbosity packagedb progdb = do
  pkgss <- getInstalledPackages' verbosity [packagedb] progdb
  toPackageIndex verbosity pkgss progdb
187 188

-- | Given a package DB stack, return all installed packages.
189
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb
190
                     -> IO InstalledPackageIndex
191
getInstalledPackages verbosity packagedbs progdb = do
ttuegel's avatar
ttuegel committed
192
  checkPackageDbEnvVar
193
  checkPackageDbStack packagedbs
ttuegel's avatar
ttuegel committed
194
  pkgss <- getInstalledPackages' verbosity packagedbs progdb
195
  index <- toPackageIndex verbosity pkgss progdb
196 197 198 199
  return $! index

toPackageIndex :: Verbosity
               -> [(PackageDB, [InstalledPackageInfo])]
200
               -> ProgramDb
201
               -> IO InstalledPackageIndex
202
toPackageIndex verbosity pkgss progdb = do
203 204 205 206 207 208 209 210 211
  -- On Windows, various fields have $topdir/foo rather than full
  -- paths. We need to substitute the right value in so that when
  -- we, for example, call gcc, we have proper paths to give it.
  topDir <- getLibDir' verbosity ghcjsProg
  let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
                | (_, pkgs) <- pkgss ]
  return $! (mconcat indices)

  where
212
    Just ghcjsProg = lookupProgram ghcjsProgram progdb
213

ttuegel's avatar
ttuegel committed
214 215 216 217
checkPackageDbEnvVar :: IO ()
checkPackageDbEnvVar =
    Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH"

218 219 220 221 222 223 224 225 226 227 228 229
checkPackageDbStack :: PackageDBStack -> IO ()
checkPackageDbStack (GlobalPackageDB:rest)
  | GlobalPackageDB `notElem` rest = return ()
checkPackageDbStack rest
  | GlobalPackageDB `notElem` rest =
  die $ "With current ghc versions the global package db is always used "
     ++ "and must be listed first. This ghc limitation may be lifted in "
     ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"
checkPackageDbStack _ =
  die $ "If the global package db is specified, it must be "
     ++ "specified first and cannot be specified multiple times"

230
getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb
231
                      -> IO [(PackageDB, [InstalledPackageInfo])]
232
getInstalledPackages' verbosity packagedbs progdb =
233
  sequenceA
234
    [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
235 236 237 238 239 240
         return (packagedb, pkgs)
    | packagedb <- packagedbs ]

getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir verbosity lbi =
    (reverse . dropWhile isSpace . reverse) `fmap`
241
     getDbProgramOutput verbosity ghcjsProgram
242 243 244 245 246
     (withPrograms lbi) ["--print-libdir"]

getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' verbosity ghcjsProg =
    (reverse . dropWhile isSpace . reverse) `fmap`
247
     getProgramOutput verbosity ghcjsProg ["--print-libdir"]
248 249 250 251 252

-- | Return the 'FilePath' to the global GHC package database.
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB verbosity ghcjsProg =
    (reverse . dropWhile isSpace . reverse) `fmap`
253
     getProgramOutput verbosity ghcjsProg ["--print-global-package-db"]
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270

toJSLibName :: String -> String
toJSLibName lib
  | takeExtension lib `elem` [".dll",".dylib",".so"]
                              = replaceExtension lib "js_so"
  | takeExtension lib == ".a" = replaceExtension lib "js_a"
  | otherwise                 = lib <.> "js_a"

buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription
                  -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
                  -> IO ()
buildLib = buildOrReplLib False
replLib  = buildOrReplLib True

buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)
               -> PackageDescription -> LocalBuildInfo
               -> Library            -> ComponentLocalBuildInfo -> IO ()
271
buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
272
  let uid = componentUnitId clbi
273
      libTargetDir = buildDir lbi
274 275 276 277 278 279 280
      whenVanillaLib forceVanilla =
        when (not forRepl && (forceVanilla || withVanillaLib lbi))
      whenProfLib = when (not forRepl && withProfLib lbi)
      whenSharedLib forceShared =
        when (not forRepl &&  (forceShared || withSharedLib lbi))
      whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)
      ifReplLib = when forRepl
281 282 283
      comp      = compiler lbi
      platform  = hostPlatform lbi
      implInfo  = getImplInfo comp
284 285 286
      nativeToo = ghcjsNativeToo comp

  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
287
  let runGhcjsProg        = runGHC verbosity ghcjsProg comp platform
288 289 290 291 292 293 294 295 296 297
      libBi               = libBuildInfo lib
      isGhcjsDynamic      = isDynamic comp
      dynamicTooSupported = supportsDynamicToo comp
      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi
      forceVanillaLib = doingTH && not isGhcjsDynamic
      forceSharedLib  = doingTH &&     isGhcjsDynamic
      -- TH always needs default libs, even when building for profiling

  -- Determine if program coverage should be enabled and if so, what
  -- '-hpcdir' should be.
298
  let isCoverageEnabled = libCoverage lbi
299
      pkg_name = display $ PD.package pkg_descr
300
      distPref = fromFlag $ configDistPref $ configFlags lbi
301
      hpcdir way
302
        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
303
        | otherwise = mempty
304 305 306 307 308 309 310 311 312

  createDirectoryIfMissingVerbose verbosity True libTargetDir
  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?
  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)
      jsSrcs      = jsSources libBi
      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir
      linkJsLibOpts = mempty {
                        ghcOptExtra = toNubListR $
313
                          [ "-link-js-lib"     , getHSLibraryName uid
314 315 316 317 318 319
                          , "-js-lib-outputdir", libTargetDir ] ++
                          concatMap (\x -> ["-js-lib-src",x]) jsSrcs
                      }
      vanillaOptsNoJsLib = baseOpts `mappend` mempty {
                      ghcOptMode         = toFlag GhcModeMake,
                      ghcOptNumJobs      = numJobs,
320
                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,
321
                      ghcOptHPCDir       = hpcdir Hpc.Vanilla
322 323 324 325 326 327
                    }
      vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts

      profOpts    = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {
                        ghcOptProfilingMode = toFlag True,
                        ghcOptExtra         = toNubListR $
328 329
                                              ghcjsProfOptions libBi,
                        ghcOptHPCDir        = hpcdir Hpc.Prof
330 331 332 333 334
                      }
      sharedOpts  = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {
                        ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                        ghcOptFPic        = toFlag True,
                        ghcOptExtra       = toNubListR $
335 336
                                            ghcjsSharedOptions libBi,
                        ghcOptHPCDir      = hpcdir Hpc.Dyn
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361
                      }
      linkerOpts = mempty {
                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions libBi,
                      ghcOptLinkLibs       = toNubListR $ extraLibs libBi,
                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs libBi,
                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
                      ghcOptInputFiles     =
                        toNubListR $ [libTargetDir </> x | x <- cObjs] ++ jsSrcs
                   }
      replOpts    = vanillaOptsNoJsLib {
                      ghcOptExtra        = overNubListR
                                           Internal.filterGhciFlags
                                           (ghcOptExtra vanillaOpts),
                      ghcOptNumJobs      = mempty
                    }
                    `mappend` linkerOpts
                    `mappend` mempty {
                      ghcOptMode         = toFlag GhcModeInteractive,
                      ghcOptOptimisation = toFlag GhcNoOptimisation
                    }

      vanillaSharedOpts = vanillaOpts `mappend`
                            mempty {
                              ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,
                              ghcOptDynHiSuffix  = toFlag "dyn_hi",
362 363
                              ghcOptDynObjSuffix = toFlag "dyn_o",
                              ghcOptHPCDir       = hpcdir Hpc.Dyn
364 365
                            }

366
  unless (forRepl || (null (allLibModules lib clbi) && null jsSrcs && null cObjs)) $
367 368 369 370 371 372 373
    do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)
           shared  = whenSharedLib  forceSharedLib  (runGhcjsProg sharedOpts)
           useDynToo = dynamicTooSupported &&
                       (forceVanillaLib || withVanillaLib lbi) &&
                       (forceSharedLib  || withSharedLib  lbi) &&
                       null (ghcjsSharedOptions libBi)
       if useDynToo
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388
          then do
              runGhcjsProg vanillaSharedOpts
              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do
                    -- When the vanilla and shared library builds are done
                    -- in one pass, only one set of HPC module interfaces
                    -- are generated. This set should suffice for both
                    -- static and dynamically linked executables. We copy
                    -- the modules interfaces so they are available under
                    -- both ways.
                    copyDirectoryRecursive verbosity dynDir vanillaDir
                _ -> return ()
          else if isGhcjsDynamic
            then do shared;  vanilla
            else do vanilla; shared
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
       whenProfLib (runGhcjsProg profOpts)

  -- build any C sources
  unless (null (cSources libBi) || not nativeToo) $ do
     info verbosity "Building C Sources..."
     sequence_
       [ do let vanillaCcOpts =
                  (Internal.componentCcGhcOptions verbosity implInfo
                     lbi libBi clbi libTargetDir filename)
                profCcOpts    = vanillaCcOpts `mappend` mempty {
                                  ghcOptProfilingMode = toFlag True,
                                  ghcOptObjSuffix     = toFlag "p_o"
                                }
                sharedCcOpts  = vanillaCcOpts `mappend` mempty {
                                  ghcOptFPic        = toFlag True,
                                  ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                                  ghcOptObjSuffix   = toFlag "dyn_o"
                                }
                odir          = fromFlag (ghcOptObjDir vanillaCcOpts)
            createDirectoryIfMissingVerbose verbosity True odir
            runGhcjsProg vanillaCcOpts
            whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts)
            whenProfLib (runGhcjsProg profCcOpts)
       | filename <- cSources libBi]

  -- TODO: problem here is we need the .c files built first, so we can load them
  -- with ghci, but .c files can depend on .h files generated by ghc by ffi
  -- exports.
417
  unless (null (allLibModules lib clbi)) $
418 419 420 421 422 423 424 425 426
     ifReplLib (runGhcjsProg replOpts)

  -- link:
  when (nativeToo && not forRepl) $ do
    info verbosity "Linking..."
    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))
                      (cSources libBi)
        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
                      (cSources libBi)
427 428 429 430 431
        compiler_id = compilerId (compiler lbi)
        vanillaLibFilePath = libTargetDir </> mkLibName            uid
        profileLibFilePath = libTargetDir </> mkProfLibName        uid
        sharedLibFilePath  = libTargetDir </> mkSharedLibName compiler_id uid
        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName uid
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468

    hObjs     <- Internal.getHaskellObjects implInfo lib lbi
                      libTargetDir objExtension True
    hProfObjs <-
      if (withProfLib lbi)
              then Internal.getHaskellObjects implInfo lib lbi
                      libTargetDir ("p_" ++ objExtension) True
              else return []
    hSharedObjs <-
      if (withSharedLib lbi)
              then Internal.getHaskellObjects implInfo lib lbi
                      libTargetDir ("dyn_" ++ objExtension) False
              else return []

    unless (null hObjs && null cObjs) $ do

      let staticObjectFiles =
                 hObjs
              ++ map (libTargetDir </>) cObjs
          profObjectFiles =
                 hProfObjs
              ++ map (libTargetDir </>) cProfObjs
          ghciObjFiles =
                 hObjs
              ++ map (libTargetDir </>) cObjs
          dynamicObjectFiles =
                 hSharedObjs
              ++ map (libTargetDir </>) cSharedObjs
          -- After the relocation lib is created we invoke ghc -shared
          -- with the dependencies spelled out as -package arguments
          -- and ghc invokes the linker with the proper library paths
          ghcSharedLinkArgs =
              mempty {
                ghcOptShared             = toFlag True,
                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,
                ghcOptInputFiles         = toNubListR dynamicObjectFiles,
                ghcOptOutputFile         = toFlag sharedLibFilePath,
469 470
                ghcOptExtra              = toNubListR $
                                           ghcjsSharedOptions libBi,
471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493
                ghcOptNoAutoLinkPackages = toFlag True,
                ghcOptPackageDBs         = withPackageDB lbi,
                ghcOptPackages           = toNubListR $
                                           Internal.mkGhcOptPackages clbi,
                ghcOptLinkLibs           = toNubListR $ extraLibs libBi,
                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi
              }

      whenVanillaLib False $ do
        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles

      whenProfLib $ do
        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles

      whenGHCiLib $ do
        (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
        Ld.combineObjectFiles verbosity ldProg
          ghciLibFilePath ghciObjFiles

      whenSharedLib False $
        runGhcjsProg ghcSharedLinkArgs

-- | Start a REPL without loading any source files.
494
startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform
495
                 -> PackageDBStack -> IO ()
496
startInterpreter verbosity progdb comp platform packageDBs = do
497 498 499 500 501
  let replOpts = mempty {
        ghcOptMode       = toFlag GhcModeInteractive,
        ghcOptPackageDBs = packageDBs
        }
  checkPackageDbStack packageDBs
502
  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb
503
  runGHC verbosity ghcjsProg comp platform replOpts
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518

buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)
                  -> PackageDescription -> LocalBuildInfo
                  -> Executable         -> ComponentLocalBuildInfo -> IO ()
buildExe = buildOrReplExe False
replExe  = buildOrReplExe True

buildOrReplExe :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)
               -> PackageDescription -> LocalBuildInfo
               -> Executable         -> ComponentLocalBuildInfo -> IO ()
buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi
  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do

  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
  let comp         = compiler lbi
519
      platform     = hostPlatform lbi
520
      implInfo     = getImplInfo comp
521
      runGhcjsProg = runGHC verbosity ghcjsProg comp platform
522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
      exeBi        = buildInfo exe

  -- exeNameReal, the name that GHC really uses (with .exe on Windows)
  let exeNameReal = exeName' <.>
                    (if takeExtension exeName' /= ('.':exeExtension)
                       then exeExtension
                       else "")

  let targetDir = (buildDir lbi) </> exeName'
  let exeDir    = targetDir </> (exeName' ++ "-tmp")
  createDirectoryIfMissingVerbose verbosity True targetDir
  createDirectoryIfMissingVerbose verbosity True exeDir
  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?  FIX: what about exeName.hi-boot?

  -- Determine if program coverage should be enabled and if so, what
  -- '-hpcdir' should be.
539
  let isCoverageEnabled = exeCoverage lbi
540
      distPref = fromFlag $ configDistPref $ configFlags lbi
541 542 543
      hpcdir way
        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'
        | otherwise = mempty
544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569

  -- build executables

  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath
  let isGhcjsDynamic      = isDynamic comp
      dynamicTooSupported = supportsDynamicToo comp
      buildRunner = case clbi of
                       ExeComponentLocalBuildInfo {} -> False
                       _                             -> True
      isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]
      jsSrcs        = jsSources exeBi
      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]
      cObjs         = map (`replaceExtension` objExtension) cSrcs
      nativeToo     = ghcjsNativeToo comp
      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)
                    `mappend` mempty {
                      ghcOptMode         = toFlag GhcModeMake,
                      ghcOptInputFiles   = toNubListR $
                        [ srcMainFile | isHaskellMain],
                      ghcOptInputModules = toNubListR $
                        [ m | not isHaskellMain, m <- exeModules exe],
                      ghcOptExtra =
                        if buildRunner then toNubListR ["-build-runner"]
                                       else mempty
                    }
      staticOpts = baseOpts `mappend` mempty {
570 571
                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,
                      ghcOptHPCDir         = hpcdir Hpc.Vanilla
572 573 574
                   }
      profOpts   = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty {
                      ghcOptProfilingMode  = toFlag True,
575 576
                      ghcOptExtra          = toNubListR $ ghcjsProfOptions exeBi,
                      ghcOptHPCDir         = hpcdir Hpc.Prof
577 578 579 580
                    }
      dynOpts    = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty {
                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,
                      ghcOptExtra          = toNubListR $
581 582
                                             ghcjsSharedOptions exeBi,
                      ghcOptHPCDir         = hpcdir Hpc.Dyn
583 584
                    }
      dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty {
585 586
                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,
                      ghcOptHPCDir         = hpcdir Hpc.Dyn
587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691
                    }
      linkerOpts = mempty {
                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions exeBi,
                      ghcOptLinkLibs       = toNubListR $ extraLibs exeBi,
                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs exeBi,
                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,
                      ghcOptInputFiles     = toNubListR $
                                             [exeDir </> x | x <- cObjs] ++ jsSrcs
                   }
      replOpts   = baseOpts {
                      ghcOptExtra          = overNubListR
                                             Internal.filterGhciFlags
                                             (ghcOptExtra baseOpts)
                   }
                   -- For a normal compile we do separate invocations of ghc for
                   -- compiling as for linking. But for repl we have to do just
                   -- the one invocation, so that one has to include all the
                   -- linker stuff too, like -l flags and any .o files from C
                   -- files etc.
                   `mappend` linkerOpts
                   `mappend` mempty {
                      ghcOptMode           = toFlag GhcModeInteractive,
                      ghcOptOptimisation   = toFlag GhcNoOptimisation
                   }
      commonOpts  | withProfExe lbi = profOpts
                  | withDynExe  lbi = dynOpts
                  | otherwise       = staticOpts
      compileOpts | useDynToo = dynTooOpts
                  | otherwise = commonOpts
      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)

      -- For building exe's that use TH with -prof or -dynamic we actually have
      -- to build twice, once without -prof/-dynamic and then again with
      -- -prof/-dynamic. This is because the code that TH needs to run at
      -- compile time needs to be the vanilla ABI so it can be loaded up and run
      -- by the compiler.
      -- With dynamic-by-default GHC the TH object files loaded at compile-time
      -- need to be .dyn_o instead of .o.
      doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi
      -- Should we use -dynamic-too instead of compiling twice?
      useDynToo = dynamicTooSupported && isGhcjsDynamic
                  && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi)
      compileTHOpts | isGhcjsDynamic = dynOpts
                    | otherwise      = staticOpts
      compileForTH
        | forRepl      = False
        | useDynToo    = False
        | isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe)
        | otherwise      = doingTH && (withProfExe lbi || withDynExe lbi)

      linkOpts = commonOpts `mappend`
                 linkerOpts `mappend` mempty {
                      ghcOptLinkNoHsMain   = toFlag (not isHaskellMain)
                 }

  -- Build static/dynamic object files for TH, if needed.
  when compileForTH $
    runGhcjsProg compileTHOpts { ghcOptNoLink  = toFlag True
                               , ghcOptNumJobs = numJobs }

  unless forRepl $
    runGhcjsProg compileOpts { ghcOptNoLink  = toFlag True
                             , ghcOptNumJobs = numJobs }

  -- build any C sources
  unless (null cSrcs || not nativeToo) $ do
   info verbosity "Building C Sources..."
   sequence_
     [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi
                         clbi exeDir filename) `mappend` mempty {
                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi
                                                       then GhcDynamicOnly
                                                       else GhcStaticOnly),
                       ghcOptProfilingMode = toFlag (withProfExe lbi)
                     }
              odir = fromFlag (ghcOptObjDir opts)
          createDirectoryIfMissingVerbose verbosity True odir
          runGhcjsProg opts
     | filename <- cSrcs ]

  -- TODO: problem here is we need the .c files built first, so we can load them
  -- with ghci, but .c files can depend on .h files generated by ghc by ffi
  -- exports.
  when forRepl $ runGhcjsProg replOpts

  -- link:
  unless forRepl $ do
    info verbosity "Linking..."
    runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }

-- |Install for ghc, .hi, .a and, if --with-ghci given, .o
installLib    :: Verbosity
              -> LocalBuildInfo
              -> FilePath  -- ^install location
              -> FilePath  -- ^install location for dynamic libraries
              -> FilePath  -- ^Build location
              -> PackageDescription
              -> Library
              -> ComponentLocalBuildInfo
              -> IO ()
installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
  whenVanilla $ copyModuleFiles "js_hi"
  whenProf    $ copyModuleFiles "js_p_hi"
  whenShared  $ copyModuleFiles "js_dyn_hi"

692 693 694
  whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName
  whenProf    $ installOrdinary builtDir targetDir $ toJSLibName profileLibName
  whenShared  $ installShared   builtDir dynlibTargetDir $ toJSLibName sharedLibName
695 696 697 698 699 700 701 702

  when (ghcjsNativeToo $ compiler lbi) $ do
    -- copy .hi files over:
    whenVanilla $ copyModuleFiles "hi"
    whenProf    $ copyModuleFiles "p_hi"
    whenShared  $ copyModuleFiles "dyn_hi"

    -- copy the built library files over:
703 704 705 706
    whenVanilla $ installOrdinaryNative builtDir targetDir       vanillaLibName
    whenProf    $ installOrdinaryNative builtDir targetDir       profileLibName
    whenGHCi    $ installOrdinaryNative builtDir targetDir       ghciLibName
    whenShared  $ installSharedNative   builtDir dynlibTargetDir sharedLibName
707 708

  where
709
    install isShared isJS srcDir dstDir name = do
710 711 712
      let src = srcDir </> name
          dst = dstDir </> name
      createDirectoryIfMissingVerbose verbosity True dstDir
713

714
      if isShared
715
        then installExecutableFile verbosity src dst
716 717
        else installOrdinaryFile   verbosity src dst

718 719 720
      when (stripLibs lbi && not isJS) $
        Strip.stripLib verbosity
        (hostPlatform lbi) (withPrograms lbi) dst
721

722 723 724 725 726
    installOrdinary = install False True
    installShared   = install True  True

    installOrdinaryNative = install False False
    installSharedNative   = install True  False
727 728

    copyModuleFiles ext =
729
      findModuleFiles [builtDir] [ext] (allLibModules lib clbi)
730 731
      >>= installOrdinaryFiles verbosity targetDir

732 733 734 735 736 737
    compiler_id = compilerId (compiler lbi)
    uid = componentUnitId clbi
    vanillaLibName = mkLibName              uid
    profileLibName = mkProfLibName          uid
    ghciLibName    = Internal.mkGHCiLibName uid
    sharedLibName  = (mkSharedLibName compiler_id)  uid
738

739
    hasLib    = not $ null (allLibModules lib clbi)
740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760
                   && null (cSources (libBuildInfo lib))
    whenVanilla = when (hasLib && withVanillaLib lbi)
    whenProf    = when (hasLib && withProfLib    lbi)
    whenGHCi    = when (hasLib && withGHCiLib    lbi)
    whenShared  = when (hasLib && withSharedLib  lbi)

installExe :: Verbosity
              -> LocalBuildInfo
              -> InstallDirs FilePath -- ^Where to copy the files to
              -> FilePath  -- ^Build location
              -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)
              -> PackageDescription
              -> Executable
              -> IO ()
installExe verbosity lbi installDirs buildPref
           (progprefix, progsuffix) _pkg exe = do
  let binDir = bindir installDirs
  createDirectoryIfMissingVerbose verbosity True binDir
  let exeFileName = exeName exe
      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix
      installBinary dest = do
761
        runDbProgram verbosity ghcjsProgram (withPrograms lbi) $
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
          [ "--install-executable"
          , buildPref </> exeName exe </> exeFileName
          , "-o", dest
          ] ++
          case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of
           (True, Just strip) -> ["-strip-program", programPath strip]
           _                  -> []
  installBinary (binDir </> fixedExeBaseName)

libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
           -> Library -> ComponentLocalBuildInfo -> IO String
libAbiHash verbosity _pkg_descr lbi lib clbi = do
  let
      libBi       = libBuildInfo lib
      comp        = compiler lbi
777
      platform    = hostPlatform lbi
778 779 780 781
      vanillaArgs =
        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
        `mappend` mempty {
          ghcOptMode         = toFlag GhcModeAbiHash,
782
          ghcOptInputModules = toNubListR $ PD.exposedModules lib
783 784 785 786 787 788 789 790 791 792
        }
      profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty {
                     ghcOptProfilingMode = toFlag True,
                     ghcOptExtra         = toNubListR (ghcjsProfOptions libBi)
                 }
      ghcArgs = if withVanillaLib lbi then vanillaArgs
           else if withProfLib    lbi then profArgs
           else error "libAbiHash: Can't find an enabled library way"
  --
  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
793 794
  getProgramInvocationOutput verbosity
    (ghcInvocation ghcjsProg comp platform ghcArgs)
795 796 797 798 799 800 801 802 803

adjustExts :: String -> String -> GhcOptions -> GhcOptions
adjustExts hiSuf objSuf opts =
  opts `mappend` mempty {
    ghcOptHiSuffix  = toFlag hiSuf,
    ghcOptObjSuffix = toFlag objSuf
  }

registerPackage :: Verbosity
804
                -> ProgramDb
805
                -> HcPkg.MultiInstance
806
                -> PackageDBStack
807
                -> InstalledPackageInfo
808
                -> IO ()
809
registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo
810
  | HcPkg.MultiInstance <- multiInstance
811 812 813 814 815 816
  = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity
      packageDbs installedPkgInfo

  | otherwise
  = HcPkg.reregister (hcPkgInfo progdb) verbosity
      packageDbs (Right installedPkgInfo)
817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844

componentGhcOptions :: Verbosity -> LocalBuildInfo
                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
                    -> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
  let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir
  in  opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR
                             (hcOptions GHCJS bi)
           }

ghcjsProfOptions :: BuildInfo -> [String]
ghcjsProfOptions bi =
  hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi

ghcjsSharedOptions :: BuildInfo -> [String]
ghcjsSharedOptions bi =
  hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi

isDynamic :: Compiler -> Bool
isDynamic = Internal.ghcLookupProperty "GHC Dynamic"

supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"

findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsGhcVersion verbosity pgm =
  findProgramVersion "--numeric-ghc-version" id verbosity pgm

845 846 847
findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion verbosity pgm =
  findProgramVersion "--numeric-ghcjs-version" id verbosity pgm
848 849 850 851

-- -----------------------------------------------------------------------------
-- Registering

852 853 854 855 856 857
hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg
                                   , HcPkg.noPkgDbStack    = False
                                   , HcPkg.noVerboseFlag   = False
                                   , HcPkg.flagPackageConf = False
                                   , HcPkg.supportsDirDbs  = True
858 859
                                   , HcPkg.requiresDirDbs  = ver >= v7_10
                                   , HcPkg.nativeMultiInstance  = ver >= v7_10
860 861
                                   , HcPkg.recacheMultiInstance = True
                                   }
862
  where
863
    v7_10 = mkVersion [7,10]
864
    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb
865
    Just ver          = programVersion ghcjsPkgProg
866 867 868 869

-- | Get the JavaScript file name and command and arguments to run a
--   program compiled by GHCJS
--   the exe should be the base program name without exe extension
870
runCmd :: ProgramDb -> FilePath
871
            -> (FilePath, FilePath, [String])
872
runCmd progdb exe =
873 874 875 876 877 878
  ( script
  , programPath ghcjsProg
  , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]
  )
  where
    script = exe <.> "jsexe" </> "all" <.> "js"
879
    Just ghcjsProg = lookupProgram ghcjsProgram progdb