Refactor to make it clearer where dot needs EnvConfig

This is towards addressing:

* #4390
* #4405

src/Stack/Dot.hs

@@ -34,11 +34,13 @@ 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.Config
 import           Stack.Types.GhcPkgId
 import           Stack.Types.SourceMap
+import           Stack.Build.Target(NeedTargets(..))
 
 -- | Options record for @stack dot@
 data DotOpts = DotOpts
@@ -72,7 +74,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 +90,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 $ withEnvConfigDot dotOpts $ do
   localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted)
   resultGraph <- createDependencyGraph dotOpts
   let pkgsToPrune = if dotIncludeBase dotOpts
@@ -106,9 +107,9 @@ 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 EnvConfig (Map PackageName (Set PackageName, DotPayload))
 createDependencyGraph dotOpts = do
   sourceMap <- view $ envConfigL.to envConfigSourceMap
   locals <- projectLocalPackages
@@ -129,9 +130,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 +245,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 EnvConfig (Set PackageName, DotPayload))
                 -> PackageName
-                -> RIO env (Set PackageName, DotPayload)
+                -> RIO EnvConfig (Set PackageName, DotPayload)
 createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do
   fromMaybe noDepsErr
     (projectPackageDeps <|> dependencyDeps <|> globalDeps)
@@ -372,3 +372,20 @@ isWiredIn = (`Set.member` wiredInPackages)
 localPackageToPackage :: LocalPackage -> Package
 localPackageToPackage lp =
   fromMaybe (lpPackage lp) (lpTestBench lp)
+
+-- Plumbing for --test and --bench flags
+withEnvConfigDot
+    :: DotOpts
+    -> RIO EnvConfig a
+    -> RIO Config a
+withEnvConfigDot opts f =
+  local (over globalOptsL modifyGO) $
+  withEnvConfig NeedTargets boptsCLI f
+  where
+    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)

src/Stack/Ls.hs

@@ -10,9 +10,6 @@ module Stack.Ls
   ) where
 
 import Control.Exception (Exception, throw)
-import Control.Monad.Catch (MonadThrow)
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Reader (MonadReader)
 import Control.Monad (when)
 import Data.Aeson
 import Data.Array.IArray ((//), elems)
@@ -34,7 +31,7 @@ import RIO.PrettyPrint.DefaultStyles (defaultStyles)
 import RIO.PrettyPrint.Types (StyleSpec)
 import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), stylesUpdateL)
 import Stack.Dot
-import Stack.Runners (withConfig, withDefaultEnvConfig, withEnvConfigDot)
+import Stack.Runners (withConfig, withDefaultEnvConfig)
 import Stack.Options.DotParser (listDepsOptsParser)
 import Stack.Types.Config
 import System.Console.ANSI.Codes (SGR (Reset), setSGRCode, sgrToCode)
@@ -226,11 +223,9 @@ displayLocalSnapshot term xs = renderData term (localSnaptoText xs)
 localSnaptoText :: [String] -> Text
 localSnaptoText xs = T.intercalate "\n" $ L.map T.pack xs
 
-handleLocal
-    :: (HasEnvConfig env)
-    => LsCmdOpts -> RIO env ()
+handleLocal :: LsCmdOpts -> RIO Runner ()
 handleLocal lsOpts = do
-    (instRoot :: Path Abs Dir) <- installationRootDeps
+    (instRoot :: Path Abs Dir) <- withConfig $ withDefaultEnvConfig installationRootDeps
     isStdoutTerminal <- view terminalL
     let snapRootDir = parent $ parent instRoot
     snapData' <- liftIO $ listDirectory $ toFilePath snapRootDir
@@ -251,8 +246,8 @@ handleLocal lsOpts = do
         LsStyles _ -> return ()
 
 handleRemote
-    :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
-    => LsCmdOpts -> m ()
+    :: HasRunner env
+    => LsCmdOpts -> RIO env ()
 handleRemote lsOpts = do
     req <- liftIO $ parseRequest urlInfo
     isStdoutTerminal <- view terminalL
@@ -278,23 +273,22 @@ handleRemote lsOpts = do
 
 lsCmd :: LsCmdOpts -> RIO Runner ()
 lsCmd lsOpts =
-    withConfig $
     case lsView lsOpts of
         LsSnapshot SnapshotOpts {..} ->
             case soptViewType of
-                Local -> withDefaultEnvConfig (handleLocal lsOpts)
-                Remote -> withDefaultEnvConfig (handleRemote lsOpts)
+                Local -> handleLocal lsOpts
+                Remote -> handleRemote lsOpts
         LsDependencies depOpts -> listDependenciesCmd False depOpts
-        LsStyles stylesOpts -> listStylesCmd stylesOpts
+        LsStyles stylesOpts -> withConfig $ listStylesCmd stylesOpts
 
 -- | List the dependencies
