Fix two issues when starting the repl

Issue 1: In 3.14 there was a poor error when starting a repl in a
project context without any targets. In 3.16, this error regressed, so
cabal just exited cleanly.
Issue 2: The repl was broken when started from a global context.

Issue 1 is fixed by checking to see if there are any user targets, and
issuing a proper error if there are none.

Issue 2 is fixed by specifying the correct fake target which is
constructed when starting the repl in the global context.

Both are reported in #11107 and fixed in this patch.

Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>

Author: philderbeast

cabal-install/src/Distribution/Client/CmdRepl.hs

@@ -106,7 +106,8 @@ import Distribution.Simple.Compiler
   )
 import Distribution.Simple.Program.GHC
 import Distribution.Simple.Setup
-  ( ReplOptions (..)
+  ( Flag
+  , ReplOptions (..)
   , commonSetupTempFileOptions
   )
 import Distribution.Simple.Utils
@@ -170,8 +171,8 @@ import Data.List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Distribution.Client.ProjectConfig
-  ( ProjectConfig (projectConfigShared)
-  , ProjectConfigShared (projectConfigConstraints, projectConfigMultiRepl)
+  ( ProjectConfig (..)
+  , ProjectConfigShared (..)
   )
 import Distribution.Client.ReplFlags
   ( EnvFlags (envIncludeTransitive, envPackages)
@@ -195,6 +196,8 @@ import System.FilePath
   , splitSearchPath
   , (</>)
   )
+import Text.PrettyPrint hiding ((<>))
+import Distribution.Types.PackageName.Magic ( fakePackageId )
 
 replCommand :: CommandUI (NixStyleFlags ReplFlags)
 replCommand =
@@ -281,17 +284,29 @@ multiReplDecision ctx compiler flags =
 -- For more details on how this works, see the module
 -- "Distribution.Client.ProjectOrchestration"
 replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO ()
-replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags =
-  withContextAndSelectors verbosity AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do
+replAction flags@NixStyleFlags{extraFlags = replFlags@ReplFlags{..}, configFlags} targetStrings globalFlags = do
+  withCtx verbosity targetStrings $ \targetCtx ctx userTargetSelectors -> do
     when (buildSettingOnlyDeps (buildSettings ctx)) $
       dieWithException verbosity ReplCommandDoesn'tSupport
     let projectRoot = distProjectRootDirectory $ distDirLayout ctx
         distDir = distDirectory $ distDirLayout ctx
 
-    baseCtx <- case targetCtx of
-      ProjectContext -> return ctx
+    -- After ther user selectors have been resolved, and it's decided what context
+    -- we're in, implement repl-specific behaviour.
+    (baseCtx, targetSelectors) <- case targetCtx of
+      -- If in the project context, and no selectors are provided
+      -- then produce an error.
+      ProjectContext -> do
+        let projectFile = projectConfigProjectFile . projectConfigShared $ projectConfig ctx
+        let pkgs = projectPackages $ projectConfig ctx
+        case userTargetSelectors of
+          [] -> dieWithException verbosity $
+                  RenderReplTargetProblem [render (reportProjectNoTarget projectFile pkgs)]
+          _  -> return (ctx, userTargetSelectors)
+      -- In the global context, construct a fake package which can be used to start
+      -- a repl with extra arguments if `-b` is given.
       GlobalContext -> do
-        unless (null targetStrings) $
+        unless (null userTargetSelectors) $
           dieWithException verbosity $
             ReplTakesNoArguments targetStrings
         let
@@ -303,12 +318,18 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
           library = emptyLibrary{libBuildInfo = lBuildInfo}
           lBuildInfo =
             emptyBuildInfo
-              { targetBuildDepends = [baseDep]
+              { targetBuildDepends = [baseDep] ++ envPackages replEnvFlags
               , defaultLanguage = Just Haskell2010
               }
           baseDep = Dependency "base" anyVersion mainLibSet
 
-        updateContextAndWriteProjectFile' ctx sourcePackage
+        -- Write the fake package
+        updatedCtx <- updateContextAndWriteProjectFile' ctx sourcePackage
+        -- Specify the selector for this package
+        let fakeSelector = TargetPackage TargetExplicitNamed [fakePackageId] Nothing
+        return (updatedCtx, [fakeSelector])
+
+      -- For the script context, no special behaviour.
       ScriptContext scriptPath scriptExecutable -> do
         unless (length targetStrings == 1) $
           dieWithException verbosity $
@@ -318,7 +339,8 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
           dieWithException verbosity $
             ReplTakesSingleArgument targetStrings
 
-        updateContextAndWriteProjectFile ctx scriptPath scriptExecutable
+        updatedCtx <- updateContextAndWriteProjectFile ctx scriptPath scriptExecutable
+        return (updatedCtx, userTargetSelectors)
 
     -- If multi-repl is used, we need a Cabal recent enough to handle it.
     -- We need to do this before solving, but the compiler version is only known
@@ -361,7 +383,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         -- especially in the no-project case.
         withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do
           -- targets should be non-empty map, but there's no NonEmptyMap yet.
-          targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors
+          targets <- validatedTargets' (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors
 
           let
             (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
@@ -385,7 +407,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         let ProjectBaseContext{..} = baseCtx''
 
         -- Recalculate with updated project.
-        targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors
+        targets <- validatedTargets' (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors
 
         let
           elaboratedPlan' =
@@ -518,31 +540,13 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s)
         go m _ = m
 
+    withCtx ctxVerbosity strings =
+      withContextAndSelectors ctxVerbosity AcceptNoTargets (Just LibKind) flags strings globalFlags ReplCommand
+
     verbosity = cfgVerbosity normal flags
     tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags
 
-    validatedTargets ctx compiler elaboratedPlan targetSelectors = do
-      let multi_repl_enabled = multiReplDecision ctx compiler r
-      -- Interpret the targets on the command line as repl targets
-      -- (as opposed to say build or haddock targets).
-      targets <-
-        either (reportTargetProblems verbosity) return $
-          resolveTargetsFromSolver
-            (selectPackageTargets multi_repl_enabled)
-            selectComponentTarget
-            elaboratedPlan
-            Nothing
-            targetSelectors
-
-      -- Reject multiple targets, or at least targets in different
-      -- components. It is ok to have two module/file targets in the
-      -- same component, but not two that live in different components.
-      when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $
-        reportTargetProblems
-          verbosity
-          [multipleTargetsProblem multi_repl_enabled targets]
-
-      return targets
+    validatedTargets' = validatedTargets verbosity replFlags
 
 -- | Create a constraint which requires a later version of Cabal.
 -- This is used for commands which require a specific feature from the Cabal library
@@ -555,6 +559,69 @@ requireCabal version source =
   , source
   )
 
+reportProjectNoTarget :: Flag FilePath -> [String] -> Doc
+reportProjectNoTarget projectFile pkgs =
+  case (null pkgs, projectName) of
+    (True, Just project) ->
+      text "There are no packages in"
+        <+> (project <> char '.')
+        <+> text "Please add a package to the project and"
+        <+> pickComponent
+    (True, Nothing) ->
+      text "Please add a package to the project and" <+> pickComponent
+    (False, Just project) ->
+      text "Please"
+        <+> pickComponent
+        <+> text "The packages in"
+        <+> project
+        <+> (text "from which to select a component target are" <> colon)
+        $+$ nest 1 (vcat [text "-" <+> text pkg | pkg <- sort pkgs])
+    (False, Nothing) ->
+      text "Please"
+        <+> pickComponent
+        <+> (text "The packages from which to select a component in 'cabal.project'" <> comma)
+        <+> (text "the implicit default as if `--project-file=cabal.project` was added as a command option" <> comma)
+        <+> (text "are" <> colon)
+        $+$ nest 1 (vcat [text "-" <+> text pkg | pkg <- sort pkgs])
+  where
+    projectName = case projectFile of
+      Flag "" -> Nothing
+      Flag n -> Just $ quotes (text n)
+      _ -> Nothing
+    pickComponent = text "pick a single [package:][ctype:]component (or all) as target for the REPL command."
+
+-- | Invariant: validatedTargets returns at least one target for the REPL.
+validatedTargets
+  :: Verbosity
+  -> ReplFlags
+  -> ProjectConfigShared
+  -> Compiler
+  -> ElaboratedInstallPlan
+  -> [TargetSelector]
+  -> IO TargetsMap
+validatedTargets verbosity replFlags ctx compiler elaboratedPlan targetSelectors = do
+  let multi_repl_enabled = multiReplDecision ctx compiler replFlags
+  -- Interpret the targets on the command line as repl targets (as opposed to
+  -- say build or haddock targets).
+  targets <-
+    either (reportTargetProblems verbosity) return $
+      resolveTargetsFromSolver
+        (selectPackageTargets multi_repl_enabled)
+        selectComponentTarget
+        elaboratedPlan
+        Nothing
+        targetSelectors
+
+  -- Reject multiple targets, or at least targets in different components. It is
+  -- ok to have two module/file targets in the same component, but not two that
+  -- live in different components.
+  when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $
+    reportTargetProblems
+      verbosity
+      [multipleTargetsProblem multi_repl_enabled targets]
+
+  return targets
+
 -- | First version of GHC which supports multiple home packages
 minMultipleHomeUnitsVersion :: Version
 minMultipleHomeUnitsVersion = mkVersion [9, 4]

cabal-testsuite/PackageTests/ReplDashB/File.hs

@@ -0,0 +1 @@
+module File where

cabal-testsuite/PackageTests/ReplDashB/cabal.test.hs

@@ -0,0 +1,8 @@
+import Test.Cabal.Prelude
+
+main = do
+  cabalTest' "repl -b option" $ do
+    cabal' "clean" []
+    res <- cabalWithStdin "v2-repl" ["-b", "containers"] ":set"
+    assertOutputContains "Ok, two modules loaded." res
+

cabal-testsuite/PackageTests/ReplOptions/alt.project

@@ -0,0 +1 @@
+packages: alt

cabal-testsuite/PackageTests/ReplOptions/alt/ModuleA.hs

@@ -0,0 +1,4 @@
+module ModuleA where
+
+a :: Int
+a = 42

cabal-testsuite/PackageTests/ReplOptions/alt/ModuleC.hs

@@ -0,0 +1,4 @@
+module ModuleC where
+
+c :: Int
+c = 42

cabal-testsuite/PackageTests/ReplOptions/alt/alt.cabal

@@ -0,0 +1,10 @@
+name: alt
+version: 0.1
+build-type: Simple
+cabal-version: >= 1.10
+
+library
+  exposed-modules: ModuleA, ModuleC
+  build-depends: base
+  default-language: Haskell2010
+

cabal-testsuite/PackageTests/ReplOptions/cabal.alt-multiple-repl-options.out

@@ -0,0 +1,12 @@
+# cabal clean
+# cabal v2-repl
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - alt-0.1 (interactive) (lib) (first run)
+Configuring library for alt-0.1...
+Preprocessing library for alt-0.1...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - alt-0.1 (lib) (configuration changed)
+Configuring library for alt-0.1...

cabal-testsuite/PackageTests/ReplOptions/cabal.alt-single-repl-options.out

@@ -0,0 +1,12 @@
+# cabal clean
+# cabal v2-repl
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - alt-0.1 (interactive) (lib) (first run)
+Configuring library for alt-0.1...
+Preprocessing library for alt-0.1...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - alt-0.1 (lib) (configuration changed)
+Configuring library for alt-0.1...

cabal-testsuite/PackageTests/ReplOptions/cabal.test.hs

@@ -1,29 +1,46 @@
 import Test.Cabal.Prelude
 
+singleOpts = ["--repl-options=-fwrite-interface"]
+multiOpts = "--repl-options=-fdefer-typed-holes" : singleOpts
+altProject = ("--project-file=alt.project" :)
+
 main = do
   cabalTest' "single-repl-options" $ do
     cabal' "clean" []
-    res <- cabalWithStdin "v2-repl" ["--repl-options=-fwrite-interface"] ":set"
+    res <- cabalWithStdin "v2-repl" singleOpts ":set"
     assertOutputContains "Ok, two modules loaded." res
-    assertOutputContains "  -fwrite-interface" res
+
+  cabalTest' "alt-single-repl-options" $ do
+    cabal' "clean" []
+    -- We can 'cabal repl' without a target when the project has a single package.
+    void $ cabalWithStdin "v2-repl" (altProject singleOpts) ":set"
+
   cabalTest' "multiple-repl-options" $ do
     cabal' "clean" []
-    res <- cabalWithStdin "v2-repl" ["--repl-options=-fwrite-interface", "--repl-options=-fdefer-typed-holes"] ":set"
+    res <- cabalWithStdin "v2-repl" multiOpts ":set"
     assertOutputContains "Ok, two modules loaded." res
     assertOutputContains "  -fwrite-interface" res
     assertOutputContains "  -fdefer-typed-holes" res
+
+  cabalTest' "alt-multiple-repl-options" $ do
+    cabal' "clean" []
+    -- We can 'cabal repl' without a target when the project has a single package.
+    void $ cabalWithStdin "v2-repl" (altProject multiOpts) ":set"
+
   cabalTest' "single-repl-options-multiple-flags" $ do
     cabal' "clean" []
     res <- cabalWithStdin "v2-repl" ["--repl-options=-fdefer-typed-holes -fwrite-interface"] ":set"
     assertOutputContains "Ok, two modules loaded." res
     assertOutputContains "  -fwrite-interface" res
     assertOutputContains "  -fdefer-typed-holes" res
+
   cabalTest' "single-repl-options-multiple-flags-negative" $ do
     cabal' "clean" []
     res <- fails $ cabalWithStdin "v2-repl" ["--repl-options=-fwrite-interface -fdiagnostics-show-baret"] ":set"
     assertOutputDoesNotContain "Ok, two modules loaded." res
     assertOutputContains "unrecognised flag: -fdiagnostics-show-baret" res
     assertOutputContains "did you mean one of:" res
+
   cabalTest' "multiple-repl-options-multiple-flags" $ do
     cabal' "clean" []
     res <- cabalWithStdin "v2-repl" [