Find GHC on PATH via version suffixes (fixes #2433)

If you enable system-ghc, and have multiple versions of GHC available, Stack will now find the appropriate one based on the version-suffixed name. Note: the code in Stack.Setup is _really_ difficult to follow at this point. This PR makes the situation a bit worse, to avoid making this diff larger than it has to be. A later PR to clean up Stack.Setup would be a great idea.
commercialhaskell · Mar 28, 2019 · 32eb609 · 32eb609
1 parent a73fff7
commit 32eb609
Show file tree

Hide file tree

Showing 27 changed files with 442 additions and 339 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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,28 +114,25 @@ generateLocalHaddockIndex wc bco localDumpPkgs locals = do
                 locals
     generateHaddockIndex
         "local packages"
-        wc
         bco
         dumpPackages
         "."
         (localDocDir bco)
 
 -- | 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,32 +162,29 @@ 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)
         "."
         (snapDocDir bco)
 
 -- | 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
@@ -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
@@ -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