Merge pull request #1030 from commercialhaskell/setup-ghcjs

Support for stack setup installing + booting GHCJS

ChangeLog.md

@@ -1,3 +1,9 @@
+## 0.1.6.0
+
+Major changes:
+
+* "stack setup" now supports building and booting GHCJS from source tarball.
+
 ## 0.1.5.0
 
 Major changes:

src/Stack/Build/Cache.hs

@@ -302,7 +302,7 @@ precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
 precompiledCacheFile pkgident copts = do
  ec <- asks getEnvConfig
 
- compiler <- parseRelDir $ T.unpack $ compilerVersionName $ envConfigCompilerVersion ec
+ compiler <- parseRelDir $ compilerVersionString $ envConfigCompilerVersion ec
  cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec
  pkg <- parseRelDir $ packageIdentifierString pkgident
 

src/Stack/Build/Execute.hs

@@ -226,8 +226,7 @@ getSetupExe setupHs tmpdir = do
  , "-"
  , Distribution.Text.display $ configPlatform config
  , "-"
- , T.unpack $ compilerVersionName
- $ envConfigCompilerVersion econfig
+ , compilerVersionString $ envConfigCompilerVersion econfig
  ]
  exeNameS = baseNameS ++
  case configPlatform config of

src/Stack/Types/Build.hs

@@ -137,7 +137,7 @@ instance Show StackBuildException where
  Nothing -> "No compiler found, expected "
  Just (actual, arch) -> concat
  [ "Compiler version mismatched, found "
- , T.unpack (compilerVersionName actual)
+ , compilerVersionString actual
  , " ("
  , display arch
  , ")"
@@ -147,7 +147,7 @@ instance Show StackBuildException where
  MatchMinor -> "minor version match with "
  MatchExact -> "exact version "
  NewerMinor -> "minor version match or newer with "
- , T.unpack (compilerVersionName expected)
+ , compilerVersionString expected
  , " ("
  , display earch
  , ghcVariantSuffix ghcVariant

src/Stack/Types/Compiler.hs

@@ -1,12 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Stack.Types.Compiler where
 
 import Control.DeepSeq
 import Data.Aeson
 import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
+import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Monoid ((<>))
 import qualified Data.Text as T
 import GHC.Generics (Generic)
@@ -36,10 +39,24 @@ instance Binary CompilerVersion
 instance HasStructuralInfo CompilerVersion
 instance NFData CompilerVersion
 instance ToJSON CompilerVersion where
- toJSON = toJSON . compilerVersionName
+ toJSON = toJSON . compilerVersionText
 instance FromJSON CompilerVersion where
  parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t)
  parseJSON _ = fail "Invalid CompilerVersion, must be String"
+instance FromJSON a => FromJSON (Map CompilerVersion a) where
+ -- TODO: Dedupe with similar code in Stack.Types.Version?
+ --
+ -- Maybe this ought to be abstracted into a 'JSONKey' class, so that a
+ -- fully generic definition for Map can be provided.
+ parseJSON val = do
+ m <- parseJSON val
+ fmap Map.fromList $ mapM go $ Map.toList m
+ where
+ go (k, v) = do
+ let mparsed = parseCompilerVersion (T.pack k)
+ case mparsed of
+ Nothing -> fail $ "Failed to parse CompilerVersion " ++ k
+ Just parsed -> return (parsed, v)
 
 parseCompilerVersion :: T.Text -> Maybe CompilerVersion
 parseCompilerVersion t
@@ -54,12 +71,15 @@ parseCompilerVersion t
  | otherwise
  = Nothing
 
-compilerVersionName :: CompilerVersion -> T.Text
-compilerVersionName (GhcVersion vghc) =
+compilerVersionText :: CompilerVersion -> T.Text
+compilerVersionText (GhcVersion vghc) =
  "ghc-" <> versionText vghc
-compilerVersionName (GhcjsVersion vghcjs vghc) =
+compilerVersionText (GhcjsVersion vghcjs vghc) =
  "ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc
 
+compilerVersionString :: CompilerVersion -> String
+compilerVersionString = T.unpack . compilerVersionText
+
 whichCompiler :: CompilerVersion -> WhichCompiler
 whichCompiler GhcVersion {} = Ghc
 whichCompiler GhcjsVersion {} = Ghcjs

