Add GHCJS support to the Simple build infrastructure

Cabal/Cabal.cabal

@@ -180,6 +180,7 @@ library
     Distribution.Simple.Compiler
     Distribution.Simple.Configure
     Distribution.Simple.GHC
+    Distribution.Simple.GHCJS
     Distribution.Simple.Haddock
     Distribution.Simple.HaskellSuite
     Distribution.Simple.Hpc
@@ -229,6 +230,7 @@ library
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.IPI641
     Distribution.Simple.GHC.IPI642
+    Distribution.Simple.GHC.ImplInfo
     Paths_Cabal
 
   default-language: Haskell98

Cabal/Distribution/Compat/CreatePipe.hs

@@ -15,6 +15,7 @@ import GHC.IO.FD (mkFD)
 import GHC.IO.Device (IODeviceType(Stream))
 import GHC.IO.Handle.FD (mkHandleFromFD)
 import System.IO (IOMode(ReadMode, WriteMode))
+#elif ghcjs_HOST_OS
 #else
 import System.Posix.IO (fdToHandle)
 import qualified System.Posix.IO as Posix
@@ -48,6 +49,8 @@ foreign import ccall "io.h _pipe" c__pipe ::
 
 foreign import ccall "io.h _close" c__close ::
     CInt -> IO CInt
+#elif ghcjs_HOST_OS
+createPipe = error "createPipe"
 #else
 createPipe = do
     (readfd, writefd) <- Posix.createPipe

Cabal/Distribution/Compat/TempFile.hs

@@ -25,7 +25,7 @@ import Foreign.C              (getErrno, errnoToIOError)
 
 import System.Posix.Internals (c_getpid)
 
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
 import System.Directory       ( createDirectory )
 #else
 import qualified System.Posix
@@ -121,7 +121,7 @@ createTempDirectory dir template = do
                 | otherwise              -> ioError e
 
 mkPrivateDir :: String -> IO ()
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
 mkPrivateDir s = createDirectory s
 #else
 mkPrivateDir s = System.Posix.createDirectory s 0o700

Cabal/Distribution/Simple/Build.hs

@@ -23,10 +23,11 @@ module Distribution.Simple.Build (
     writeAutogenFiles,
   ) where
 
-import qualified Distribution.Simple.GHC  as GHC
-import qualified Distribution.Simple.JHC  as JHC
-import qualified Distribution.Simple.LHC  as LHC
-import qualified Distribution.Simple.UHC  as UHC
+import qualified Distribution.Simple.GHC   as GHC
+import qualified Distribution.Simple.GHCJS as GHCJS
+import qualified Distribution.Simple.JHC   as JHC
+import qualified Distribution.Simple.LHC   as LHC
+import qualified Distribution.Simple.UHC   as UHC
 import qualified Distribution.Simple.HaskellSuite as HaskellSuite
 
 import qualified Distribution.Simple.Build.Macros      as Build.Macros
@@ -46,7 +47,6 @@ import qualified Distribution.InstalledPackageInfo as IPI
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.ModuleName (ModuleName)
 
-import Distribution.Simple.Program (ghcPkgProgram)
 import Distribution.Simple.Setup
          ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag )
 import Distribution.Simple.BuildTarget
@@ -115,8 +115,7 @@ build pkg_descr lbi flags suffixes = do
     -- Only bother with this message if we're building the whole package
     setupMessage verbosity "Building" (packageId pkg_descr)
 
-  let Just ghcPkgProg = lookupProgram ghcPkgProgram (withPrograms lbi)
-  internalPackageDB <- createInternalPackageDB verbosity ghcPkgProg distPref
+  internalPackageDB <- createInternalPackageDB verbosity lbi distPref
 
   withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->
     let bi     = componentBuildInfo comp
@@ -153,8 +152,8 @@ repl pkg_descr lbi flags suffixes args = do
 
   initialBuildSteps distPref pkg_descr lbi verbosity
 
-  let Just ghcPkgProg = lookupProgram ghcPkgProgram (withPrograms lbi)
-  internalPackageDB <- createInternalPackageDB verbosity ghcPkgProg distPref
+  internalPackageDB <- createInternalPackageDB verbosity lbi distPref
+
   let lbiForComponent comp lbi' =
         lbi' {
           withPackageDB = withPackageDB lbi ++ [internalPackageDB],