-listDependenciesCmd :: Bool -> ListDepsOpts -> RIO Config ()
+listDependenciesCmd :: Bool -> ListDepsOpts -> RIO Runner ()
 listDependenciesCmd deprecated opts = do
     when
         deprecated
         (logWarn
              "DEPRECATED: Use ls dependencies instead. Will be removed in next major version.")
-    withEnvConfigDot (listDepsDotOpts opts) $ listDependencies opts
+    listDependencies opts
 
 lsViewLocalCmd :: OA.Mod OA.CommandFields LsView
 lsViewLocalCmd =

src/Stack/Runners.hs

@@ -14,7 +14,6 @@ module Stack.Runners
     , withEnvConfig
     , withDefaultEnvConfig
     , withEnvConfigExt
-    , withEnvConfigDot
     , withConfig
     , loadCompilerVersion
     , withUserFileLock
@@ -38,7 +37,6 @@ import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
 import           System.Environment (getEnvironment)
 import           System.FileLock
 import           System.Terminal (getTerminalWidth)
-import           Stack.Dot
 
 -- FIXME it seems wrong that we call loadBuildConfig multiple times
 loadCompilerVersion :: RIO Config WantedCompiler
@@ -110,32 +108,32 @@ withGlobalConfigAndLock inner =
 -- For now the non-locking version just unlocks immediately.
 -- That is, there's still a serialization point.
 withDefaultEnvConfig
-    :: RIO EnvConfig ()
-    -> RIO Config ()
+    :: RIO EnvConfig a
+    -> RIO Config a
 withDefaultEnvConfig inner =
     withEnvConfigAndLock AllowNoTargets defaultBuildOptsCLI (\lk -> do munlockFile lk
                                                                        inner)
 
 withEnvConfig
     :: NeedTargets
     -> BuildOptsCLI
-    -> RIO EnvConfig ()
-    -> RIO Config ()
+    -> RIO EnvConfig a
+    -> RIO Config a
 withEnvConfig needTargets boptsCLI inner =
     withEnvConfigAndLock needTargets boptsCLI (\lk -> do munlockFile lk
                                                          inner)
 
 withDefaultEnvConfigAndLock
-    :: (Maybe FileLock -> RIO EnvConfig ())
-    -> RIO Config ()
+    :: (Maybe FileLock -> RIO EnvConfig a)
+    -> RIO Config a
 withDefaultEnvConfigAndLock inner =
     withEnvConfigExt AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing
 
 withEnvConfigAndLock
     :: NeedTargets
     -> BuildOptsCLI
-    -> (Maybe FileLock -> RIO EnvConfig ())
-    -> RIO Config ()
+    -> (Maybe FileLock -> RIO EnvConfig a)
+    -> RIO Config a
 withEnvConfigAndLock needTargets boptsCLI inner =
     withEnvConfigExt needTargets boptsCLI Nothing inner Nothing
 
@@ -263,20 +261,3 @@ withRunnerGlobal go inner = do
 munlockFile :: MonadIO m => Maybe FileLock -> m ()
 munlockFile Nothing = return ()
 munlockFile (Just lk) = liftIO $ unlockFile lk
-
--- Plumbing for --test and --bench flags
-withEnvConfigDot
-    :: DotOpts
-    -> RIO EnvConfig ()
-    -> RIO Config ()
-withEnvConfigDot opts f =
-  local (over globalOptsL modifyGO) $
-  withEnvConfig NeedTargets boptsCLI f
-  where
-    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)

src/main/Main.hs

@@ -338,7 +338,7 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions
             (sdistOptsParser False)
         addCommand' "dot"
                     "Visualize your project's dependency graph using Graphviz dot"
-                    dotCmd
+                    dot
                     (dotOptsParser False) -- Default for --external is False.
         addCommand' "ghc"
                     "Run ghc"
@@ -417,7 +417,7 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions
                     (cleanOptsParser Purge)
         addCommand' "list-dependencies"
                     "List the dependencies"
-                    (withConfig . listDependenciesCmd True)
+                    (listDependenciesCmd True)
                     listDepsOptsParser
         addCommand' "query"
                     "Query general build information (experimental)"
@@ -1027,10 +1027,6 @@ solverCmd fixStackYaml =
     withConfig $
     withDefaultEnvConfigAndLock (\_ -> solveExtraDeps fixStackYaml)
 
--- | Visualize dependencies
-dotCmd :: DotOpts -> RIO Runner ()
-dotCmd dotOpts = withConfig $ withEnvConfigDot dotOpts $ dot dotOpts
-
 -- | Query build information
 queryCmd :: [String] -> RIO Runner ()
 queryCmd selectors = withConfig $ withDefaultEnvConfig $ queryBuildInfo $ map T.pack selectors