src/Stack/Types/Config.hs

@@ -448,7 +448,7 @@ instance FromJSON (Resolver,[JSONWarning]) where
 -- directory names
 resolverName :: Resolver -> Text
 resolverName (ResolverSnapshot name) = renderSnapName name
-resolverName (ResolverCompiler v) = compilerVersionName v
+resolverName (ResolverCompiler v) = compilerVersionText v
 resolverName (ResolverCustom name _) = "custom-" <> name
 
 -- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).
@@ -875,7 +875,7 @@ compilerVersionDir = do
  compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)
  parseRelDir $ case compilerVersion of
  GhcVersion version -> versionString version
- GhcjsVersion {} -> T.unpack (compilerVersionName compilerVersion)
+ GhcjsVersion {} -> compilerVersionString compilerVersion
 
 -- | Package database for installing dependencies into
 packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
@@ -1099,6 +1099,7 @@ data SetupInfo = SetupInfo
  , siSevenzDll :: Maybe DownloadInfo
  , siMsys2 :: Map Text VersionedDownloadInfo
  , siGHCs :: Map Text (Map Version DownloadInfo)
+ , siGHCJSs :: Map Text (Map CompilerVersion DownloadInfo)
  }
  deriving Show
 
@@ -1108,6 +1109,7 @@ instance FromJSON (SetupInfo, [JSONWarning]) where
  siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")
  siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)
  siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)
+ siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)
  -- Don't warn about 'portable-git' that is no-longer used
  tellJSONField "portable-git"
  return SetupInfo {..}
@@ -1119,13 +1121,15 @@ instance Monoid SetupInfo where
  , siSevenzDll = Nothing
  , siMsys2 = Map.empty
  , siGHCs = Map.empty
+ , siGHCJSs = Map.empty
  }
  mappend l r =
  SetupInfo
  { siSevenzExe = siSevenzExe l <|> siSevenzExe r
  , siSevenzDll = siSevenzDll l <|> siSevenzDll r
  , siMsys2 = siMsys2 l <> siMsys2 r
- , siGHCs = siGHCs l <> siGHCs r }
+ , siGHCs = siGHCs l <> siGHCs r
+ , siGHCJSs = siGHCJSs l <> siGHCJSs r }
 
 -- | Remote or inline 'SetupInfo'
 data SetupInfoLocation

src/System/Process/Read.hs

@@ -13,6 +13,7 @@ module System.Process.Read
  (readProcessStdout
  ,tryProcessStdout
  ,sinkProcessStdout
+ ,sinkProcessStderrStdout
  ,readProcess
  ,EnvOverride(..)
  ,unEnvOverride
@@ -233,7 +234,7 @@ sinkProcessStdout wd menv name args sinkStdout = do
  menv
  name
  args
- (CL.mapM_ (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))))
+ (CL.mapM_ (\bytes -> liftIO (modifyIORef' stderrBuffer (<> byteString bytes))))
  (CL.iterM (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))) $=
  sinkStdout))
  (\(ProcessExitedUnsuccessfully cp ec) ->

src/main/Main.hs

@@ -562,7 +562,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
  )
  miniConfig <- loadMiniConfig (lcConfig lc)
  mpaths <- runStackTGlobal manager miniConfig go $
- ensureGHC SetupOpts
+ ensureCompiler SetupOpts
  { soptsInstallIfMissing = True
  , soptsUseSystem =
  (configSystemGHC $ lcConfig lc)
@@ -579,11 +579,14 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
  , soptsStackSetupYaml = scoStackSetupYaml
  , soptsGHCBindistURL = scoGHCBindistURL
  }
+ let compiler = case wantedCompiler of
+ GhcVersion _ -> "GHC"
+ GhcjsVersion {} -> "GHCJS"
  case mpaths of
- Nothing -> $logInfo "stack will use the GHC on your PATH"
- Just _ -> $logInfo "stack will use a locally installed GHC"
+ Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH"
+ Just _ -> $logInfo $ "stack will use a locally installed " <> compiler
  $logInfo "For more information on paths, see 'stack path' and 'stack exec env'"
- $logInfo "To use this GHC and packages outside of a project, consider using:"
+ $logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:"
  $logInfo "stack ghc, stack ghci, stack runghc, or stack exec"
  )
  Nothing