Make dot and ls dependencies not require GHC

ChangeLog.md

@@ -120,6 +120,9 @@ Other enhancements:
   [#4480](https://github.com/commercialhaskell/stack/issues/4480).
 * Add `stack purge` as a shortcut for `stack clean --full`. See
   [#3863](https://github.com/commercialhaskell/stack/issues/3863).
+* Both `stack dot` and `stack ls dependencies` accept a
+  `--global-hints` flag to bypass the need for an installed GHC. See
+  [#4390](https://github.com/commercialhaskell/stack/issues/4390).
 
 Bug fixes:
 

src/Stack/Build.hs

@@ -252,7 +252,7 @@ mkBaseConfigOpts boptsCli = do
 
 -- | Provide a function for loading package information from the package index
 loadPackage
-  :: HasEnvConfig env
+  :: (HasBuildConfig env, HasSourceMap env)
   => PackageLocationImmutable
   -> Map FlagName Bool
   -> [Text]

src/Stack/Build/ConstructPlan.hs

@@ -145,6 +145,8 @@ instance HasPantryConfig Ctx where
 instance HasProcessContext Ctx where
     processContextL = configL.processContextL
 instance HasBuildConfig Ctx
+instance HasSourceMap Ctx where
+    sourceMapL = envConfigL.sourceMapL
 instance HasEnvConfig Ctx where
     envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y })
 
@@ -246,7 +248,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
 
     getSources = do
       pPackages <- for (smProject sourceMap) $ \pp -> do
-        lp <- loadLocalPackage sourceMap pp
+        lp <- loadLocalPackage pp
         return $ PSFilePath lp
       bopts <- view $ configL.to configBuild
       deps <- for (smDeps sourceMap) $ \dp ->
@@ -255,7 +257,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
             return $ PSRemote loc (getPLIVersion loc) (dpFromSnapshot dp) (dpCommon dp)
           PLMutable dir -> do
             pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)
-            lp <- loadLocalPackage sourceMap pp
+            lp <- loadLocalPackage pp
             return $ PSFilePath lp
       return $ pPackages <> deps
 
@@ -871,8 +873,11 @@ psForceDirty :: PackageSource -> Bool
 psForceDirty (PSFilePath lp) = lpForceDirty lp
 psForceDirty PSRemote{} = False
 
-psDirty :: MonadIO m => PackageSource -> m (Maybe (Set FilePath))
-psDirty (PSFilePath lp) = runMemoized $ lpDirtyFiles lp
+psDirty
+  :: (MonadIO m, HasEnvConfig env, MonadReader env m)
+  => PackageSource
+  -> m (Maybe (Set FilePath))
+psDirty (PSFilePath lp) = runMemoizedWith $ lpDirtyFiles lp
 psDirty PSRemote {} = pure Nothing -- files never change in a remote package
 
 psLocal :: PackageSource -> Bool

src/Stack/Build/Execute.hs

@@ -1480,7 +1480,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap
         case taskType of
             TTLocalMutable lp -> do
                 when enableTests $ unsetTestSuccess pkgDir
-                caches <- runMemoized $ lpNewBuildCaches lp
+                caches <- runMemoizedWith $ lpNewBuildCaches lp
                 mapM_ (uncurry (writeBuildCache pkgDir))
                       (Map.toList caches)
             TTRemotePackage{} -> return ()
@@ -1722,7 +1722,7 @@ checkExeStatus compiler platform distDir name = do
 -- | Check if any unlisted files have been found, and add them to the build cache.
 checkForUnlistedFiles :: HasEnvConfig env => TaskType -> CTime -> Path Abs Dir -> RIO env [PackageWarning]
 checkForUnlistedFiles (TTLocalMutable lp) preBuildTime pkgDir = do
-    caches <- runMemoized $ lpNewBuildCaches lp
+    caches <- runMemoizedWith $ lpNewBuildCaches lp
     (addBuildCache,warnings) <-
         addUnlistedToBuildCache
             preBuildTime

src/Stack/Build/Source.hs

@@ -51,7 +51,7 @@ projectLocalPackages :: HasEnvConfig env
               => RIO env [LocalPackage]
 projectLocalPackages = do
     sm <- view $ envConfigL.to envConfigSourceMap