@@ -181,8 +180,9 @@ repl pkg_descr lbi flags suffixes args = do
 startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO ()
 startInterpreter verbosity programDb comp packageDBs =
   case compilerFlavor comp of
-    GHC -> GHC.startInterpreter verbosity programDb comp packageDBs
-    _   -> die "A REPL is not supported with this compiler."
+    GHC   -> GHC.startInterpreter   verbosity programDb comp packageDBs
+    GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs
+    _     -> die "A REPL is not supported with this compiler."
 
 buildComponent :: Verbosity
                -> Flag (Maybe Int)
@@ -440,14 +440,22 @@ benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"
 
 -- | Initialize a new package db file for libraries defined
 -- internally to the package.
-createInternalPackageDB :: Verbosity -> ConfiguredProgram -> FilePath -> IO PackageDB
-createInternalPackageDB verbosity ghcPkgProg distPref = do
-    let dbDir = distPref </> "package.conf.inplace"
-        packageDB = SpecificPackageDB dbDir
-    exists <- doesDirectoryExist dbDir
-    when exists $ removeDirectoryRecursive dbDir
-    HcPkg.init verbosity ghcPkgProg dbDir
-    return packageDB
+createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
+                        -> IO PackageDB
+createInternalPackageDB verbosity lbi distPref = do
+    case compilerFlavor (compiler lbi) of
+      GHC   -> createWith $ GHC.hcPkgInfo   (withPrograms lbi)
+      GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi)
+      LHC   -> createWith $ LHC.hcPkgInfo   (withPrograms lbi)
+      _     -> return packageDB
+    where
+      dbDir = distPref </> "package.conf.inplace"
+      packageDB = SpecificPackageDB dbDir
+      createWith hpi = do
+        exists <- doesDirectoryExist dbDir
+        when exists $ removeDirectoryRecursive dbDir
+        HcPkg.init hpi verbosity dbDir
+        return packageDB
 
 addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
                       -> ProgramDb -> ProgramDb
@@ -472,10 +480,11 @@ buildLib :: Verbosity -> Flag (Maybe Int)
                       -> Library            -> ComponentLocalBuildInfo -> IO ()
 buildLib verbosity numJobs pkg_descr lbi lib clbi =
   case compilerFlavor (compiler lbi) of
-    GHC  -> GHC.buildLib  verbosity numJobs pkg_descr lbi lib clbi
-    JHC  -> JHC.buildLib  verbosity         pkg_descr lbi lib clbi
-    LHC  -> LHC.buildLib  verbosity         pkg_descr lbi lib clbi
-    UHC  -> UHC.buildLib  verbosity         pkg_descr lbi lib clbi
+    GHC   -> GHC.buildLib   verbosity numJobs pkg_descr lbi lib clbi
+    GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi
+    JHC   -> JHC.buildLib   verbosity         pkg_descr lbi lib clbi
+    LHC   -> LHC.buildLib   verbosity         pkg_descr lbi lib clbi
+    UHC   -> UHC.buildLib   verbosity         pkg_descr lbi lib clbi
     HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
     _    -> die "Building is not supported with this compiler."
 
@@ -484,28 +493,30 @@ buildExe :: Verbosity -> Flag (Maybe Int)
                       -> Executable         -> ComponentLocalBuildInfo -> IO ()
 buildExe verbosity numJobs pkg_descr lbi exe clbi =
   case compilerFlavor (compiler lbi) of
-    GHC  -> GHC.buildExe  verbosity numJobs pkg_descr lbi exe clbi
-    JHC  -> JHC.buildExe  verbosity         pkg_descr lbi exe clbi
-    LHC  -> LHC.buildExe  verbosity         pkg_descr lbi exe clbi
-    UHC  -> UHC.buildExe  verbosity         pkg_descr lbi exe clbi
-    _    -> die "Building is not supported with this compiler."
-
+    GHC   -> GHC.buildExe   verbosity numJobs pkg_descr lbi exe clbi
+    GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi
+    JHC   -> JHC.buildExe   verbosity         pkg_descr lbi exe clbi
+    LHC   -> LHC.buildExe   verbosity         pkg_descr lbi exe clbi
+    UHC   -> UHC.buildExe   verbosity         pkg_descr lbi exe clbi
+    _     -> die "Building is not supported with this compiler."
 
 replLib :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Library            -> ComponentLocalBuildInfo -> IO ()
 replLib verbosity pkg_descr lbi lib clbi =
   case compilerFlavor (compiler lbi) of
     -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass
     -- NoFlag as the numJobs parameter.
