From c79c8e3e536ede3a872456e03426654ab857a8c9 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sat, 2 Mar 2024 23:51:37 +0000 Subject: [PATCH] Fix #2530 Handle --package values as intended --- ChangeLog.md | 4 +++ doc/ghc_command.md | 10 ++++--- doc/maintainers/stack_errors.md | 3 +- doc/runghc_command.md | 10 ++++--- src/Stack/Exec.hs | 52 ++++++++++++++++++++++++++++----- src/Stack/Options/ExecParser.hs | 5 ++-- 6 files changed, 65 insertions(+), 19 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index b437b056ac..4a54b9bf72 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -37,6 +37,10 @@ Bug fixes: presence of a synoymous key. * On Windows, package locations that are Git repositories with submodules now work as intended. +* The `ghc`, `runghc` and `runhaskell` commands accept `--package` values that + are a list of package names or package identifiers separated by spaces and, in + the case of package identifiers, in the same way as if they were specified as + targets to `stack build`. ## v2.15.1 - 2024-02-09 diff --git a/doc/ghc_command.md b/doc/ghc_command.md index 8cd9c8ed61..9ede8d4c8b 100644 --- a/doc/ghc_command.md +++ b/doc/ghc_command.md @@ -12,8 +12,10 @@ stack ghc [-- ARGUMENT(S) (e.g. stack ghc -- X.hs -o x)] [`stack exec ghc`](exec_command.md), with the exception of the `--package` option. -Pass the option `--package ` to add the initial GHC argument +Pass the option `--package ` to add the initial GHC argument `-package-id=`, where `` is the unit ID of the specified -package in the installed package database. The option can be specified multiple -times. The approach taken to these packages is the same as if they were -specified as targets to [`stack build`](build_command.md#target-syntax). +package in the installed package database. The option can be a list of package +names or package identifiers separated by spaces. The option can also be +specified multiple times. The approach taken to these packages is the same as if +they were specified as targets to +[`stack build`](build_command.md#target-syntax). diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 434b63536e..094039bbdb 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -5,7 +5,7 @@ In connection with considering Stack's support of the [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks to take stock of the errors that Stack itself can raise, by reference to the -`master` branch of the Stack repository. Last updated: 2024-01-29. +`master` branch of the Stack repository. Last updated: 2024-03-02. * `Stack.main`: catches exceptions from action `commandLineHandler`. @@ -133,6 +133,7 @@ to take stock of the errors that Stack itself can raise, by reference to the [S-8251] = PackageIdNotFoundBug String [S-2483] | ExecutableToRunNotFound [S-8600] | NoPackageIdReportedBug + [S-7371] | InvalidExecTargets [Text] ~~~ - `Stack.GhcPkg` diff --git a/doc/runghc_command.md b/doc/runghc_command.md index e1c44cb654..55023f070e 100644 --- a/doc/runghc_command.md +++ b/doc/runghc_command.md @@ -13,8 +13,10 @@ same effect as, and is provided as a shorthand for, [`stack exec runghc`](exec_command.md), with the exception of the `--package` option. -Pass the option `--package ` to add the initial GHC argument +Pass the option `--package ` to add the initial GHC argument `-package-id=`, where `` is the unit ID of the specified -package in the installed package database. The option can be specified multiple -times. The approach taken to these packages is the same as if they were -specified as targets to [`stack build`](build_command.md#target-syntax). +package in the installed package database. The option can be a list of package +names or package identifiers separated by spaces. The option can also be +specified multiple times. The approach taken to these packages is the same as if +they were specified as targets to +[`stack build`](build_command.md#target-syntax). diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 3d20bc26a0..4f2c7a1171 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -15,13 +15,14 @@ import qualified Data.List as L import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T +import Distribution.Types.PackageName ( unPackageName ) import RIO.NonEmpty ( head, nonEmpty ) import RIO.Process ( exec ) import Stack.Build ( build ) -import Stack.Build.Target ( NeedTargets (..) ) +import Stack.Build.Target + ( NeedTargets (..), RawTarget (..), parseRawTarget ) import Stack.GhcPkg ( findGhcPkgField ) import Stack.Setup ( withNewLocalBuildTargets ) -import Stack.Types.NamedComponent ( NamedComponent (..), isCExe ) import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig ) import Stack.Types.BuildConfig @@ -33,6 +34,7 @@ import Stack.Types.CompilerPaths import Stack.Types.Config ( Config (..), HasConfig (..) ) import Stack.Types.EnvConfig ( EnvConfig ) import Stack.Types.EnvSettings ( EnvSettings (..) ) +import Stack.Types.NamedComponent ( NamedComponent (..), isCExe ) import Stack.Types.Runner ( Runner ) import Stack.Types.SourceMap ( SMWanted (..), ppComponents ) import System.Directory ( withCurrentDirectory ) @@ -58,6 +60,7 @@ data ExecPrettyException = PackageIdNotFoundBug !String | ExecutableToRunNotFound | NoPackageIdReportedBug + | InvalidExecTargets ![Text] deriving (Show, Typeable) instance Pretty ExecPrettyException where @@ -72,6 +75,20 @@ instance Pretty ExecPrettyException where <> flow "No executables found." pretty NoPackageIdReportedBug = bugPrettyReport "S-8600" $ flow "execCmd: findGhcPkgField returned Just \"\"." + pretty (InvalidExecTargets targets) = + "[S-7371]" + <> line + <> fillSep + [ flow "The following are invalid" + , style Shell "--package" + , "values for" + , style Shell (flow "stack ghc") <> "," + , style Shell (flow "stack runghc") <> "," + , "or" + , style Shell (flow "stack runhaskell") <> ":" + ] + <> line + <> bulletedList (map (style Target . string . T.unpack) targets ) instance Exception ExecPrettyException @@ -99,12 +116,17 @@ data ExecOpts = ExecOpts } deriving Show +-- Type representing valid targets for --package option. +data ExecTarget = ExecTarget PackageName (Maybe Version) + -- | The function underlying Stack's @exec@, @ghc@, @run@, @runghc@ and -- @runhaskell@ commands. Execute a command. execCmd :: ExecOpts -> RIO Runner () execCmd opts = withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do - unless (null targets) $ build Nothing + let (errs, execTargets) = partitionEithers $ map fromTarget targets + unless (null errs) $ prettyThrowM $ InvalidExecTargets errs + unless (null execTargets) $ build Nothing config <- view configL menv <- liftIO $ config.processContextSettings eo.envSettings @@ -116,18 +138,32 @@ execCmd opts = (cmd, args) <- case (opts.cmd, argsWithRts opts.args) of (ExecCmd cmd, args) -> pure (cmd, args) (ExecRun, args) -> getRunCmd args - (ExecGhc, args) -> getGhcCmd eo.packages args - (ExecRunGhc, args) -> getRunGhcCmd eo.packages args + (ExecGhc, args) -> getGhcCmd execTargets args + (ExecRunGhc, args) -> getRunGhcCmd execTargets args runWithPath eo.cwd $ exec cmd args where eo = opts.extra - targets = concatMap words eo.packages - boptsCLI = defaultBuildOptsCLI { targetsCLI = map T.pack targets } + targets = concatMap (T.words . T.pack) eo.packages + boptsCLI = defaultBuildOptsCLI { targetsCLI = targets } + + fromTarget :: Text -> Either Text ExecTarget + fromTarget target = + case parseRawTarget target >>= toExecTarget of + Nothing -> Left target + Just execTarget -> Right execTarget + + toExecTarget :: RawTarget -> Maybe ExecTarget + toExecTarget (RTPackageComponent _ _) = Nothing + toExecTarget (RTComponent _) = Nothing + toExecTarget (RTPackage name) = Just $ ExecTarget name Nothing + toExecTarget (RTPackageIdentifier (PackageIdentifier name pkgId)) = + Just $ ExecTarget name (Just pkgId) -- return the package-id of the first package in GHC_PACKAGE_PATH - getPkgId name = do + getPkgId (ExecTarget pkgName _) = do + let name = unPackageName pkgName pkg <- getGhcPkgExe mId <- findGhcPkgField pkg [] name "id" case mId of diff --git a/src/Stack/Options/ExecParser.hs b/src/Stack/Options/ExecParser.hs index 551c32eff8..143b6a1509 100644 --- a/src/Stack/Options/ExecParser.hs +++ b/src/Stack/Options/ExecParser.hs @@ -67,8 +67,9 @@ execOptsExtraParser = ExecOptsExtra eoPackagesParser :: Parser [String] eoPackagesParser = many (strOption ( long "package" - <> metavar "PACKAGE" - <> help "Add a package (can be specified multiple times)." + <> metavar "PACKAGE(S)" + <> help "Add package(s) as a list of names or identifiers separated by \ + \spaces (can be specified multiple times)." )) eoRtsOptionsParser :: Parser [String]