diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index e6d99c8281..750949ee99 100644 --- a/src/Stack/Dot.hs +++ b/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) diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index decc508148..f17bc2da42 100644 --- a/src/Stack/Ls.hs +++ b/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 = diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index ba541cb290..beef5e114b 100644 --- a/src/Stack/Runners.hs +++ b/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,8 +108,8 @@ 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) @@ -119,23 +117,23 @@ withDefaultEnvConfig 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) diff --git a/src/main/Main.hs b/src/main/Main.hs index aa0dffa462..c02468358b 100644 --- a/src/main/Main.hs +++ b/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