-    GHC  -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi
-    _    -> die "A REPL is not supported for this compiler."
+    GHC   -> GHC.replLib   verbosity NoFlag pkg_descr lbi lib clbi
+    GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi
+    _     -> die "A REPL is not supported for this compiler."
 
 replExe :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Executable         -> ComponentLocalBuildInfo -> IO ()
 replExe verbosity pkg_descr lbi exe clbi =
   case compilerFlavor (compiler lbi) of
-    GHC  -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi
-    _    -> die "A REPL is not supported for this compiler."
+    GHC   -> GHC.replExe   verbosity NoFlag pkg_descr lbi exe clbi
+    GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi
+    _     -> die "A REPL is not supported for this compiler."
 
 
 initialBuildSteps :: FilePath -- ^"dist" prefix

Cabal/Distribution/Simple/Build/PathsModule.hs

@@ -162,6 +162,9 @@ generate pkg_descr lbi =
         supportsRelocatableProgs GHC  = case buildOS of
                            Windows   -> True
                            _         -> False
+        supportsRelocatableProgs GHCJS = case buildOS of
+                           Windows   -> True
+                           _         -> False
         supportsRelocatableProgs _    = False
 
         paths_modulename = autogenModuleName pkg_descr
@@ -171,9 +174,10 @@ generate pkg_descr lbi =
         path_sep = show [pathSeparator]
 
         supports_language_pragma =
-          compilerFlavor (compiler lbi) == GHC &&
+          (compilerFlavor (compiler lbi) == GHC &&
             (compilerVersion (compiler lbi)
-              `withinRange` orLaterVersion (Version [6,6,1] []))
+              `withinRange` orLaterVersion (Version [6,6,1] []))) ||
+           compilerFlavor (compiler lbi) == GHCJS
 
 -- | Generates the name of the environment variable controlling the path
 -- component of interest.

Cabal/Distribution/Simple/Compiler.hs

@@ -24,7 +24,9 @@ module Distribution.Simple.Compiler (
         -- * Haskell implementations
         module Distribution.Compiler,
         Compiler(..),
-        showCompilerId, compilerFlavor, compilerVersion,
+        showCompilerId, showCompilerIdWithAbi,
+        compilerFlavor, compilerVersion,
+        compilerCompatVersion,
         compilerInfo,
 
         -- * Support for package databases
@@ -59,7 +61,7 @@ import Control.Monad (liftM)
 import Data.Binary (Binary)
 import Data.List (nub)
 import qualified Data.Map as M (Map, lookup)
-import Data.Maybe (catMaybes, isNothing)
+import Data.Maybe (catMaybes, isNothing, listToMaybe)
 import GHC.Generics (Generic)
 import System.Directory (canonicalizePath)
 
@@ -84,12 +86,25 @@ instance Binary Compiler
 showCompilerId :: Compiler -> String
 showCompilerId = display . compilerId
 
+showCompilerIdWithAbi :: Compiler -> String
+showCompilerIdWithAbi comp =
+  display (compilerId comp) ++
+  case compilerAbiTag comp of
+    NoAbiTag  -> []
+    AbiTag xs -> '-':xs
+
 compilerFlavor ::  Compiler -> CompilerFlavor
 compilerFlavor = (\(CompilerId f _) -> f) . compilerId
 
 compilerVersion :: Compiler -> Version
 compilerVersion = (\(CompilerId _ v) -> v) . compilerId
 
+compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version
+compilerCompatVersion flavor comp
+  | compilerFlavor comp == flavor = Just (compilerVersion comp)
+  | otherwise    =
+      listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]
+
 compilerInfo :: Compiler -> CompilerInfo
 compilerInfo c = CompilerInfo (compilerId c)
                               (compilerAbiTag c)
@@ -232,7 +247,10 @@ packageKeySupported = ghcSupported "Uses package keys"
 ghcSupported :: String -> Compiler -> Bool
 ghcSupported key comp =
   case compilerFlavor comp of
-    GHC -> case M.lookup key (compilerProperties comp) of
-      Just "YES" -> True
-      _          -> False
-    _   -> False
+    GHC   -> checkProp
+    GHCJS -> checkProp
+    _     -> False
+  where checkProp =
+          case M.lookup key (compilerProperties comp) of
+            Just "YES" -> True
+            _          -> False