-    for (toList $ smProject sm) $ loadLocalPackage sm
+    for (toList $ smProject sm) loadLocalPackage
 
 -- | loads all local dependencies - project packages and local extra-deps
 localDependencies :: HasEnvConfig env => RIO env [LocalPackage]
@@ -62,7 +62,7 @@ localDependencies = do
         case dpLocation dp of
             PLMutable dir -> do
                 pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)
-                Just <$> loadLocalPackage sourceMap pp
+                Just <$> loadLocalPackage pp
             _ -> return Nothing
 
 -- | Given the parsed targets and buld command line options constructs
@@ -236,7 +236,7 @@ splitComponents =
     go a b c (CBench x:xs) = go a b (c . (x:)) xs
 
 loadCommonPackage ::
-       forall env. HasEnvConfig env
+       forall env. (HasBuildConfig env, HasSourceMap env)
     => CommonPackage
     -> RIO env Package
 loadCommonPackage common = do
@@ -247,11 +247,11 @@ loadCommonPackage common = do
 -- | Upgrade the initial project package info to a full-blown @LocalPackage@
 -- based on the selected components
 loadLocalPackage ::
-       forall env. HasEnvConfig env
-    => SourceMap
-    -> ProjectPackage
+       forall env. (HasBuildConfig env, HasSourceMap env)
+    => ProjectPackage
     -> RIO env LocalPackage
-loadLocalPackage sm pp = do
+loadLocalPackage pp = do
+    sm <- view sourceMapL
     let common = ppCommon pp
     bopts <- view buildOptsL
     mcurator <- view $ buildConfigL.to bcCurator
@@ -338,10 +338,10 @@ loadLocalPackage sm pp = do
         testpkg = resolvePackage testconfig gpkg
         benchpkg = resolvePackage benchconfig gpkg
 
-    componentFiles <- memoizeRef $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents
+    componentFiles <- memoizeRefWith $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents
 
-    checkCacheResults <- memoizeRef $ do
-      componentFiles' <- runMemoized componentFiles
+    checkCacheResults <- memoizeRefWith $ do
+      componentFiles' <- runMemoizedWith componentFiles
       forM (Map.toList componentFiles') $ \(component, files) -> do
         mbuildCache <- tryGetBuildCache (ppRoot pp) component
         checkCacheResult <- checkBuildCache
@@ -503,10 +503,11 @@ calcFci modTime' fp = liftIO $
             }
 
 -- | Get 'PackageConfig' for package given its name.
-getPackageConfig :: (MonadReader env m, HasEnvConfig env)
+getPackageConfig
+  :: (HasBuildConfig env, HasSourceMap env)
   => Map FlagName Bool
   -> [Text]
-  -> m PackageConfig
+  -> RIO env PackageConfig
 getPackageConfig flags ghcOptions = do
   platform <- view platformL
   compilerVersion <- view actualCompilerVersionL

src/Stack/Dot.hs

@@ -26,6 +26,8 @@ import qualified Distribution.PackageDescription as PD
 import qualified Distribution.SPDX.License as SPDX
 import           Distribution.License (License(BSD3), licenseFromSPDX)
 import           Distribution.Types.PackageName (mkPackageName)
+import           RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..))
+import           RIO.Process (HasProcessContext (..))
 import           Stack.Build (loadPackage)
 import           Stack.Build.Installed (getInstalled, toInstallMap)
 import           Stack.Build.Source
@@ -34,11 +36,14 @@ import           Stack.Package
 import           Stack.PackageDump (DumpPackage(..))
 import           Stack.Prelude hiding (Display (..), pkgName, loadPackage)
 import qualified Stack.Prelude (pkgName)
+import           Stack.Runners
 import           Stack.SourceMap
 import           Stack.Types.Build
+import           Stack.Types.Compiler (wantedToActual)
 import           Stack.Types.Config
 import           Stack.Types.GhcPkgId
 import           Stack.Types.SourceMap
+import           Stack.Build.Target(NeedTargets(..), parseTargets)
 
 -- | Options record for @stack dot@
 data DotOpts = DotOpts
