Add --global-hints flag for dot and ls dependencies

This flag allows us to bypass the need for an installation of GHC for
these commands, at the cost of not getting completely accurate
information on packages that ship with GHC.

* Fixes #4390
* Closes #4405

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
@@ -37,10 +39,11 @@ 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(..))
+import           Stack.Build.Target(NeedTargets(..), parseTargets)
 
 -- | Options record for @stack dot@
 data DotOpts = DotOpts
@@ -60,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
@@ -94,7 +99,7 @@ createPrunedDependencyGraph :: DotOpts
                             -> RIO Runner
                                  (Set PackageName,
                                   Map PackageName (Set PackageName, DotPayload))
-createPrunedDependencyGraph dotOpts = withConfig $ withEnvConfigDot dotOpts $ do
+createPrunedDependencyGraph dotOpts = withConfig $ withDotConfig dotOpts $ do
   localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted)
   resultGraph <- createDependencyGraph dotOpts
   let pkgsToPrune = if dotIncludeBase dotOpts
@@ -109,13 +114,12 @@ createPrunedDependencyGraph dotOpts = withConfig $ withEnvConfigDot dotOpts $ do
 -- @resolveDependencies@.
 createDependencyGraph
   :: DotOpts
-  -> RIO EnvConfig (Map PackageName (Set PackageName, DotPayload))
+  -> 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
@@ -249,9 +253,9 @@ createDepLoader :: SourceMap
                 -> Map PackageName DumpPackage
                 -> Map GhcPkgId PackageIdentifier
                 -> (PackageName -> Version -> PackageLocationImmutable ->
-                    Map FlagName Bool -> [Text] -> RIO EnvConfig (Set PackageName, DotPayload))
+                    Map FlagName Bool -> [Text] -> RIO DotConfig (Set PackageName, DotPayload))
                 -> PackageName
-                -> RIO EnvConfig (Set PackageName, DotPayload)
+                -> RIO DotConfig (Set PackageName, DotPayload)
 createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do
   fromMaybe noDepsErr
     (projectPackageDeps <|> dependencyDeps <|> globalDeps)
@@ -374,18 +378,95 @@ localPackageToPackage lp =
   fromMaybe (lpPackage lp) (lpTestBench lp)
 
 -- Plumbing for --test and --bench flags
-withEnvConfigDot
+withDotConfig
     :: DotOpts
-    -> RIO EnvConfig a
+    -> RIO DotConfig a
     -> RIO Config a
-withEnvConfigDot opts f =
+withDotConfig opts inner =
   local (over globalOptsL modifyGO) $
-  withEnvConfig NeedTargets boptsCLI f
+    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 })

src/Stack/Options/DotParser.hs

@@ -24,6 +24,7 @@ dotOptsParser externalDefault =
           <*> flagsParser
           <*> testTargets
           <*> benchTargets
+          <*> globalHints
   where includeExternal = boolFlags externalDefault
                                     "external"
                                     "inclusion of external dependencies"
@@ -52,6 +53,9 @@ dotOptsParser externalDefault =
         splitNames :: String -> [String]
         splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","
 
+        globalHints = switch (long "global-hints" <>
+                              help "Do not require an install GHC; instead, use a hints file for global packages")
+
 -- | Parser for arguments to `stack list-dependencies`.
 listDepsOptsParser :: Parser ListDepsOpts
 listDepsOptsParser = ListDepsOpts

src/Stack/Package.hs

@@ -77,7 +77,7 @@ import qualified RIO.PrettyPrint as PP (Style (Module))
 
 data Ctx = Ctx { ctxFile :: !(Path Abs File)
                , ctxDistDir :: !(Path Abs Dir)
-               , ctxEnvConfig :: !EnvConfig
+               , ctxBuildConfig :: !BuildConfig
                }
 
 instance HasPlatform Ctx
@@ -96,9 +96,14 @@ instance HasPantryConfig Ctx where
     pantryConfigL = configL.pantryConfigL
 instance HasProcessContext Ctx where
     processContextL = configL.processContextL
-instance HasBuildConfig Ctx
+instance HasBuildConfig Ctx where
+    buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = y })
+    {-
+instance HasSourceMap Ctx where
+    sourceMapL = envConfigL.sourceMapL
 instance HasEnvConfig Ctx where
     envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y })
+    -}
 
 -- | Read @<package>.buildinfo@ ancillary files produced by some Setup.hs hooks.
 -- The file includes Cabal file syntax to be merged into the package description
@@ -213,10 +218,10 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg
         \cabalfp -> debugBracket ("getPackageFiles" <+> pretty cabalfp) $ do
              let pkgDir = parent cabalfp
              distDir <- distDirFromDir pkgDir
-             env <- view envConfigL
+             bc <- view buildConfigL
              (componentModules,componentFiles,dataFiles',warnings) <-
                  runRIO
-                     (Ctx cabalfp distDir env)
+                     (Ctx cabalfp distDir bc)
                      (packageDescModulesAndFiles pkg)
              setupFiles <-
                  if buildType pkg == Custom

src/Stack/SourceMap.hs

@@ -14,6 +14,7 @@ module Stack.SourceMap
     , checkFlagsUsedThrowing
     , globalCondCheck
     , pruneGlobals
+    , globalsFromHints
     ) where
 
 import qualified Data.Conduit.List as CL