merge queue: embarking 3.16 (06b79de) and [#11225 + #11251] together

Cabal-tests/Cabal-tests.cabal

@@ -155,7 +155,7 @@ test-suite hackage-tests
     , base-orphans          >=0.6      && <0.10
     , clock                 >=0.8      && <0.9
     , optparse-applicative  >=0.13.2.0 && <0.19
-    , tar                   >=0.5.0.3  && <0.7
+    , tar                   >=0.5.0.3  && <0.8
     , tree-diff             >=0.1      && <0.4
 
   ghc-options:        -Wall -rtsopts -threaded

cabal-install/cabal-install.cabal

@@ -250,7 +250,7 @@ library
       , process    >= 1.2.3.0  && < 1.7
       , random     >= 1.2      && < 1.4
       , stm        >= 2.0      && < 2.6
-      , tar        >= 0.5.0.3  && < 0.7
+      , tar        >= 0.5.0.3  && < 0.8
       , time       >= 1.5.0.1  && < 1.16
       , zlib       >= 0.5.3    && < 0.8
       , hackage-security >= 0.6.2.0 && < 0.7

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)
@@ -184,6 +185,7 @@ import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag)
 import Distribution.Simple.Program.Builtin (ghcProgram)
 import Distribution.Simple.Program.Db (requireProgram)
 import Distribution.Simple.Program.Types
+import Distribution.Types.PackageName.Magic (fakePackageId)
 import System.Directory
   ( doesFileExist
   , getCurrentDirectory
@@ -195,6 +197,7 @@ import System.FilePath
   , splitSearchPath
   , (</>)
   )
+import Text.PrettyPrint hiding ((<>))
 
 replCommand :: CommandUI (NixStyleFlags ReplFlags)
 replCommand =
@@ -281,17 +284,30 @@ 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
@@ -302,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 $
@@ -317,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
@@ -360,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
@@ -384,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 +541,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 +560,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-install/src/Distribution/Client/Compat/Tar.hs

@@ -4,6 +4,7 @@
 {- FOURMOLU_DISABLE -}
 module Distribution.Client.Compat.Tar
   ( extractTarGzFile
+  , createTarGzFile
 #if MIN_VERSION_tar(0,6,0)
   , Tar.Entry
   , Tar.Entries
@@ -27,6 +28,7 @@ import qualified Codec.Archive.Tar.Check as Tar
 #else
 import qualified Codec.Archive.Tar.Entry as Tar
 #endif
+import qualified Codec.Compression.GZip as GZip
 import qualified Data.ByteString.Lazy as BS
 import qualified Distribution.Client.GZipUtils as GZipUtils
 
@@ -65,4 +67,20 @@ extractTarGzFile dir expected tar =
   . Tar.read
   . GZipUtils.maybeDecompress
   =<< BS.readFile tar
+
+createTarGzFile
+  :: FilePath
+  -- ^ Full Tarball path
+  -> FilePath
+  -- ^ Base directory
+  -> FilePath
+  -- ^ Directory to archive, relative to base dir
+  -> IO ()
+createTarGzFile tar base dir =
+#if MIN_VERSION_tar(0,7,0)
+  BS.writeFile tar . GZip.compress =<< Tar.write' =<< Tar.pack' base [dir]
+#else
+  BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]
+#endif
+
 {- FOURMOLU_ENABLE -}

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

@@ -17,7 +17,7 @@
 -- Reading, writing and manipulating \"@.tar@\" archive files.
 module Distribution.Client.Tar
   ( -- * @tar.gz@ operations
-    createTarGzFile
+    TarComp.createTarGzFile
   , TarComp.extractTarGzFile
 
     -- * Other local utils
@@ -34,8 +34,6 @@ import Prelude ()
 
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
-import qualified Codec.Compression.GZip as GZip
-import qualified Data.ByteString.Lazy as BS
 import qualified Distribution.Client.Compat.Tar as TarComp
 
 -- for foldEntries...
@@ -45,19 +43,6 @@ import Control.Exception (throw)
 
 -- * High level operations
 
---
-
-createTarGzFile
-  :: FilePath
-  -- ^ Full Tarball path
-  -> FilePath
-  -- ^ Base directory
-  -> FilePath
-  -- ^ Directory to archive, relative to base dir
-  -> IO ()
-createTarGzFile tar base dir =
-  BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]
-
 -- | Type code for the local build tree reference entry type. We don't use the
 -- symbolic link entry type because it allows only 100 ASCII characters for the
 -- path.

cabal-testsuite/PackageTests/ReplDashB/File.hs

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

cabal-testsuite/PackageTests/ReplDashB/cabal.out

@@ -0,0 +1,8 @@
+# cabal clean
+# cabal v2-repl
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - fake-package-0 (interactive) (lib) (first run)
+Configuring library for fake-package-0...
+Warning: No exposed modules

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

@@ -0,0 +1,8 @@
+import Test.Cabal.Prelude
+
+main = do
+  cabalTest $ do
+    cabal' "clean" []
+    res <- cabalWithStdin "v2-repl" ["-b", "containers"] ":m +Data.Map\n:t fromList"
+    assertOutputContains "fromList :: Ord k => [(k, a)] -> Map k a" 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,5 @@
+# cabal clean
+# cabal v2-repl
+Error: [Cabal-7076]
+Please pick a single [package:][ctype:]component (or all) as target for the REPL command. The packages in 'alt.project' from which to select a component target are:
+ - alt

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

@@ -0,0 +1,5 @@
+# cabal clean
+# cabal v2-repl
+Error: [Cabal-7076]
+Please pick a single [package:][ctype:]component (or all) as target for the REPL command. The packages in 'alt.project' from which to select a component target are:
+ - alt