From 93a7bd8104310caaf89d2e84e6095c4dcf844447 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Thu, 15 Feb 2024 00:01:10 +0000 Subject: [PATCH] Fix #6484 stack path avoids EnvConfig where possible --- ChangeLog.md | 3 + doc/path_command.md | 6 +- src/Stack/Options/PathParser.hs | 11 +- src/Stack/Path.hs | 234 ++++++++++++++++++++------------ 4 files changed, 164 insertions(+), 90 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 4cd418bfdd..da1b62642d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -10,6 +10,9 @@ Major changes: Behavior changes: +* `stack path --global-config`, `--programs`, and `--local-bin` no longer set + up Stack's environment. + Other enhancements: Bug fixes: diff --git a/doc/path_command.md b/doc/path_command.md index 26a4f17df5..9f3528677d 100644 --- a/doc/path_command.md +++ b/doc/path_command.md @@ -3,9 +3,9 @@ # The `stack path` command ~~~text -stack path [--stack-root] [--global-config] [--project-root] [--config-location] - [--bin-path] [--programs] [--compiler-exe] [--compiler-bin] - [--compiler-tools-bin] [--local-bin] [--extra-include-dirs] +stack path [--stack-root] [--global-config] [--programs] [--local-bin] + [--project-root] [--config-location] [--bin-path] [--compiler-exe] + [--compiler-bin] [--compiler-tools-bin] [--extra-include-dirs] [--extra-library-dirs] [--snapshot-pkg-db] [--local-pkg-db] [--global-pkg-db] [--ghc-package-path] [--snapshot-install-root] [--local-install-root] [--snapshot-doc-root] [--local-doc-root] diff --git a/src/Stack/Options/PathParser.hs b/src/Stack/Options/PathParser.hs index 92d9c72467..f7a65d7bbc 100644 --- a/src/Stack/Options/PathParser.hs +++ b/src/Stack/Options/PathParser.hs @@ -7,15 +7,22 @@ module Stack.Options.PathParser import qualified Data.Text as T import Options.Applicative ( Parser, flag, help, long ) -import Stack.Path ( paths ) +import Stack.Path + ( pathsFromConfig, pathsFromEnvConfig, pathsFromRunner ) import Stack.Prelude -- | Parse command line arguments for Stack's @path@ command. pathParser :: Parser [Text] pathParser = mapMaybeA - ( \(desc, name, _) -> flag Nothing (Just name) + ( \(desc, name) -> flag Nothing (Just name) ( long (T.unpack name) <> help desc ) ) paths + where + toDescName (desc, name, _) = (desc, name) + paths = + pathsFromRunner + : map toDescName pathsFromConfig + <> map toDescName pathsFromEnvConfig diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index f8444765c2..8cfb77617e 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -6,9 +6,11 @@ -- | Types and functions related to Stack's @path@ command. module Stack.Path - ( PathInfo + ( EnvConfigPathInfo , path - , paths + , pathsFromRunner + , pathsFromConfig + , pathsFromEnvConfig ) where import Data.List ( intercalate ) @@ -35,8 +37,7 @@ import Stack.Types.BuildOptsMonoid ( buildOptsMonoidHaddockL ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..), getCompilerPath ) import Stack.Types.Config - ( Config (..), HasConfig (..), stackGlobalConfigL, stackRootL - ) + ( Config (..), HasConfig (..), stackGlobalConfigL ) import Stack.Types.EnvConfig ( EnvConfig, HasEnvConfig (..), bindirCompilerTools , hpcReportDir, installationRootDeps, installationRootLocal @@ -54,48 +55,79 @@ import qualified System.FilePath as FP -- | Print out useful path information in a human-readable format (and support -- others later). path :: [Text] -> RIO Runner () --- Distinguish a request for only the Stack root, as such a request does not --- require 'withDefaultEnvConfig'. -path [key] | key == stackRootOptionName' = do - clArgs <- view $ globalOptsL . to (.configMonoid) - liftIO $ do - (_, stackRoot, _) <- determineStackRootAndOwnership clArgs - T.putStrLn $ T.pack $ toFilePathNoTrailingSep stackRoot path keys = do let -- filter the chosen paths in flags (keys), or show all of them if no -- specific paths chosen. - goodPaths = filter - ( \(_, key, _) -> null keys || elem key keys ) - paths - singlePath = length goodPaths == 1 - toEither (_, k, UseHaddocks p) = Left (k, p) - toEither (_, k, WithoutHaddocks p) = Right (k, p) - (with, without) = partitionEithers $ map toEither goodPaths - runHaddock True $ printKeys with singlePath - runHaddock False $ printKeys without singlePath + filterKeys (_, key, _) = null keys || elem key keys + goodPathsFromRunner = null keys || elem stackRootOptionName' keys + goodPathsFromConfig = filter filterKeys pathsFromConfig + goodPathsFromEnvConfig = filter filterKeys pathsFromEnvConfig + toKeyPath (_, key, p) = (key, p) + goodPathsFromConfig' = map toKeyPath goodPathsFromConfig + singlePath = (if goodPathsFromRunner then 1 else 0) + + length goodPathsFromConfig + length goodPathsFromEnvConfig == 1 + toEither (_, k, UseHaddocks a) = Left (k, a) + toEither (_, k, WithoutHaddocks a) = Right (k, a) + (with, without) = partitionEithers $ map toEither goodPathsFromEnvConfig + when goodPathsFromRunner $ printKeysWithRunner singlePath + unless (null goodPathsFromConfig') $ + runHaddockWithConfig $ printKeysWithConfig goodPathsFromConfig' singlePath + unless (null without) $ + runHaddockWithEnvConfig False $ printKeysWithEnvConfig without singlePath + unless (null with) $ + runHaddockWithEnvConfig True $ printKeysWithEnvConfig with singlePath -printKeys :: +printKeysWithRunner :: + Bool + -> RIO Runner () +printKeysWithRunner single = do + clArgs <- view $ globalOptsL . to (.configMonoid) + liftIO $ do + (_, stackRoot, _) <- determineStackRootAndOwnership clArgs + let prefix = if single then "" else stackRootOptionName' <> ": " + T.putStrLn $ prefix <> T.pack (toFilePathNoTrailingSep stackRoot) + +printKeysWithConfig :: + HasConfig env + => [(Text, Config -> Text)] + -> Bool + -> RIO env () +printKeysWithConfig extractors single = + view configL >>= printKeys extractors single + +printKeysWithEnvConfig :: HasEnvConfig env - => [(Text, PathInfo -> Text)] + => [(Text, EnvConfigPathInfo -> Text)] -> Bool -> RIO env () -printKeys extractors single = do - pathInfo <- fillPathInfo +printKeysWithEnvConfig extractors single = + fillEnvConfigPathInfo >>= printKeys extractors single + +printKeys :: + [(Text, info -> Text)] + -> Bool + -> info + -> RIO env () +printKeys extractors single info = do liftIO $ forM_ extractors $ \(key, extractPath) -> do let prefix = if single then "" else key <> ": " - T.putStrLn $ prefix <> extractPath pathInfo + T.putStrLn $ prefix <> extractPath info + +runHaddockWithEnvConfig :: Bool -> RIO EnvConfig () -> RIO Runner () +runHaddockWithEnvConfig x action = runHaddock x (withDefaultEnvConfig action) + +runHaddockWithConfig :: RIO Config () -> RIO Runner () +runHaddockWithConfig = runHaddock False -runHaddock :: Bool -> RIO EnvConfig () -> RIO Runner () -runHaddock x action = local modifyConfig $ - withConfig YesReexec $ - withDefaultEnvConfig action +runHaddock :: Bool -> RIO Config () -> RIO Runner () +runHaddock x action = local modifyConfig $ withConfig YesReexec action where modifyConfig = set (globalOptsL . globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL) (Just x) -fillPathInfo :: HasEnvConfig env => RIO env PathInfo -fillPathInfo = do +fillEnvConfigPathInfo :: HasEnvConfig env => RIO env EnvConfigPathInfo +fillEnvConfigPathInfo = do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the -- full environment info including GHC paths etc. buildConfig <- view $ envConfigL . buildConfigL @@ -115,7 +147,7 @@ fillPathInfo = do distDir <- distRelativeDir hpcDir <- hpcReportDir compiler <- getCompilerPath - pure PathInfo + pure EnvConfigPathInfo { buildConfig , snapDb , localDb @@ -130,8 +162,7 @@ fillPathInfo = do , compiler } --- | Type representing information passed to all the path printers. -data PathInfo = PathInfo +data EnvConfigPathInfo = EnvConfigPathInfo { buildConfig :: !BuildConfig , snapDb :: !(Path Abs Dir) , localDb :: !(Path Abs Dir) @@ -146,40 +177,40 @@ data PathInfo = PathInfo , compiler :: !(Path Abs File) } -instance HasPlatform PathInfo where +instance HasPlatform EnvConfigPathInfo where platformL = configL . platformL {-# INLINE platformL #-} platformVariantL = configL . platformVariantL {-# INLINE platformVariantL #-} -instance HasLogFunc PathInfo where +instance HasLogFunc EnvConfigPathInfo where logFuncL = configL . logFuncL -instance HasRunner PathInfo where +instance HasRunner EnvConfigPathInfo where runnerL = configL . runnerL -instance HasStylesUpdate PathInfo where +instance HasStylesUpdate EnvConfigPathInfo where stylesUpdateL = runnerL . stylesUpdateL -instance HasTerm PathInfo where +instance HasTerm EnvConfigPathInfo where useColorL = runnerL . useColorL termWidthL = runnerL . termWidthL -instance HasGHCVariant PathInfo where +instance HasGHCVariant EnvConfigPathInfo where ghcVariantL = configL . ghcVariantL {-# INLINE ghcVariantL #-} -instance HasConfig PathInfo where +instance HasConfig EnvConfigPathInfo where configL = buildConfigL . lens (.config) (\x y -> x { config = y }) {-# INLINE configL #-} -instance HasPantryConfig PathInfo where +instance HasPantryConfig EnvConfigPathInfo where pantryConfigL = configL . pantryConfigL -instance HasProcessContext PathInfo where +instance HasProcessContext EnvConfigPathInfo where processContextL = configL . processContextL -instance HasBuildConfig PathInfo where +instance HasBuildConfig EnvConfigPathInfo where buildConfigL = lens (.buildConfig) (\x y -> x { buildConfig = y }) . buildConfigL @@ -187,68 +218,97 @@ data UseHaddocks a = UseHaddocks a | WithoutHaddocks a --- | The paths of interest to a user. The first tuple string is used for a --- description that the optparse flag uses, and the second string as a --- machine-readable key and also for @--foo@ flags. The user can choose a --- specific path to list like @--stack-root@. But really it's mainly for the --- documentation aspect. +-- | The paths of interest to a user which do require a 'Config' or 'EnvConfig'. +-- The first tuple string is used for a description that the optparse flag uses, +-- and the second string as a machine-readable key and also for @--foo@ flags. +-- The user can choose a specific path to list like @--stack-root@. But really +-- it's mainly for the documentation aspect. +pathsFromRunner :: (String, Text) +pathsFromRunner = ("Global Stack root directory", stackRootOptionName') + +-- | The paths of interest to a user which do require an 'EnvConfig'. The first +-- tuple string is used for a description that the optparse flag uses, and the +-- second string as a machine-readable key and also for @--foo@ flags. The user +-- can choose a specific path to list like @--stack-root@. But really it's +-- mainly for the documentation aspect. -- --- When printing output we generate @PathInfo@ and pass it to the function to --- generate an appropriate string. Trailing slashes are removed, see #506. -paths :: [(String, Text, UseHaddocks (PathInfo -> Text))] -paths = - [ ( "Global Stack root directory" - , stackRootOptionName' - , WithoutHaddocks $ - view (stackRootL . to toFilePathNoTrailingSep . to T.pack)) - , ( "Global Stack configuration file" +-- When printing output we generate @Config@ and pass it to the function +-- to generate an appropriate string. Trailing slashes are removed, see #506. +pathsFromConfig :: [(String, Text, Config -> Text)] +pathsFromConfig = + [ ( "Global Stack configuration file" , T.pack stackGlobalConfigOptionName - , WithoutHaddocks $ view (stackGlobalConfigL . to toFilePath . to T.pack)) - , ( "Project root (derived from stack.yaml file)" + , view (stackGlobalConfigL . to toFilePath . to T.pack) + ) + , ( "Install location for GHC and other core tools (see 'stack ls tools' command)" + , "programs" + , view (configL . to (.localPrograms) . to toFilePathNoTrailingSep . to T.pack) + ) + , ( "Directory where Stack installs executables (e.g. ~/.local/bin (Unix-like OSs) or %APPDATA%\\local\\bin (Windows))" + , "local-bin" + , view $ configL . to (.localBin) . to toFilePathNoTrailingSep . to T.pack + ) + ] + +-- | The paths of interest to a user which require a 'EnvConfig'. The first +-- tuple string is used for a description that the optparse flag uses, and the +-- second string as a machine-readable key and also for @--foo@ flags. The user +-- can choose a specific path to list like @--project-root@. But really it's +-- mainly for the documentation aspect. +-- +-- When printing output we generate @EnvConfigPathInfo@ and pass it to the +-- function to generate an appropriate string. Trailing slashes are removed, see +-- #506. +pathsFromEnvConfig :: [(String, Text, UseHaddocks (EnvConfigPathInfo -> Text))] +pathsFromEnvConfig = + [ ( "Project root (derived from stack.yaml file)" , "project-root" , WithoutHaddocks $ - view (projectRootL . to toFilePathNoTrailingSep . to T.pack)) + view (projectRootL . to toFilePathNoTrailingSep . to T.pack) + ) , ( "Configuration location (where the stack.yaml file is)" , "config-location" - , WithoutHaddocks $ view (stackYamlL . to toFilePath . to T.pack)) + , WithoutHaddocks $ view (stackYamlL . to toFilePath . to T.pack) + ) , ( "PATH environment variable" , "bin-path" , WithoutHaddocks $ - T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL) - , ( "Install location for GHC and other core tools (see 'stack ls tools' command)" - , "programs" - , WithoutHaddocks $ - view (configL . to (.localPrograms) . to toFilePathNoTrailingSep . to T.pack)) + T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL + ) , ( "Compiler binary (e.g. ghc)" , "compiler-exe" - , WithoutHaddocks $ T.pack . toFilePath . (.compiler) ) + , WithoutHaddocks $ T.pack . toFilePath . (.compiler) + ) , ( "Directory containing the compiler binary (e.g. ghc)" , "compiler-bin" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . (.compiler) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . (.compiler) + ) , ( "Directory containing binaries specific to a particular compiler" , "compiler-tools-bin" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.toolsDir) ) - , ( "Directory where Stack installs executables (e.g. ~/.local/bin (Unix-like OSs) or %APPDATA%\\local\\bin (Windows))" - , "local-bin" - , WithoutHaddocks $ - view $ configL . to (.localBin) . to toFilePathNoTrailingSep . to T.pack) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.toolsDir) + ) , ( "Extra include directories" , "extra-include-dirs" , WithoutHaddocks $ - T.intercalate ", " . map T.pack . (.extraIncludeDirs) . view configL ) + T.intercalate ", " . map T.pack . (.extraIncludeDirs) . view configL + ) , ( "Extra library directories" , "extra-library-dirs" , WithoutHaddocks $ - T.intercalate ", " . map T.pack . (.extraLibDirs) . view configL ) + T.intercalate ", " . map T.pack . (.extraLibDirs) . view configL + ) , ( "Snapshot package database" , "snapshot-pkg-db" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.snapDb) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.snapDb) + ) , ( "Local project package database" , "local-pkg-db" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.localDb) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.localDb) + ) , ( "Global package database" , "global-pkg-db" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.globalDb) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.globalDb) + ) , ( "GHC_PACKAGE_PATH environment variable" , "ghc-package-path" , WithoutHaddocks $ @@ -261,11 +321,12 @@ paths = ) , ( "Snapshot installation root" , "snapshot-install-root" - , WithoutHaddocks $ - T.pack . toFilePathNoTrailingSep . (.snapRoot) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.snapRoot) + ) , ( "Local project installation root" , "local-install-root" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.localRoot) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.localRoot) + ) , ( "Snapshot documentation root" , "snapshot-doc-root" , UseHaddocks $ @@ -278,13 +339,16 @@ paths = ) , ( "Local project documentation root" , "local-hoogle-root" - , UseHaddocks $ T.pack . toFilePathNoTrailingSep . (.hoogleRoot)) + , UseHaddocks $ T.pack . toFilePathNoTrailingSep . (.hoogleRoot) + ) , ( "Dist work directory, relative to package directory" , "dist-dir" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.distDir) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.distDir) + ) , ( "Where HPC reports and tix files are stored" , "local-hpc-root" - , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.hpcDir) ) + , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.hpcDir) + ) ] -- | 'Text' equivalent of 'stackRootOptionName'.