From c811c33e9e072a3b087453d2bb27a40f1e8c04f4 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 | 2 + doc/path_command.md | 6 +- src/Stack/Options/PathParser.hs | 11 +- src/Stack/Path.hs | 234 ++++++++++++++++++++------------ 4 files changed, 163 insertions(+), 90 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index a6d56c42d0..f8a42d87eb 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -13,6 +13,8 @@ Behavior changes: * Stack uses the version of the Cabal package that comes with the specified version of GHC. Stack no longer supports such Cabal versions before 2.2, which came with versions of GHC before 8.4. +* `stack path --global-config`, `--programs`, and `--local-bin` no longer set + up Stack's environment. Other enhancements: diff --git a/doc/path_command.md b/doc/path_command.md index b70b675a38..27276e4b8a 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'.