Merge pull request #6506 from commercialhaskell/fix2530

Fix #2530 Handle --package values as intended

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
 

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 <package>` to add the initial GHC argument
+Pass the option `--package <package(s)>` to add the initial GHC argument
 `-package-id=<unit_id>`, where `<unit_id>` 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).

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`

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 <package>` to add the initial GHC argument
+Pass the option `--package <package(s)>` to add the initial GHC argument
 `-package-id=<unit_id>`, where `<unit_id>` 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).

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

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]