@@ -58,6 +63,8 @@ data DotOpts = DotOpts
     -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.
     , dotBenchTargets :: Bool
     -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.
+    , dotGlobalHints :: Bool
+    -- ^ Use global hints instead of relying on an actual GHC installation.
     }
 
 data ListDepsOpts = ListDepsOpts
@@ -72,7 +79,7 @@ data ListDepsOpts = ListDepsOpts
     }
 
 -- | Visualize the project's dependencies as a graphviz graph
-dot :: HasEnvConfig env => DotOpts -> RIO env ()
+dot :: DotOpts -> RIO Runner ()
 dot dotOpts = do
   (localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts
   printGraph dotOpts localNames prunedGraph
@@ -88,12 +95,11 @@ data DotPayload = DotPayload
 -- | Create the dependency graph and also prune it as specified in the dot
 -- options. Returns a set of local names and and a map from package names to
 -- dependencies.
-createPrunedDependencyGraph :: HasEnvConfig env
-                            => DotOpts
-                            -> RIO env
+createPrunedDependencyGraph :: DotOpts
+                            -> RIO Runner
                                  (Set PackageName,
                                   Map PackageName (Set PackageName, DotPayload))
-createPrunedDependencyGraph dotOpts = do
+createPrunedDependencyGraph dotOpts = withConfig $ withDotConfig dotOpts $ do
   localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted)
   resultGraph <- createDependencyGraph dotOpts
   let pkgsToPrune = if dotIncludeBase dotOpts
@@ -106,15 +112,14 @@ createPrunedDependencyGraph dotOpts = do
 -- name to a tuple of dependencies and payload if available. This
 -- function mainly gathers the required arguments for
 -- @resolveDependencies@.
-createDependencyGraph :: HasEnvConfig env
-                       => DotOpts
-                       -> RIO env (Map PackageName (Set PackageName, DotPayload))
+createDependencyGraph
+  :: DotOpts
+  -> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
 createDependencyGraph dotOpts = do
-  sourceMap <- view $ envConfigL.to envConfigSourceMap
-  locals <- projectLocalPackages
+  sourceMap <- view sourceMapL
+  locals <- for (toList $ smProject sourceMap) loadLocalPackage
   let graph = Map.fromList $ projectPackageDependencies dotOpts (filter lpWanted locals)
-  installMap <- toInstallMap sourceMap
-  (_, globalDump, _, _) <- getInstalled installMap
+  globalDump <- view $ to dcGlobalDump
   -- TODO: Can there be multiple entries for wired-in-packages? If so,
   -- this will choose one arbitrarily..
   let globalDumpMap = Map.fromList $ map (\dp -> (Stack.Prelude.pkgName (dpPackageIdent dp), dp)) globalDump
@@ -129,9 +134,9 @@ createDependencyGraph dotOpts = do
   resolveDependencies (dotDependencyDepth dotOpts) graph depLoader
   where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)
 
-listDependencies :: HasEnvConfig env
-                  => ListDepsOpts
-                  -> RIO env ()
+listDependencies
+  :: ListDepsOpts
+  -> RIO Runner ()
 listDependencies opts = do
   let dotOpts = listDepsDotOpts opts
   (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts
@@ -244,14 +249,13 @@ resolveDependencies limit graph loadPackageDeps = do
   where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1)
 
 -- | Given a SourceMap and a dependency loader, load the set of dependencies for a package
-createDepLoader :: HasEnvConfig env
-                => SourceMap
+createDepLoader :: SourceMap
                 -> Map PackageName DumpPackage
                 -> Map GhcPkgId PackageIdentifier
                 -> (PackageName -> Version -> PackageLocationImmutable ->
-                    Map FlagName Bool -> [Text] -> RIO env (Set PackageName, DotPayload))
+                    Map FlagName Bool -> [Text] -> RIO DotConfig (Set PackageName, DotPayload))
                 -> PackageName
-                -> RIO env (Set PackageName, DotPayload)
+                -> RIO DotConfig (Set PackageName, DotPayload)
 createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do
   fromMaybe noDepsErr
     (projectPackageDeps <|> dependencyDeps <|> globalDeps)