Cabal/Distribution/Simple/Configure.hs

@@ -110,10 +110,11 @@ import Distribution.Version
 import Distribution.Verbosity
     ( Verbosity, lessVerbose )
 
-import qualified Distribution.Simple.GHC  as GHC
-import qualified Distribution.Simple.JHC  as JHC
-import qualified Distribution.Simple.LHC  as LHC
-import qualified Distribution.Simple.UHC  as UHC
+import qualified Distribution.Simple.GHC   as GHC
+import qualified Distribution.Simple.GHCJS as GHCJS
+import qualified Distribution.Simple.JHC   as JHC
+import qualified Distribution.Simple.LHC   as LHC
+import qualified Distribution.Simple.UHC   as UHC
 import qualified Distribution.Simple.HaskellSuite as HaskellSuite
 
 -- Prefer the more generic Data.Traversable.mapM to Prelude.mapM
@@ -574,6 +575,7 @@ configure (pkg_descr0, pbi) cfg
                 then return False
                 else case flavor of
                             GHC | version >= Version [6,5] [] -> return True
+                            GHCJS                             -> return True
                             _ -> do warn verbosity
                                          ("this compiler does not support " ++
                                           "--enable-split-objs; ignoring")
@@ -590,15 +592,19 @@ configure (pkg_descr0, pbi) cfg
                   -- rely on them. By the time that bug was fixed, ghci had
                   -- been changed to read shared libraries instead of archive
                   -- files (see next code block).
-                  not (GHC.ghcDynamic comp)
+                  not (GHC.isDynamic comp)
+                CompilerId GHCJS _ ->
+                  not (GHCJS.isDynamic comp)
                 _ -> False
 
         let sharedLibsByDefault =
               case compilerId comp of
                 CompilerId GHC _ ->
                   -- if ghc is dynamic, then ghci needs a shared
                   -- library, so we build one by default.
-                  GHC.ghcDynamic comp
+                  GHC.isDynamic comp
+                CompilerId GHCJS _ ->
+                  GHCJS.isDynamic comp
                 _ -> False
 
         let lbi = LocalBuildInfo {
@@ -785,10 +791,11 @@ getInstalledPackages verbosity comp packageDBs progconf = do
 
   info verbosity "Reading installed packages..."
   case compilerFlavor comp of
-    GHC -> GHC.getInstalledPackages verbosity packageDBs progconf
-    JHC -> JHC.getInstalledPackages verbosity packageDBs progconf
-    LHC -> LHC.getInstalledPackages verbosity packageDBs progconf
-    UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf
+    GHC   -> GHC.getInstalledPackages verbosity packageDBs progconf
+    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf
+    JHC   -> JHC.getInstalledPackages verbosity packageDBs progconf
+    LHC   -> LHC.getInstalledPackages verbosity packageDBs progconf
+    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs progconf
     HaskellSuite {} ->
       HaskellSuite.getInstalledPackages verbosity packageDBs progconf
     flv -> die $ "don't know how to find the installed packages for "
@@ -802,7 +809,7 @@ getPackageDBContents verbosity comp packageDB progconf = do
   info verbosity "Reading installed packages..."
   case compilerFlavor comp of
     GHC -> GHC.getPackageDBContents verbosity packageDB progconf
-
+    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf
     -- For other compilers, try to fall back on 'getInstalledPackages'.
     _   -> getInstalledPackages verbosity comp [packageDB] progconf
 
@@ -1105,11 +1112,12 @@ configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath
 configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"
 configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do
   (comp, maybePlatform, programsConfig) <- case hcFlavor of
-    GHC  -> GHC.configure  verbosity hcPath hcPkg conf
-    JHC  -> JHC.configure  verbosity hcPath hcPkg conf
-    LHC  -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf
-               LHC.configure  verbosity hcPath Nothing ghcConf
-    UHC  -> UHC.configure  verbosity hcPath hcPkg conf
+    GHC   -> GHC.configure  verbosity hcPath hcPkg conf
+    GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf
+    JHC   -> JHC.configure  verbosity hcPath hcPkg conf
+    LHC   -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf
+                LHC.configure  verbosity hcPath Nothing ghcConf
+    UHC   -> UHC.configure  verbosity hcPath hcPkg conf
     HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf
     _    -> die "Unknown compiler"
   return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)