diff --git a/ChangeLog.md b/ChangeLog.md index 4060250484..71fa876ea4 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -149,6 +149,10 @@ Other enhancements: * Warn when a Docker image does not include a `PATH` environment variable. See [#2472](https://github.com/commercialhaskell/stack/issues/2742) +* When using `system-ghc: true`, Stack will now find the appropriate GHC + installation based on the version suffix, allowing you to more easily switch + between various system-installed GHCs. See + [#2433](https://github.com/commercialhaskell/stack/issues/2433). Bug fixes: diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 1d2b5e7434..fad856aabc 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -147,7 +147,8 @@ instance HasProcessContext Ctx where instance HasBuildConfig Ctx instance HasSourceMap Ctx where sourceMapL = envConfigL.sourceMapL -instance HasCompiler Ctx +instance HasCompiler Ctx where + compilerPathsL = envConfigL.compilerPathsL instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 3010e31a45..13460f3732 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -205,8 +205,6 @@ data ExecuteEnv = ExecuteEnv , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage)) , eeLocalDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage)) , eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File)) - , eeGetGhcPath :: !(forall m. MonadIO m => m (Path Abs File)) - , eeGetGhcjsPath :: !(forall m. MonadIO m => m (Path Abs File)) , eeCustomBuilt :: !(IORef (Set PackageName)) -- ^ Stores which packages with custom-setup have already had their -- Setup.hs built. @@ -290,11 +288,11 @@ getSetupExe setupHs setupShimHs tmpdir = do , toFilePath tmpOutputPath ] ++ ["-build-runner" | wc == Ghcjs] - withWorkingDir (toFilePath tmpdir) (proc (compilerExeName wc) args $ \pc0 -> do + compilerPath <- getCompilerPath + withWorkingDir (toFilePath tmpdir) (proc (toFilePath compilerPath) args $ \pc0 -> do let pc = setStdout (useHandleOpen stderr) pc0 runProcess_ pc) - `catch` \ece -> do - compilerPath <- getCompilerPath wc + `catch` \ece -> throwM $ SetupHsBuildFailure (eceExitCode ece) Nothing compilerPath args Nothing [] when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath renameFile tmpExePath exePath @@ -318,8 +316,6 @@ withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPacka idMap <- liftIO $ newTVarIO Map.empty config <- view configL - getGhcPath <- memoizeRef $ getCompilerPath Ghc - getGhcjsPath <- memoizeRef $ getCompilerPath Ghcjs customBuiltRef <- newIORef Set.empty -- Create files for simple setup and setup shim, if necessary @@ -338,7 +334,7 @@ withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPacka setupExe <- getSetupExe setupHs setupShimHs tmpdir cabalPkgVer <- view cabalVersionL - globalDB <- getGlobalDB =<< view (actualCompilerVersionL.whichCompilerL) + globalDB <- cpGlobalDB snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages) localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages) logFilesTChan <- liftIO $ atomically newTChan @@ -366,8 +362,6 @@ withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPacka , eeSnapshotDumpPkgs = snapshotPackagesTVar , eeLocalDumpPkgs = localPackagesTVar , eeLogFiles = logFilesTChan - , eeGetGhcPath = runMemoized getGhcPath - , eeGetGhcjsPath = runMemoized getGhcjsPath , eeCustomBuilt = customBuiltRef } `finally` dumpLogs logFilesTChan totalWanted where @@ -581,7 +575,6 @@ executePlan' :: HasEnvConfig env executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports cv <- view actualCompilerVersionL - let wc = view whichCompilerL cv case nonEmpty . Map.toList $ planUnregisterLocal plan of Nothing -> return () Just ids -> do @@ -636,9 +629,9 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (boptsHaddock eeBuildOpts) $ do snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs) localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs) - generateLocalHaddockIndex wc eeBaseConfigOpts localDumpPkgs eeLocals - generateDepsHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals - generateSnapHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs + generateLocalHaddockIndex eeBaseConfigOpts localDumpPkgs eeLocals + generateDepsHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals + generateSnapHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs when (boptsOpenHaddocks eeBuildOpts) $ do let planPkgs, localPkgs, installedPkgs, availablePkgs :: Map PackageName (PackageIdentifier, InstallLocation) @@ -663,7 +656,6 @@ unregisterPackages :: -> NonEmpty (GhcPkgId, (PackageIdentifier, Text)) -> RIO env () unregisterPackages cv localDB ids = do - let wc = view whichCompilerL cv let logReason ident reason = logInfo $ fromString (packageIdentifierString ident) <> ": unregistering" <> @@ -672,7 +664,7 @@ unregisterPackages cv localDB ids = do else " (" <> RIO.display reason <> ")" let unregisterSinglePkg select (gid, (ident, reason)) = do logReason ident reason - unregisterGhcPkgIds wc localDB $ select ident gid :| [] + unregisterGhcPkgIds localDB $ select ident gid :| [] case cv of -- GHC versions >= 8.0.1 support batch unregistering of packages. See @@ -691,7 +683,7 @@ unregisterPackages cv localDB ids = do let chunksOfNE size = mapMaybe nonEmpty . chunksOf size . NonEmpty.toList for_ (chunksOfNE batchSize ids) $ \batch -> do for_ batch $ \(_, (ident, reason)) -> logReason ident reason - unregisterGhcPkgIds wc localDB $ fmap (Right . fst) batch + unregisterGhcPkgIds localDB $ fmap (Right . fst) batch -- GHC versions >= 7.9 support unregistering of packages via their -- GhcPkgId. @@ -862,10 +854,14 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = when needConfig $ withMVar eeConfigureLock $ \_ -> do deleteCaches pkgDir announce + cp <- view compilerPathsL let programNames = - if eeCabalPkgVer < mkVersion [1, 22] - then ["ghc", "ghc-pkg"] - else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"] + case cpWhich cp of + Ghc -> + [ "--with-ghc=" ++ toFilePath (cpCompiler cp) + , "--with-ghc-pkg=" ++ toFilePath (cpPkg cp) + ] + Ghcjs -> [] exes <- forM programNames $ \name -> do mpath <- findExecutable name return $ case mpath of @@ -1226,10 +1222,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi else do ensureDir setupDir compiler <- view $ actualCompilerVersionL.whichCompilerL - compilerPath <- - case compiler of - Ghc -> eeGetGhcPath - Ghcjs -> eeGetGhcjsPath + compilerPath <- view $ compilerPathsL.to cpCompiler packageArgs <- getPackageArgs setupDir runExe compilerPath $ [ "--make" @@ -1406,7 +1399,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) withModifyEnvVars modifyEnv $ do - let ghcPkgExe = ghcPkgExeName wc + ghcPkgExe <- view $ compilerPathsL.to cpPkg.to toFilePath -- first unregister everything that needs to be unregistered forM_ allToUnregister $ \packageName -> catchAny @@ -1431,7 +1424,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap case mlib of Nothing -> return $ Just $ Executable taskProvides Just _ -> do - mpkgid <- loadInstalledPkg wc pkgDbs eeSnapshotDumpPkgs pname + mpkgid <- loadInstalledPkg pkgDbs eeSnapshotDumpPkgs pname return $ Just $ case mpkgid of @@ -1640,9 +1633,9 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap let sublibName = T.concat ["z-", T.pack $ packageNameString $ packageName package, "-z-", sublib] case parsePackageName $ T.unpack sublibName of Nothing -> return Nothing -- invalid lib, ignored - Just subLibName -> loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar subLibName + Just subLibName -> loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar subLibName - mpkgid <- loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar (packageName package) + mpkgid <- loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar (packageName package) case mpkgid of Nothing -> throwM $ Couldn'tFindPkgId $ packageName package Just pkgid -> return (Library ident pkgid Nothing, sublibsPkgIds) @@ -1671,8 +1664,8 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap return mpkgid - loadInstalledPkg wc pkgDbs tvar name = do - dps <- ghcPkgDescribe name wc pkgDbs $ conduitDumpPackage .| CL.consume + loadInstalledPkg pkgDbs tvar name = do + dps <- ghcPkgDescribe name pkgDbs $ conduitDumpPackage .| CL.consume case dps of [] -> return Nothing [dp] -> do diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 6c01019bd1..698321f123 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -30,7 +30,6 @@ import RIO.PrettyPrint import Stack.Constants import Stack.PackageDump import Stack.Types.Build -import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.Package @@ -100,13 +99,12 @@ shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex - :: (HasProcessContext env, HasLogFunc env) - => WhichCompiler - -> BaseConfigOpts + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) + => BaseConfigOpts -> Map GhcPkgId DumpPackage -- ^ Local package dump -> [LocalPackage] -> RIO env () -generateLocalHaddockIndex wc bco localDumpPkgs locals = do +generateLocalHaddockIndex bco localDumpPkgs locals = do let dumpPackages = mapMaybe (\LocalPackage{lpPackage = Package{..}} -> @@ -116,7 +114,6 @@ generateLocalHaddockIndex wc bco localDumpPkgs locals = do locals generateHaddockIndex "local packages" - wc bco dumpPackages "." @@ -124,20 +121,18 @@ generateLocalHaddockIndex wc bco localDumpPkgs locals = do -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex - :: (HasProcessContext env, HasLogFunc env) - => WhichCompiler - -> BaseConfigOpts + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) + => BaseConfigOpts -> Map GhcPkgId DumpPackage -- ^ Global dump information -> Map GhcPkgId DumpPackage -- ^ Snapshot dump information -> Map GhcPkgId DumpPackage -- ^ Local dump information -> [LocalPackage] -> RIO env () -generateDepsHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do +generateDepsHaddockIndex bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals depDocDir = localDepsDocDir bco generateHaddockIndex "local packages and dependencies" - wc bco deps ".." @@ -167,16 +162,14 @@ generateDepsHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs lo -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex - :: (HasProcessContext env, HasLogFunc env) - => WhichCompiler - -> BaseConfigOpts + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) + => BaseConfigOpts -> Map GhcPkgId DumpPackage -- ^ Global package dump -> Map GhcPkgId DumpPackage -- ^ Snapshot package dump -> RIO env () -generateSnapHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs = +generateSnapHaddockIndex bco globalDumpPkgs snapshotDumpPkgs = generateHaddockIndex "snapshot packages" - wc bco (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) "." @@ -184,15 +177,14 @@ generateSnapHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs = -- | Generate Haddock index and contents for specified packages. generateHaddockIndex - :: (HasProcessContext env, HasLogFunc env) + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => Text - -> WhichCompiler -> BaseConfigOpts -> [DumpPackage] -> FilePath -> Path Abs Dir -> RIO env () -generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do +generateHaddockIndex descr bco dumpPackages docRelFP destDir = do ensureDir destDir interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages unless (null interfaceOpts) $ do @@ -211,8 +203,9 @@ generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do " in\n" <> fromString (toFilePath destIndexFile) liftIO (mapM_ copyPkgDocs interfaceOpts) + haddockExeName <- toFilePath <$> cpHaddock withWorkingDir (toFilePath destDir) $ readProcessNull - (haddockExeName wc) + haddockExeName (map (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep) [bcoSnapDB bco, bcoLocalDB bco] ++ hoAdditionalArgs (boptsHaddockOpts (bcoBuildOpts bco)) ++ diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index bed4643188..18ac402e5f 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -117,7 +117,7 @@ loadDatabase :: HasEnvConfig env -> RIO env ([LoadHelper], [DumpPackage]) loadDatabase installMap mdb lhs0 = do wc <- view $ actualCompilerVersionL.to whichCompiler - (lhs1', dps) <- ghcPkgDump wc (fmap snd (maybeToList mdb)) + (lhs1', dps) <- ghcPkgDump (fmap snd (maybeToList mdb)) $ conduitDumpPackage .| sink let ghcjsHack = wc == Ghcjs && isNothing mdb lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1' diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 3541fea4d6..1b77fd31a2 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -35,7 +35,6 @@ import Stack.Build.Target import Stack.Package import Stack.SourceMap import Stack.Types.Build -import Stack.Types.Compiler (whichCompiler) import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.Package @@ -142,9 +141,8 @@ hashSourceMapData -> SourceMap -> RIO env SourceMapHash hashSourceMapData boptsCli sm = do - let wc = whichCompiler $ smCompiler sm - compilerPath <- getUtf8Builder . fromString . toFilePath <$> getCompilerPath wc - compilerInfo <- getCompilerInfo wc + compilerPath <- getUtf8Builder . fromString . toFilePath <$> getCompilerPath + compilerInfo <- getCompilerInfo immDeps <- forM (Map.elems (smDeps sm)) depPackageHashableContent bc <- view buildConfigL let -- extra bytestring specifying GHC options supposed to be applied to diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 1ba2430dbc..7228b7badf 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -12,7 +12,6 @@ module Stack.GhcPkg ,createDatabase ,unregisterGhcPkgIds ,getCabalPkgVer - ,ghcPkgExeName ,ghcPkgPathEnvVar ,mkGhcPackagePath) where @@ -29,7 +28,7 @@ import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Stack.Constants import Stack.Types.Build -import Stack.Types.Config (HasCompiler) +import Stack.Types.Config (HasCompiler (..), CompilerPaths (..)) import Stack.Types.GhcPkgId import Stack.Types.Compiler import System.FilePath (searchPathSeparator) @@ -37,12 +36,12 @@ import RIO.Process -- | Get the global package database getGlobalDB :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler -> RIO env (Path Abs Dir) -getGlobalDB wc = do + => RIO env (Path Abs Dir) +getGlobalDB = do logDebug "Getting global package database location" -- This seems like a strange way to get the global package database -- location, but I don't know of a better one - bs <- ghcPkg wc [] ["list", "--global"] >>= either throwIO return + bs <- ghcPkg [] ["list", "--global"] >>= either throwIO return let fp = S8.unpack $ stripTrailingColon $ firstLine bs liftIO $ resolveDir' fp where @@ -54,28 +53,27 @@ getGlobalDB wc = do -- | Run the ghc-pkg executable ghcPkg :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler - -> [Path Abs Dir] + => [Path Abs Dir] -> [String] -> RIO env (Either SomeException S8.ByteString) -ghcPkg wc pkgDbs args = do +ghcPkg pkgDbs args = do eres <- go case eres of Left _ -> do - mapM_ (createDatabase wc) pkgDbs + mapM_ createDatabase pkgDbs go Right _ -> return eres where - go = tryAny - $ BL.toStrict . fst - <$> proc (ghcPkgExeName wc) args' readProcess_ + go = do + pkg <- view $ compilerPathsL.to cpPkg.to toFilePath + tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_ args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist. createDatabase :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler -> Path Abs Dir -> RIO env () -createDatabase wc db = do + => Path Abs Dir -> RIO env () +createDatabase db = do exists <- doesFileExist (db relFilePackageCache) unless exists $ do -- ghc-pkg requires that the database directory does not exist @@ -96,15 +94,11 @@ createDatabase wc db = do -- finding out it isn't the hard way ensureDir (parent db) return ["init", toFilePath db] - void $ proc (ghcPkgExeName wc) args $ \pc -> + pkg <- view $ compilerPathsL.to cpPkg.to toFilePath + void $ proc pkg args $ \pc -> readProcess_ pc `onException` logError ("Unable to create package database at " <> fromString (toFilePath db)) --- | Get the name to use for "ghc-pkg", given the compiler version. -ghcPkgExeName :: WhichCompiler -> String -ghcPkgExeName Ghc = "ghc-pkg" -ghcPkgExeName Ghcjs = "ghcjs-pkg" - -- | Get the environment variable to use for the package DB paths. ghcPkgPathEnvVar :: WhichCompiler -> Text ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH" @@ -119,15 +113,13 @@ packageDbFlags pkgDbs = -- | Get the value of a field of the package. findGhcPkgField :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler - -> [Path Abs Dir] -- ^ package databases + => [Path Abs Dir] -- ^ package databases -> String -- ^ package identifier, or GhcPkgId -> Text -> RIO env (Maybe Text) -findGhcPkgField wc pkgDbs name field = do +findGhcPkgField pkgDbs name field = do result <- ghcPkg - wc pkgDbs ["field", "--simple-output", name, T.unpack field] return $ @@ -138,12 +130,11 @@ findGhcPkgField wc pkgDbs name field = do -- | Get the version of the package findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler - -> [Path Abs Dir] -- ^ package databases + => [Path Abs Dir] -- ^ package databases -> PackageName -> RIO env (Maybe Version) -findGhcPkgVersion wc pkgDbs name = do - mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version" +findGhcPkgVersion pkgDbs name = do + mv <- findGhcPkgField pkgDbs (packageNameString name) "version" case mv of Just !v -> return (parseVersion $ T.unpack v) _ -> return Nothing @@ -151,12 +142,11 @@ findGhcPkgVersion wc pkgDbs name = do -- | unregister list of package ghcids, batching available from GHC 8.0.1, -- using GHC package id where available (from GHC 7.9) unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler - -> Path Abs Dir -- ^ package database + => Path Abs Dir -- ^ package database -> NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env () -unregisterGhcPkgIds wc pkgDb epgids = do - eres <- ghcPkg wc [pkgDb] args +unregisterGhcPkgIds pkgDb epgids = do + eres <- ghcPkg [pkgDb] args case eres of Left e -> logWarn $ displayShow e Right _ -> return () @@ -169,11 +159,10 @@ unregisterGhcPkgIds wc pkgDb epgids = do -- | Get the version of Cabal from the global package database. getCabalPkgVer :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler -> RIO env Version -getCabalPkgVer wc = do + => RIO env Version +getCabalPkgVer = do logDebug "Getting Cabal package version" mres <- findGhcPkgVersion - wc [] -- global DB cabalPackageName maybe (throwIO $ Couldn'tFindPkgId cabalPackageName) return mres diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 66a3e8059b..c2e27553a3 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -42,7 +42,6 @@ import Stack.Ghci.Script import Stack.Package import Stack.Setup (withNewLocalBuildTargets) import Stack.Types.Build -import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.Package @@ -367,7 +366,6 @@ runGhci -> RIO env () runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do config <- view configL - wc <- view $ actualCompilerVersionL.whichCompilerL let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts shouldHidePackages = fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages @@ -405,10 +403,11 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do logInfo $ "Configuring GHCi with the following packages: " <> mconcat (intersperse ", " (map (fromString . packageNameString . ghciPkgName) pkgs)) + compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath let execGhci extras = do menv <- liftIO $ configProcessContextSettings config defaultEnvSettings withProcessContext menv $ exec - (fromMaybe (compilerExeName wc) ghciGhcCommand) + (fromMaybe compilerExeName ghciGhcCommand) (("--interactive" : ) $ -- This initial "-i" resets the include directories to -- not include CWD. If there aren't any packages, CWD @@ -425,7 +424,7 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do [_] -> do menv <- liftIO $ configProcessContextSettings config defaultEnvSettings output <- withProcessContext menv - $ runGrabFirstLine (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] + $ runGrabFirstLine (fromMaybe compilerExeName ghciGhcCommand) ["--version"] return $ "Intero" `isPrefixOf` output _ -> return False -- Since usage of 'exec' does not return, we cannot do any cleanup diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 6185e284bb..f7791cd081 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -30,16 +30,14 @@ import Distribution.ModuleName (ModuleName) import qualified Distribution.Text as C import Path.Extra (toFilePathNoTrailingSep) import Stack.GhcPkg -import Stack.Types.Compiler -import Stack.Types.Config (HasCompiler) +import Stack.Types.Config (HasCompiler (..), CompilerPaths (..)) import Stack.Types.GhcPkgId import RIO.Process hiding (readProcess) -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump :: (HasProcessContext env, HasLogFunc env, HasCompiler env) - => WhichCompiler - -> [Path Abs Dir] -- ^ if empty, use global + => [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a ghcPkgDump = ghcPkgCmdArgs ["dump"] @@ -48,7 +46,6 @@ ghcPkgDump = ghcPkgCmdArgs ["dump"] ghcPkgDescribe :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => PackageName - -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a @@ -58,15 +55,15 @@ ghcPkgDescribe pkgName' = ghcPkgCmdArgs ["describe", "--simple-output", packageN ghcPkgCmdArgs :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => [String] - -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a -ghcPkgCmdArgs cmd wc mpkgDbs sink = do +ghcPkgCmdArgs cmd mpkgDbs sink = do case reverse mpkgDbs of - (pkgDb:_) -> createDatabase wc pkgDb -- TODO maybe use some retry logic instead? + (pkgDb:_) -> createDatabase pkgDb -- TODO maybe use some retry logic instead? _ -> return () - sinkProcessStdout (ghcPkgExeName wc) args sink' + pkg <- view $ compilerPathsL.to cpPkg.to toFilePath + sinkProcessStdout pkg args sink' where args = concat [ case mpkgDbs of diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index c0fce0715a..aabd784b1f 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Handy path information. module Stack.Path @@ -66,36 +67,24 @@ fillPathInfo :: HasEnvConfig env => RIO env PathInfo fillPathInfo = do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the -- full environment info including GHC paths etc. - bc <- view $ envConfigL.buildConfigL + piBuildConfig <- view $ envConfigL.buildConfigL -- This is the modified 'bin-path', -- including the local GHC or MSYS if not configured to operate on -- global GHC. -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. -- So it's not the *minimal* override path. - snap <- packageDatabaseDeps - plocal <- packageDatabaseLocal - extra <- packageDatabaseExtra - whichCompiler <- view $ actualCompilerVersionL.whichCompilerL - global <- GhcPkg.getGlobalDB whichCompiler - snaproot <- installationRootDeps - localroot <- installationRootLocal - toolsDir <- bindirCompilerTools - hoogle <- hoogleRoot - distDir <- distRelativeDir - hpcDir <- hpcReportDir - compiler <- getCompilerPath whichCompiler - return $ PathInfo bc - snap - plocal - global - snaproot - localroot - toolsDir - hoogle - distDir - hpcDir - extra - compiler + piSnapDb <- packageDatabaseDeps + piLocalDb <- packageDatabaseLocal + piExtraDbs <- packageDatabaseExtra + piGlobalDb <- cpGlobalDB + piSnapRoot <- installationRootDeps + piLocalRoot <- installationRootLocal + piToolsDir <- bindirCompilerTools + piHoogleRoot <- hoogleRoot + piDistDir <- distRelativeDir + piHpcDir <- hpcReportDir + piCompiler <- getCompilerPath + return PathInfo {..} pathParser :: OA.Parser [Text] pathParser = @@ -109,18 +98,18 @@ pathParser = -- | Passed to all the path printers as a source of info. data PathInfo = PathInfo - { piBuildConfig :: BuildConfig - , piSnapDb :: Path Abs Dir - , piLocalDb :: Path Abs Dir - , piGlobalDb :: Path Abs Dir - , piSnapRoot :: Path Abs Dir - , piLocalRoot :: Path Abs Dir - , piToolsDir :: Path Abs Dir - , piHoogleRoot :: Path Abs Dir + { piBuildConfig :: !BuildConfig + , piSnapDb :: !(Path Abs Dir) + , piLocalDb :: !(Path Abs Dir) + , piGlobalDb :: !(Path Abs Dir) + , piSnapRoot :: !(Path Abs Dir) + , piLocalRoot :: !(Path Abs Dir) + , piToolsDir :: !(Path Abs Dir) + , piHoogleRoot :: !(Path Abs Dir) , piDistDir :: Path Rel Dir - , piHpcDir :: Path Abs Dir - , piExtraDbs :: [Path Abs Dir] - , piCompiler :: Path Abs File + , piHpcDir :: !(Path Abs Dir) + , piExtraDbs :: ![Path Abs Dir] + , piCompiler :: !(Path Abs File) } instance HasPlatform PathInfo diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 3b6c326d35..7ce6a4babb 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -25,7 +25,6 @@ import Path.IO import qualified Stack.Build import Stack.Build.Installed import Stack.Constants (osIsWindows) -import Stack.GhcPkg (ghcPkgExeName) import Stack.PackageDump import Stack.Options.ScriptParser import Stack.Runners @@ -102,7 +101,6 @@ scriptCmd opts = do config <- view configL menv <- liftIO $ configProcessContextSettings config defaultEnvSettings withProcessContext menv $ do - wc <- view $ actualCompilerVersionL.whichCompilerL colorFlag <- appropriateGhcColorFlag targetsSet <- @@ -120,8 +118,8 @@ scriptCmd opts = do -- --simple-output to check which packages are installed -- already. If all needed packages are available, we can -- skip the (rather expensive) build call below. - bss <- sinkProcessStdout - (ghcPkgExeName wc) + pkg <- view $ compilerPathsL.to cpPkg.to toFilePath + bss <- sinkProcessStdout pkg ["list", "--simple-output"] CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy? let installed = Set.fromList $ map toPackageName @@ -150,7 +148,9 @@ scriptCmd opts = do , soGhcOptions opts ] case soCompile opts of - SEInterpret -> exec ("run" ++ compilerExeName wc) + SEInterpret -> do + interpret <- cpInterpreter + exec (toFilePath interpret) (ghcArgs ++ toFilePath file : soArgs opts) _ -> do -- Use readProcessStdout_ so that (1) if GHC does send any output @@ -158,8 +158,9 @@ scriptCmd opts = do -- stdout, which could break scripts, and (2) if there's an -- exception, the standard output we did capture will be reported -- to the user. + compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath withWorkingDir (toFilePath scriptDir) $ proc - (compilerExeName wc) + compilerExeName (ghcArgs ++ [toFilePath file]) (void . readProcessStdout_) exec (toExeName $ toFilePath file) (soArgs opts) @@ -200,8 +201,7 @@ getPackagesFromModuleNames mns = do hashSnapshot :: RIO EnvConfig SnapshotCacheHash hashSnapshot = do sourceMap <- view $ envConfigL . to envConfigSourceMap - let wc = whichCompiler $ smCompiler sourceMap - compilerInfo <- getCompilerInfo wc + compilerInfo <- getCompilerInfo let eitherPliHash (pn, dep) | PLImmutable pli <- dpLocation dep = Right $ immutableLocSha pli | otherwise = diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index c8bdcebfd1..7434a7b10f 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -241,25 +241,24 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do , soptsGHCJSBootOpts = ["--clean"] } - (mghcBin, mCompilerBuild, _) <- ensureCompiler sopts + compilerPaths <- ensureCompiler sopts + let ghcBin = cpExtraDirs compilerPaths + compilerVer = cpCompilerVersion compilerPaths -- Modify the initial environment to include the GHC path, if a local GHC -- is being used menv0 <- view processContextL env <- either throwM (return . removeHaskellEnvVars) $ augmentPathMap - (map toFilePath $ maybe [] edBins mghcBin) + (map toFilePath $ edBins ghcBin) (view envVarsL menv0) menv <- mkProcessContext env - (compilerVer, cabalVer, globaldb) <- runWithGHC menv $ runConcurrently $ (,,) - <$> Concurrently (getCompilerVersion wc) - <*> Concurrently (getCabalPkgVer wc) - <*> Concurrently (getGlobalDB wc) + globaldb <- liftIO $ cpGlobalDB' compilerPaths compilerPaths logDebug "Resolving package entries" - (sourceMap, sourceMapHash) <- runWithGHC menv $ do + (sourceMap, sourceMapHash) <- runWithGHC menv compilerPaths $ do smActual <- actualFromGhc (bcSMWanted bc) compilerVer let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual) @@ -270,13 +269,14 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do sourceMapHash <- hashSourceMapData boptsCLI sourceMap pure (sourceMap, sourceMapHash) + cabalVersion <- runRIO compilerPaths cpCabalVersion let envConfig0 = EnvConfig { envConfigBuildConfig = bc - , envConfigCabalVersion = cabalVer , envConfigBuildOptsCLI = boptsCLI , envConfigSourceMap = sourceMap , envConfigSourceMapHash = sourceMapHash - , envConfigCompilerBuild = mCompilerBuild + , envConfigCompilerPaths = compilerPaths + , envConfigCabalVersion = cabalVersion } -- extra installation bin directories @@ -286,9 +286,9 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath deps <- runRIO envConfig0 packageDatabaseDeps - runWithGHC menv $ createDatabase wc deps + runWithGHC menv compilerPaths $ createDatabase deps localdb <- runRIO envConfig0 packageDatabaseLocal - runWithGHC menv $ createDatabase wc localdb + runWithGHC menv compilerPaths $ createDatabase localdb extras <- runReaderT packageDatabaseExtra envConfig0 let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb @@ -354,24 +354,24 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do envOverride <- liftIO $ getProcessContext' minimalEnvSettings return EnvConfig { envConfigBuildConfig = bc - { bcConfig = maybe id addIncludeLib mghcBin + { bcConfig = addIncludeLib ghcBin $ set processContextL envOverride (view configL bc) { configProcessContextSettings = getProcessContext' } } - , envConfigCabalVersion = cabalVer , envConfigBuildOptsCLI = boptsCLI , envConfigSourceMap = sourceMap , envConfigSourceMapHash = sourceMapHash - , envConfigCompilerBuild = mCompilerBuild + , envConfigCompilerPaths = compilerPaths + , envConfigCabalVersion = cabalVersion } -- | A modified env which we know has an installed compiler on the PATH. -newtype WithGHC env = WithGHC env +data WithGHC env = WithGHC !CompilerPaths !env insideL :: Lens' (WithGHC env) env -insideL = lens (\(WithGHC x) -> x) (\_ -> WithGHC) +insideL = lens (\(WithGHC _ x) -> x) (\(WithGHC cp _) -> WithGHC cp) instance HasLogFunc env => HasLogFunc (WithGHC env) where logFuncL = insideL.logFuncL @@ -392,16 +392,17 @@ instance HasConfig env => HasConfig (WithGHC env) where configL = insideL.configL instance HasBuildConfig env => HasBuildConfig (WithGHC env) where buildConfigL = insideL.buildConfigL -instance HasCompiler (WithGHC env) +instance HasCompiler (WithGHC env) where + compilerPathsL = to (\(WithGHC cp _) -> cp) -- | Set up a modified environment which includes the modified PATH -- that GHC can be found on. This is needed for looking up global -- package information and ghc fingerprint (result from 'ghc --info'). -runWithGHC :: HasConfig env => ProcessContext -> RIO (WithGHC env) a -> RIO env a -runWithGHC pc inner = do +runWithGHC :: HasConfig env => ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a +runWithGHC pc cp inner = do env <- ask let envg - = WithGHC $ + = WithGHC cp $ set envOverrideSettingsL (\_ -> return pc) $ set processContextL pc env runRIO envg inner @@ -416,8 +417,9 @@ rebuildEnv :: EnvConfig -> RIO env EnvConfig rebuildEnv envConfig needTargets haddockDeps boptsCLI = do let bc = envConfigBuildConfig envConfig + cp = envConfigCompilerPaths envConfig compilerVer = smCompiler $ envConfigSourceMap envConfig - runRIO (WithGHC bc) $ do + runRIO (WithGHC cp bc) $ do smActual <- actualFromGhc (bcSMWanted bc) compilerVer let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual) prunedActual = smActual { @@ -452,12 +454,12 @@ addIncludeLib (ExtraDirs _bins includes libs) config = config } -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary -ensureCompiler :: (HasConfig env, HasGHCVariant env) +ensureCompiler :: forall env. (HasConfig env, HasGHCVariant env) => SetupOpts - -> RIO env (Maybe ExtraDirs, Maybe CompilerBuild, Bool) + -> RIO env CompilerPaths ensureCompiler sopts = do - let wc = whichCompiler (wantedToActual (soptsWantedCompiler sopts)) - when (getGhcVersion (wantedToActual (soptsWantedCompiler sopts)) < mkVersion [7, 8]) $ do + let wanted = soptsWantedCompiler sopts + when (getGhcVersion (wantedToActual wanted) < mkVersion [7, 8]) $ do logWarn "Stack will almost certainly fail with GHC below version 7.8" logWarn "Valiantly attempting to run anyway, but I know this is doomed" logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" @@ -467,16 +469,16 @@ ensureCompiler sopts = do if soptsUseSystem sopts then do logDebug "Getting system compiler version" - getSystemCompiler wc + getSystemCompiler wanted else return Nothing Platform expectedArch _ <- view platformL - let canUseCompiler compilerVersion arch + let canUseCompiler (compilerVersion, arch, _dir) | soptsSkipGhcCheck sopts = True | otherwise = isWanted compilerVersion && arch == expectedArch isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) - needLocal = not (any (uncurry canUseCompiler) msystem) + needLocal = not (any canUseCompiler msystem) getSetupInfo' <- memoizeRef (getSetupInfo (soptsSetupInfoYaml sopts)) @@ -508,8 +510,13 @@ ensureCompiler sopts = do -- If we need to install a GHC or MSYS, try to do so -- Return the additional directory paths of GHC & MSYS. - (mtools, compilerBuild) <- if needLocal - then do + (compilerTool, mmsys2Tool, compilerBuild) <- + case msystem of + Just system | canUseCompiler system -> do + -- Have the right ghc, may still need msys + mmsys2Tool <- getMmsys2Tool + return (Left system, mmsys2Tool, CompilerBuildStandard) + _ -> do -- Install GHC ghcVariant <- view ghcVariantL @@ -518,7 +525,7 @@ ensureCompiler sopts = do installed <- listInstalled localPrograms possibleCompilers <- - case wc of + case whichCompiler $ wantedToActual wanted of Ghc -> do ghcBuilds <- getGhcBuilds forM ghcBuilds $ \ghcBuild -> do @@ -550,8 +557,8 @@ ensureCompiler sopts = do if soptsUseSystem sopts then return False else do - msystemGhc <- getSystemCompiler wc - return (any (uncurry canUseCompiler) msystemGhc) + msystemGhc <- getSystemCompiler wanted + return (any canUseCompiler msystemGhc) let suggestion = fromMaybe (mconcat ([ "To install the correct GHC into " @@ -563,7 +570,7 @@ ensureCompiler sopts = do ])) (soptsResolveMissingGHC sopts) throwM $ CompilerVersionMismatch - msystem + ((\(x, y, _) -> (x, y)) <$> msystem) (soptsWantedCompiler sopts, expectedArch) ghcVariant (case possibleCompilers of @@ -575,38 +582,92 @@ ensureCompiler sopts = do -- Install msys2 on windows, if necessary mmsys2Tool <- getMmsys2Tool - return (Just (Just compilerTool, mmsys2Tool), compilerBuild) - -- Have the right ghc, may still need msys - else do - mmsys2Tool <- getMmsys2Tool - return (Just (Nothing, mmsys2Tool), CompilerBuildStandard) - - mpaths <- case mtools of - Nothing -> return Nothing - Just (compilerTool, mmsys2Tool) -> do - -- Add GHC's and MSYS's paths to the config. - let idents = catMaybes [compilerTool, mmsys2Tool] - paths <- mapM extraDirs idents - return $ Just $ mconcat paths - - menv <- - case mpaths of - Nothing -> view processContextL - Just ed -> do - menv0 <- view processContextL - m <- either throwM return - $ augmentPathMap (toFilePath <$> edBins ed) (view envVarsL menv0) - mkProcessContext (removeHaskellEnvVars m) - - case mtools of - Just (Just (ToolGhcjs cv), _) -> + return (Right compilerTool, mmsys2Tool, compilerBuild) + + paths <- do + -- Add GHC's and MSYS's paths to the config. + compilerPath <- + case compilerTool of + Left (_, _, dir) -> pure ExtraDirs { edBins = [dir], edInclude = [], edLib = [] } + Right tool -> extraDirs tool + msysPath <- for mmsys2Tool extraDirs + return $ compilerPath <> fold msysPath + + menv <- do + let ed = paths + menv0 <- view processContextL + m <- either throwM return + $ augmentPathMap (toFilePath <$> edBins ed) (view envVarsL menv0) + mkProcessContext (removeHaskellEnvVars m) + + case compilerTool of + Right (ToolGhcjs cv) -> withProcessContext menv $ ensureGhcjsBooted cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts) - _ -> return () + _ -> pure () + + let findHelper getName = do + eres <- withProcessContext menv $ findExecutable $ getName $ whichCompiler $ wantedToActual wanted + case eres of + Left e -> throwIO e + Right res -> parseAbsFile res + + -- FIXME this could be much smarter most likely + compiler <- findHelper $ \case + Ghc -> "ghc" + Ghcjs -> "ghcjs" + pkg <- findHelper $ \case + Ghc -> "ghc-pkg" + Ghcjs -> "ghcjs-pkg" + when (soptsSanityCheck sopts) $ withProcessContext menv $ sanityCheck compiler - when (soptsSanityCheck sopts) $ withProcessContext menv $ sanityCheck wc - - return (mpaths, Just compilerBuild, needLocal) + config <- view configL + let refHelper :: RIO (WithGHC Config) a -> RIO env (CompilerPaths -> IO a) + refHelper f = do + ref <- newIORef Nothing + pure $ \cp -> do + mres <- readIORef ref + case mres of + Just res -> pure res + Nothing -> do + res <- runRIO (WithGHC cp config) $ withProcessContext menv f + writeIORef ref $ Just res + pure res + cabalPkgVer <- refHelper getCabalPkgVer + globaldb <- refHelper getGlobalDB + compilerVer <- getCompilerVersion (whichCompiler (wantedToActual wanted)) compiler + + env <- ask + let refHelperFind f = do + ref <- newIORef Nothing + pure $ \_ -> do + mres <- readIORef ref + case mres of + Just res -> pure res + Nothing -> do + res <- runRIO env $ findHelper f + writeIORef ref $ Just res + pure res + interpreter <- refHelperFind + $ \case + Ghc -> "runghc" + Ghcjs -> "runghcjs" + haddock <- refHelperFind + $ \case + Ghc -> "haddock" + Ghcjs -> "haddock-ghcjs" + return CompilerPaths + { cpExtraDirs = paths + , cpBuild = Just compilerBuild -- FIXME is this always Just? Remove the Maybe? + , cpSandboxed = needLocal + , cpCompilerVersion = compilerVer + , cpCompiler = compiler + , cpPkg = pkg + , cpInterpreter' = interpreter + , cpHaddock' = haddock + , cpCabalVersion' = cabalPkgVer + , cpGlobalDB' = globaldb + } -- | Determine which GHC builds to use depending on which shared libraries are available -- on the system. @@ -763,31 +824,38 @@ ensureDockerStackExe containerPlatform = do -- | Get the version of the system compiler, if available getSystemCompiler :: (HasProcessContext env, HasLogFunc env) - => WhichCompiler - -> RIO env (Maybe (ActualCompiler, Arch)) -getSystemCompiler wc = do - let exeName = case wc of - Ghc -> "ghc" - Ghcjs -> "ghcjs" - exists <- doesExecutableExist exeName - if exists - then do - eres <- proc exeName ["--info"] $ tryAny . fmap fst . readProcess_ - let minfo = do - Right lbs <- Just eres - pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)] - version <- lookup "Project version" pairs_ >>= parseVersionThrowing - arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') - return (version, arch) - case (wc, minfo) of - (Ghc, Just (version, arch)) -> return (Just (ACGhc version, arch)) - (Ghcjs, Just (_, arch)) -> do - eversion <- tryAny $ getCompilerVersion Ghcjs - case eversion of - Left _ -> return Nothing - Right version -> return (Just (version, arch)) - (_, Nothing) -> return Nothing - else return Nothing + => WantedCompiler + -> RIO env (Maybe (ActualCompiler, Arch, Path Abs Dir)) +getSystemCompiler wanted = do + let actual = wantedToActual wanted + wc = whichCompiler actual + exeName = compilerVersionString actual + logDebug $ "Looking for executable named " <> fromString exeName + mexe <- findExecutable exeName + case mexe of + Left e -> do + logDebug $ "No such executable found on the PATH: " <> displayShow e + pure Nothing + Right exe -> do + logDebug $ "Found executable at " <> fromString exe + exePath <- parseAbsFile exe + let exeDir = parent exePath + eres <- proc exe ["--info"] $ tryAny . fmap fst . readProcess_ + logDebug $ "--info results: " <> displayShow eres + let minfo = do + Right lbs <- Just eres + pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)] + version <- lookup "Project version" pairs_ >>= parseVersionThrowing + arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') + return (version, arch) + case (wc, minfo) of + (Ghc, Just (version, arch)) -> return (Just (ACGhc version, arch, exeDir)) + (Ghcjs, Just (_, arch)) -> do + eversion <- tryAny $ getCompilerVersion Ghcjs exePath + case eversion of + Left _ -> return Nothing + Right version -> return (Just (version, arch, exeDir)) + (_, Nothing) -> return Nothing -- | Download the most recent SetupInfo getSetupInfo :: HasConfig env => String -> RIO env SetupInfo @@ -1684,18 +1752,15 @@ chunksOverTime diff = do -- | Perform a basic sanity check of GHC sanityCheck :: (HasProcessContext env, HasLogFunc env) - => WhichCompiler - -> RIO env () -sanityCheck wc = withSystemTempDir "stack-sanity-check" $ \dir -> do + => Path Abs File -> RIO env () +sanityCheck ghc = withSystemTempDir "stack-sanity-check" $ \dir -> do let fp = toFilePath $ dir relFileMainHs liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines [ "import Distribution.Simple" -- ensure Cabal library is present , "main = putStrLn \"Hello World\"" ] - let exeName = compilerExeName wc - ghc <- findExecutable exeName >>= either throwM parseAbsFile logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc) - eres <- withWorkingDir (toFilePath dir) $ proc exeName + eres <- withWorkingDir (toFilePath dir) $ proc (toFilePath ghc) [ fp , "-no-user-package-db" ] $ try . readProcess_ diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index bb831b900d..fca4104f74 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -16,7 +15,6 @@ module Stack.Setup.Installed , toolString , toolNameString , parseToolText - , ExtraDirs (..) , extraDirs , installDir , tempInstallDir @@ -31,7 +29,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Distribution.System (Platform (..)) import qualified Distribution.System as Cabal -import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path import Path.IO import Stack.Constants @@ -98,12 +95,13 @@ ghcjsWarning = unwords getCompilerVersion :: (HasProcessContext env, HasLogFunc env) => WhichCompiler + -> Path Abs File -- ^ executable -> RIO env ActualCompiler -getCompilerVersion wc = +getCompilerVersion wc exe = do case wc of Ghc -> do logDebug "Asking GHC for its version" - bs <- fst <$> proc "ghc" ["--numeric-version"] readProcess_ + bs <- fst <$> proc (toFilePath exe) ["--numeric-version"] readProcess_ let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs x <- ACGhc <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion) logDebug $ "GHC version is: " <> display x @@ -114,7 +112,7 @@ getCompilerVersion wc = -- Output looks like -- -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) - bs <- fst <$> proc "ghcjs" ["--version"] readProcess_ + bs <- fst <$> proc (toFilePath exe) ["--version"] readProcess_ let (rest, ghcVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs) (_, ghcjsVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd rest ACGhcjs <$> parseVersionThrowing ghcjsVersion <*> parseVersionThrowing ghcVersion @@ -179,17 +177,6 @@ extraDirs tool = do isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n isGHCJS n = "ghcjs" == n -data ExtraDirs = ExtraDirs - { edBins :: ![Path Abs Dir] - , edInclude :: ![Path Abs Dir] - , edLib :: ![Path Abs Dir] - } deriving (Show, Generic) -instance Semigroup ExtraDirs where - (<>) = mappenddefault -instance Monoid ExtraDirs where - mempty = memptydefault - mappend = (<>) - installDir :: (MonadReader env m, MonadThrow m) => Path Abs Dir -> Tool diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs index 4d429f1606..8c55f1209b 100644 --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -88,7 +88,7 @@ setup -> RIO env () setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do Config{..} <- view configL - (_, _, sandboxedGhc) <- ensureCompiler SetupOpts + sandboxedGhc <- cpSandboxed <$> ensureCompiler SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = configSystemGHC && not scoForceReinstall , soptsWantedCompiler = wantedCompiler diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index b3e62889ee..04f446cd32 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -414,7 +414,7 @@ loadCompiler :: forall env. => ActualCompiler -> RIO env LoadedSnapshot loadCompiler cv = do - m <- ghcPkgDump (whichCompiler cv) [] + m <- ghcPkgDump [] (conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)) return LoadedSnapshot { lsCompilerVersion = cv diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index fa199a228f..76dcb8ff9c 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -48,7 +48,6 @@ import Stack.BuildPlan import Stack.Config (loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Setup -import Stack.Setup.Installed import Stack.Snapshot (loadSnapshotCompiler) import Stack.Types.Build import Stack.Types.BuildPlan @@ -248,7 +247,7 @@ getCabalConfig dir constraintType constraints = do setupCompiler :: (HasConfig env, HasGHCVariant env) => WantedCompiler - -> RIO env (Maybe ExtraDirs) + -> RIO env ExtraDirs setupCompiler compiler = do let msg = Just $ utf8BuilderToText $ "Compiler version (" <> RIO.display compiler <> ") " <> @@ -258,7 +257,7 @@ setupCompiler compiler = do "compiler available on your PATH." config <- view configL - (dirs, _, _) <- ensureCompiler SetupOpts + cpExtraDirs <$> ensureCompiler SetupOpts { soptsInstallIfMissing = configInstallGHC config , soptsUseSystem = configSystemGHC config , soptsWantedCompiler = compiler @@ -273,7 +272,6 @@ setupCompiler compiler = do , soptsGHCBindistURL = Nothing , soptsGHCJSBootOpts = ["--clean"] } - return dirs -- | Runs the given inner command with an updated configuration that -- has the desired GHC on the PATH. @@ -283,13 +281,13 @@ setupCabalEnv -> (ActualCompiler -> RIO (WithGHC env) a) -> RIO env a setupCabalEnv compiler inner = do - mpaths <- setupCompiler compiler + paths <- setupCompiler compiler menv0 <- view processContextL envMap <- either throwM (return . removeHaskellEnvVars) - $ augmentPathMap (toFilePath <$> maybe [] edBins mpaths) + $ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0) menv <- mkProcessContext envMap - runWithGHC menv $ do + runWithGHC menv undefined $ do mcabal <- getCabalInstallVersion case mcabal of Nothing -> throwM SolverMissingCabalInstall @@ -305,9 +303,9 @@ setupCabalEnv compiler inner = do ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () - mver <- getSystemCompiler (whichCompiler (wantedToActual compiler)) + mver <- getSystemCompiler compiler version <- case mver of - Just (version, _) -> do + Just (version, _, _dir) -> do logInfo $ "Using compiler: " <> RIO.display version return version Nothing -> error "Failed to determine compiler version. \ diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 72232ac984..c82c1411ce 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -120,15 +120,14 @@ getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm globalsFromDump :: (HasLogFunc env, HasProcessContext env, HasCompiler env) - => ActualCompiler - -> RIO env (Map PackageName DumpedGlobalPackage) -globalsFromDump compiler = do + => RIO env (Map PackageName DumpedGlobalPackage) +globalsFromDump = do let pkgConduit = conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp) toGlobals ds = Map.fromList $ map (pkgName . dpPackageIdent &&& id) $ Map.elems ds - toGlobals <$> ghcPkgDump (whichCompiler compiler) [] pkgConduit + toGlobals <$> ghcPkgDump [] pkgConduit globalsFromHints :: HasConfig env @@ -151,7 +150,7 @@ actualFromGhc :: -> ActualCompiler -> RIO env (SMActual DumpedGlobalPackage) actualFromGhc smw ac = do - globals <- globalsFromDump ac + globals <- globalsFromDump return SMActual { smaCompiler = ac @@ -236,12 +235,9 @@ pruneGlobals globals deps = in Map.map (GlobalPackage . pkgVersion . dpPackageIdent) keptGlobals <> Map.map ReplacedGlobalPackage prunedGlobals -getCompilerInfo :: (HasConfig env) => WhichCompiler -> RIO env Builder -getCompilerInfo wc = do - let compilerExe = - case wc of - Ghc -> "ghc" - Ghcjs -> "ghcjs" +getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder +getCompilerInfo = do + compilerExe <- view $ compilerPathsL.to cpCompiler.to toFilePath lazyByteString . fst <$> proc compilerExe ["--info"] readProcess_ immutableLocSha :: PackageLocationImmutable -> Builder diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index f417eaa1f4..196dd1ff3a 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -11,10 +11,8 @@ module Stack.Types.Compiler , WhichCompiler (..) , getGhcVersion , whichCompiler - , compilerExeName , compilerVersionText , compilerVersionString - , haddockExeName , isWantedCompiler , wantedToActual , actualToWanted @@ -89,11 +87,3 @@ isWantedCompiler _ _ _ = False getGhcVersion :: ActualCompiler -> Version getGhcVersion (ACGhc v) = v getGhcVersion (ACGhcjs _ v) = v - -compilerExeName :: WhichCompiler -> String -compilerExeName Ghc = "ghc" -compilerExeName Ghcjs = "ghcjs" - -haddockExeName :: WhichCompiler -> String -haddockExeName Ghc = "haddock" -haddockExeName Ghcjs = "haddock-ghcjs" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 7e4b51d4a4..ea6f6f74c1 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -145,7 +145,14 @@ module Stack.Types.Config -- * Lens helpers ,wantedCompilerVersionL ,actualCompilerVersionL - ,HasCompiler + ,HasCompiler(..) + ,CompilerPaths(..) + ,cpInterpreter + ,cpHaddock + ,cpCabalVersion + ,cpGlobalDB + ,cpWhich + ,ExtraDirs(..) ,buildOptsL ,globalOptsL ,buildOptsInstallExesL @@ -221,7 +228,7 @@ import Stack.Types.TemplateName import Stack.Types.Version import qualified System.FilePath as FilePath import System.PosixCompat.Types (UserID, GroupID, FileMode) -import RIO.Process (ProcessContext, HasProcessContext (..), findExecutable) +import RIO.Process (ProcessContext, HasProcessContext (..)) -- Re-exports import Stack.Types.Config.Build as X @@ -552,17 +559,11 @@ projectRootL = stackYamlL.to parent -- | Configuration after the environment has been setup. data EnvConfig = EnvConfig {envConfigBuildConfig :: !BuildConfig - ,envConfigCabalVersion :: !Version - -- ^ This is the version of Cabal that stack will use to compile Setup.hs files - -- in the build process. - -- - -- Note that this is not necessarily the same version as the one that stack - -- depends on as a library and which is displayed when running - -- @stack list-dependencies | grep Cabal@ in the stack project. ,envConfigBuildOptsCLI :: !BuildOptsCLI ,envConfigSourceMap :: !SourceMap ,envConfigSourceMapHash :: !SourceMapHash - ,envConfigCompilerBuild :: !(Maybe CompilerBuild) + ,envConfigCompilerPaths :: !CompilerPaths + ,envConfigCabalVersion :: !Version } ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription @@ -1275,8 +1276,8 @@ platformGhcRelDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Rel Dir) platformGhcRelDir = do - ec <- view envConfigL - let cbSuffix = maybe "" compilerBuildSuffix $ envConfigCompilerBuild ec + cp <- view compilerPathsL + let cbSuffix = maybe "" compilerBuildSuffix $ cpBuild cp verOnly <- platformGhcVerOnlyRelDirStr parseRelDir (mconcat [ verOnly, cbSuffix ]) @@ -1440,18 +1441,8 @@ plainEnvSettings = EnvSettings -- | Get the path for the given compiler ignoring any local binaries. -- -- https://github.com/commercialhaskell/stack/issues/1052 -getCompilerPath - :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasCompiler env) - => WhichCompiler - -> m (Path Abs File) -getCompilerPath wc = do - config' <- view configL - eoWithoutLocals <- liftIO $ - configProcessContextSettings config' minimalEnvSettings { esLocaleUtf8 = True } - eres <- runRIO eoWithoutLocals $ findExecutable $ compilerExeName wc - case eres of - Left e -> throwM e - Right x -> parseAbsFile x +getCompilerPath :: HasCompiler env => RIO env (Path Abs File) +getCompilerPath = view $ compilerPathsL.to cpCompiler data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid @@ -1870,7 +1861,8 @@ instance HasBuildConfig BuildConfig where {-# INLINE buildConfigL #-} instance HasBuildConfig EnvConfig -instance HasCompiler EnvConfig +instance HasCompiler EnvConfig where + compilerPathsL = to envConfigCompilerPaths instance HasEnvConfig EnvConfig where envConfigL = id {-# INLINE envConfigL #-} @@ -1918,9 +1910,75 @@ stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler wantedCompilerVersionL = buildConfigL.to (smwCompiler . bcSMWanted) +-- | Paths on the filesystem for the compiler we're using +data CompilerPaths = CompilerPaths + { cpCompilerVersion :: !ActualCompiler + , cpBuild :: !(Maybe CompilerBuild) + , cpCompiler :: !(Path Abs File) + -- | ghc-pkg or equivalent + , cpPkg :: !(Path Abs File) + -- | runghc, in 'IO' to allow deferring the lookup + , cpInterpreter' :: !(CompilerPaths -> IO (Path Abs File)) + -- | haddock, in 'IO' to allow deferring the lookup + , cpHaddock' :: !(CompilerPaths -> IO (Path Abs File)) + -- | Is this a Stack-sandboxed installation? + , cpSandboxed :: !Bool + , cpExtraDirs :: !ExtraDirs + , cpCabalVersion' :: !(CompilerPaths -> IO Version) + -- ^ This is the version of Cabal that stack will use to compile Setup.hs files + -- in the build process. + -- + -- Note that this is not necessarily the same version as the one that stack + -- depends on as a library and which is displayed when running + -- @stack list-dependencies | grep Cabal@ in the stack project. + , cpGlobalDB' :: !(CompilerPaths -> IO (Path Abs Dir)) + -- ^ Global package database + } + +-- | Helper for 'cpInterpreter'' +cpInterpreter :: HasCompiler env => RIO env (Path Abs File) +cpInterpreter = do + env <- view compilerPathsL + liftIO $ cpInterpreter' env env + +-- | Helper for 'cpHaddock'' +cpHaddock :: HasCompiler env => RIO env (Path Abs File) +cpHaddock = do + env <- view compilerPathsL + liftIO $ cpHaddock' env env + +-- | Helper for 'cpCabalVersion'' +cpCabalVersion :: HasCompiler env => RIO env Version +cpCabalVersion = do + env <- view compilerPathsL + liftIO $ cpCabalVersion' env env + +-- | Helper for 'cpGlobalDB'' +cpGlobalDB :: HasCompiler env => RIO env (Path Abs Dir) +cpGlobalDB = do + env <- view compilerPathsL + liftIO $ cpGlobalDB' env env + +cpWhich :: (MonadReader env m, HasCompiler env) => m WhichCompiler +cpWhich = view $ compilerPathsL.to (whichCompiler.cpCompilerVersion) + +data ExtraDirs = ExtraDirs + { edBins :: ![Path Abs Dir] + , edInclude :: ![Path Abs Dir] + , edLib :: ![Path Abs Dir] + } deriving (Show, Generic) +instance Semigroup ExtraDirs where + (<>) = mappenddefault +instance Monoid ExtraDirs where + mempty = memptydefault + mappend = (<>) + -- | An environment which ensures that the given compiler is available --- on the PATH. This class is used for the type alone, and has no methods. -class HasCompiler env +-- on the PATH +class HasCompiler env where + compilerPathsL :: SimpleGetter env CompilerPaths +instance HasCompiler CompilerPaths where + compilerPathsL = id class HasSourceMap env where sourceMapL :: Lens' env SourceMap @@ -1975,10 +2033,8 @@ globalOptsBuildOptsMonoidL = configMonoidBuildOpts (\x y -> x { configMonoidBuildOpts = y }) -cabalVersionL :: HasEnvConfig env => Lens' env Version -cabalVersionL = envConfigL.lens - envConfigCabalVersion - (\x y -> x { envConfigCabalVersion = y }) +cabalVersionL :: HasEnvConfig env => SimpleGetter env Version +cabalVersionL = envConfigL.to envConfigCabalVersion whichCompilerL :: Getting r ActualCompiler WhichCompiler whichCompilerL = to whichCompiler diff --git a/src/main/Main.hs b/src/main/Main.hs index 5aef82f7d6..623dd20c25 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -98,7 +98,6 @@ import Stack.Snapshot (loadResolver) import Stack.Solver (solveExtraDeps) import Stack.Types.Version import Stack.Types.Config -import Stack.Types.Compiler import Stack.Types.NamedComponent import Stack.Types.SourceMap import Stack.Unpack @@ -805,8 +804,8 @@ execCmd ExecOpts {..} = (cmd, args) <- case (eoCmd, eoArgs) of (ExecCmd cmd, args) -> return (cmd, args) (ExecRun, args) -> getRunCmd args - (ExecGhc, args) -> return ("ghc", args) - (ExecRunGhc, args) -> return ("runghc", args) + (ExecGhc, args) -> getGhcCmd [] args + (ExecRunGhc, args) -> getRunGhcCmd [] args exec cmd args ExecOptsEmbellished {..} -> do @@ -827,17 +826,16 @@ execCmd ExecOpts {..} = (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of (ExecCmd cmd, args) -> return (cmd, args) (ExecRun, args) -> getRunCmd args - (ExecGhc, args) -> getGhcCmd "" eoPackages args + (ExecGhc, args) -> getGhcCmd eoPackages args -- NOTE: This doesn't work for GHCJS, because it doesn't have -- a runghcjs binary. - (ExecRunGhc, args) -> - getGhcCmd "run" eoPackages args + (ExecRunGhc, args) -> getRunGhcCmd eoPackages args runWithPath eoCwd $ exec cmd args where -- return the package-id of the first package in GHC_PACKAGE_PATH - getPkgId wc name = do - mId <- findGhcPkgField wc [] name "id" + getPkgId name = do + mId <- findGhcPkgField [] name "id" case mId of Just i -> return (head $ words (T.unpack i)) -- should never happen as we have already installed the packages @@ -845,8 +843,8 @@ execCmd ExecOpts {..} = hPutStrLn stderr ("Could not find package id of package " ++ name) exitFailure - getPkgOpts wc pkgs = - map ("-package-id=" ++) <$> mapM (getPkgId wc) pkgs + getPkgOpts pkgs = + map ("-package-id=" ++) <$> mapM getPkgId pkgs getRunCmd args = do packages <- view $ buildConfigL.to (smwProject . bcSMWanted) @@ -867,10 +865,15 @@ execCmd ExecOpts {..} = logError "No executables found." liftIO exitFailure - getGhcCmd prefix pkgs args = do - wc <- view $ actualCompilerVersionL.whichCompilerL - pkgopts <- getPkgOpts wc pkgs - return (prefix ++ compilerExeName wc, pkgopts ++ args) + getGhcCmd pkgs args = do + pkgopts <- getPkgOpts pkgs + compiler <- view $ compilerPathsL.to cpCompiler + return (toFilePath compiler, pkgopts ++ args) + + getRunGhcCmd pkgs args = do + pkgopts <- getPkgOpts pkgs + interpret <- cpInterpreter + return (toFilePath interpret, pkgopts ++ args) runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig () runWithPath path callback = case path of diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index ca65b1392d..1aebf32b73 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -11,10 +11,12 @@ import qualified Data.Set as Set import Distribution.License (License(..)) import Distribution.Types.PackageName (mkPackageName) import Distribution.Version (mkVersion) +import Path (parseAbsFile) import Stack.PackageDump import Stack.Prelude import Stack.Setup -import Stack.Types.Compiler +import Stack.Types.Compiler (ActualCompiler (..)) +import Stack.Types.Config import Stack.Types.GhcPkgId import RIO.Process import Test.Hspec @@ -209,7 +211,7 @@ spec = do it "sinkMatching" $ runEnvNoLogging $ do - m <- ghcPkgDump Ghc [] + m <- ghcPkgDump [] $ conduitDumpPackage .| sinkMatching (Map.singleton (mkPackageName "transformers") (mkVersion [0, 0, 0, 0, 0, 0, 1])) case Map.lookup (mkPackageName "base") m of @@ -264,4 +266,19 @@ runEnvNoLogging :: RIO (WithGHC LoggedProcessContext) a -> IO a runEnvNoLogging inner = do envVars <- view envVarsL <$> mkDefaultProcessContext menv <- mkProcessContext $ Map.delete "GHC_PACKAGE_PATH" envVars - runRIO (WithGHC (LoggedProcessContext menv mempty)) inner + let find name = runRIO menv (findExecutable name) >>= either throwIO parseAbsFile + compiler <- find "ghc" + pkg <- find "ghc-pkg" + let cp = CompilerPaths + { cpCompilerVersion = ACGhc $ mkVersion [1, 2, 3] + , cpBuild = Nothing + , cpCompiler = compiler + , cpPkg = pkg + , cpInterpreter' = const $ pure undefined + , cpHaddock' = const $ pure undefined + , cpSandboxed = False + , cpExtraDirs = mempty + , cpCabalVersion' = const $ pure undefined + , cpGlobalDB' = const $ pure undefined + } + runRIO (WithGHC cp (LoggedProcessContext menv mempty)) inner diff --git a/test/integration/tests/2433-ghc-by-version/Main.hs b/test/integration/tests/2433-ghc-by-version/Main.hs new file mode 100644 index 0000000000..d1676c1d32 --- /dev/null +++ b/test/integration/tests/2433-ghc-by-version/Main.hs @@ -0,0 +1,5 @@ +import System.Process (rawSystem) +import Control.Exception (throwIO) + +main :: IO () +main = rawSystem "./run.sh" [] >>= throwIO diff --git a/test/integration/tests/2433-ghc-by-version/files/.gitignore b/test/integration/tests/2433-ghc-by-version/files/.gitignore new file mode 100644 index 0000000000..17906d378e --- /dev/null +++ b/test/integration/tests/2433-ghc-by-version/files/.gitignore @@ -0,0 +1 @@ +/fake-root/ diff --git a/test/integration/tests/2433-ghc-by-version/files/fake-path/ghc b/test/integration/tests/2433-ghc-by-version/files/fake-path/ghc new file mode 100755 index 0000000000..91eca4af65 --- /dev/null +++ b/test/integration/tests/2433-ghc-by-version/files/fake-path/ghc @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +echo I should not be used! +exit 1 diff --git a/test/integration/tests/2433-ghc-by-version/files/fake-path/ghc-pkg b/test/integration/tests/2433-ghc-by-version/files/fake-path/ghc-pkg new file mode 100755 index 0000000000..91eca4af65 --- /dev/null +++ b/test/integration/tests/2433-ghc-by-version/files/fake-path/ghc-pkg @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +echo I should not be used! +exit 1 diff --git a/test/integration/tests/2433-ghc-by-version/files/foo.hs b/test/integration/tests/2433-ghc-by-version/files/foo.hs new file mode 100644 index 0000000000..623c600c18 --- /dev/null +++ b/test/integration/tests/2433-ghc-by-version/files/foo.hs @@ -0,0 +1 @@ +main = putStrLn "Looks like everything is working!" diff --git a/test/integration/tests/2433-ghc-by-version/files/run.sh b/test/integration/tests/2433-ghc-by-version/files/run.sh new file mode 100755 index 0000000000..807cb6ffc8 --- /dev/null +++ b/test/integration/tests/2433-ghc-by-version/files/run.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +set -exuo pipefail + +export PATH=$(pwd)/fake-path:$($STACK_EXE path --resolver ghc-8.2.2 --compiler-bin):$($STACK_EXE path --resolver ghc-8.4.4 --compiler-bin):$PATH +export STACK_ROOT=$(pwd)/fake-root + +which ghc + +$STACK_EXE --system-ghc --no-install-ghc --resolver ghc-8.2.2 ghc -- --info +$STACK_EXE --system-ghc --no-install-ghc --resolver ghc-8.4.4 ghc -- --info + +$STACK_EXE --system-ghc --no-install-ghc --resolver ghc-8.2.2 runghc foo.hs