@@ -372,3 +376,97 @@ isWiredIn = (`Set.member` wiredInPackages)
 localPackageToPackage :: LocalPackage -> Package
 localPackageToPackage lp =
   fromMaybe (lpPackage lp) (lpTestBench lp)
+
+-- Plumbing for --test and --bench flags
+withDotConfig
+    :: DotOpts
+    -> RIO DotConfig a
+    -> RIO Config a
+withDotConfig opts inner =
+  local (over globalOptsL modifyGO) $
+    if dotGlobalHints opts
+      then withBuildConfig withGlobalHints
+      else withReal
+  where
+    withGlobalHints = do
+      bconfig <- view buildConfigL
+      globals <- globalsFromHints $ smwCompiler $ bcSMWanted bconfig
+      fakeGhcPkgId <- parseGhcPkgId "ignored"
+      let smActual = SMActual
+            { smaCompiler = wantedToActual $ smwCompiler $ bcSMWanted bconfig
+            , smaProject = smwProject $ bcSMWanted bconfig
+            , smaDeps = smwDeps $ bcSMWanted bconfig
+            , smaGlobal = Map.mapWithKey toDump globals
+            }
+          toDump :: PackageName -> Version -> DumpPackage
+          toDump name version = DumpPackage
+            { dpGhcPkgId = fakeGhcPkgId
+            , dpPackageIdent = PackageIdentifier name version
+            , dpParentLibIdent = Nothing
+            , dpLicense = Nothing
+            , dpLibDirs = []
+            , dpLibraries = []
+            , dpHasExposedModules = True
+            , dpExposedModules = mempty
+            , dpDepends = []
+            , dpHaddockInterfaces = []
+            , dpHaddockHtml = Nothing
+            , dpIsExposed = True
+            }
+          actualPkgs = Map.keysSet (smaDeps smActual) <>
+                       Map.keysSet (smaProject smActual)
+          prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }
+      targets <- parseTargets NeedTargets False boptsCLI prunedActual
+      sourceMap <- loadSourceMap targets boptsCLI smActual
+      let dc = DotConfig
+                  { dcBuildConfig = bconfig
+                  , dcSourceMap = sourceMap
+                  , dcGlobalDump = toList $ smaGlobal smActual
+                  }
+      runRIO dc inner
+
+    withReal = withEnvConfig NeedTargets boptsCLI $ do
+      envConfig <- ask
+      let sourceMap = envConfigSourceMap envConfig
+      installMap <- toInstallMap sourceMap
+      (_, globalDump, _, _) <- getInstalled installMap
+      let dc = DotConfig
+            { dcBuildConfig = envConfigBuildConfig envConfig
+            , dcSourceMap = sourceMap
+            , dcGlobalDump = globalDump
+            }
+      runRIO dc inner
+
+    boptsCLI = defaultBuildOptsCLI
+        { boptsCLITargets = dotTargets opts
+        , boptsCLIFlags = dotFlags opts
+        }
+    modifyGO =
+        (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) .
+        (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id)
+
+data DotConfig = DotConfig
+  { dcBuildConfig :: !BuildConfig
+  , dcSourceMap :: !SourceMap
+  , dcGlobalDump :: ![DumpPackage]
+  }
+instance HasLogFunc DotConfig where
+  logFuncL = runnerL.logFuncL
+instance HasPantryConfig DotConfig where
+  pantryConfigL = configL.pantryConfigL
+instance HasTerm DotConfig where
+  useColorL = runnerL.useColorL
+  termWidthL = runnerL.termWidthL
+instance HasStylesUpdate DotConfig where
+  stylesUpdateL = runnerL.stylesUpdateL
+instance HasGHCVariant DotConfig
+instance HasPlatform DotConfig
+instance HasRunner DotConfig where
+  runnerL = configL.runnerL
+instance HasProcessContext DotConfig where
+  processContextL = runnerL.processContextL
+instance HasConfig DotConfig
+instance HasBuildConfig DotConfig where
+  buildConfigL = lens dcBuildConfig (\x y -> x { dcBuildConfig = y })
+instance HasSourceMap DotConfig where
+  sourceMapL = lens dcSourceMap (\x y -> x { dcSourceMap = y })