NamedPackage + exceptions

cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs

@@ -6,7 +6,8 @@ module Distribution.Solver.Types.ConstraintSource
 
 import Distribution.Solver.Compat.Prelude
 import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath)
-import Text.PrettyPrint (render)
+import Distribution.Pretty (Pretty(pretty), prettyShow)
+import Text.PrettyPrint (text)
 
 -- | Source of a 'PackageConstraint'.
 data ConstraintSource =
@@ -55,31 +56,40 @@ data ConstraintSource =
   -- | An internal constraint due to compatibility issues with the Setup.hs
   -- command line interface requires a maximum upper bound on Cabal
   | ConstraintSetupCabalMaxVersion
+
+  -- | An implicit constraint added by Cabal.
+  | ConstraintSourceImplicit
   deriving (Show, Eq, Ord, Generic, Typeable)
 
 instance Binary ConstraintSource
 instance Structured ConstraintSource
 
 -- | Description of a 'ConstraintSource'.
 showConstraintSource :: ConstraintSource -> String
-showConstraintSource (ConstraintSourceMainConfig path) =
-    "main config " ++ path
-showConstraintSource (ConstraintSourceProjectConfig path) =
-    "project config " ++ render (docProjectConfigPath path)
-showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path
-showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"
-showConstraintSource ConstraintSourceUserTarget = "user target"
-showConstraintSource ConstraintSourceNonReinstallablePackage =
-    "non-reinstallable package"
-showConstraintSource ConstraintSourceFreeze = "cabal freeze"
-showConstraintSource ConstraintSourceConfigFlagOrTarget =
-    "config file, command line flag, or user target"
-showConstraintSource ConstraintSourceMultiRepl =
-    "--enable-multi-repl"
-showConstraintSource ConstraintSourceProfiledDynamic =
-    "--enable-profiling-shared"
-showConstraintSource ConstraintSourceUnknown = "unknown source"
-showConstraintSource ConstraintSetupCabalMinVersion =
-    "minimum version of Cabal used by Setup.hs"
-showConstraintSource ConstraintSetupCabalMaxVersion =
-    "maximum version of Cabal used by Setup.hs"
+showConstraintSource = prettyShow
+
+instance Pretty ConstraintSource where
+  pretty constraintSource = case constraintSource of
+    (ConstraintSourceMainConfig path) ->
+      text "main config" <+> text path
+    (ConstraintSourceProjectConfig path) ->
+      text "project config" <+> docProjectConfigPath path
+    (ConstraintSourceUserConfig path)-> text "user config " <+> text path
+    ConstraintSourceCommandlineFlag -> text "command line flag"
+    ConstraintSourceUserTarget -> text "user target"
+    ConstraintSourceNonReinstallablePackage ->
+      text "non-reinstallable package"
+    ConstraintSourceFreeze -> text "cabal freeze"
+    ConstraintSourceConfigFlagOrTarget ->
+      text "config file, command line flag, or user target"
+    ConstraintSourceMultiRepl ->
+      text "--enable-multi-repl"
+    ConstraintSourceProfiledDynamic ->
+      text "--enable-profiling-shared"
+    ConstraintSourceUnknown -> text "unknown source"
+    ConstraintSetupCabalMinVersion ->
+      text "minimum version of Cabal used by Setup.hs"
+    ConstraintSetupCabalMaxVersion ->
+      text "maximum version of Cabal used by Setup.hs"
+    ConstraintSourceImplicit ->
+      text "implicit target"

cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Distribution.Solver.Types.WithConstraintSource
   ( WithConstraintSource (..)

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

@@ -104,7 +104,6 @@ import Distribution.Client.Setup
   )
 import Distribution.Client.Types
   ( PackageLocation (..)
-  , PackageLocationProvenance (..)
   , PackageSpecifier (..)
   , SourcePackageDb (..)
   , UnresolvedSourcePackage
@@ -176,6 +175,9 @@ import Distribution.Simple.Utils
   , withTempDirectory
   , wrapText
   )
+import Distribution.Solver.Types.ConstraintSource
+  ( ConstraintSource (..)
+  )
 import Distribution.Solver.Types.PackageConstraint
   ( PackageProperty (..)
   )
@@ -186,6 +188,9 @@ import Distribution.Solver.Types.PackageIndex
 import Distribution.Solver.Types.SourcePackage
   ( SourcePackage (..)
   )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 import Distribution.System
   ( OS (Windows)
   , Platform
@@ -360,7 +365,23 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
   let
     installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
 
-    normalisedTargetStrings = if null targetStrings then ["."] else targetStrings
+    normalisedTargetStrings =
+      if null targetStrings
+        then
+          [ WithConstraintSource
+              { constraintPackage = "."
+              , constraintConstraint = ConstraintSourceImplicit
+              }
+          ]
+        else
+          map
+            ( \target ->
+                WithConstraintSource
+                  { constraintPackage = target
+                  , constraintConstraint = ConstraintSourceCommandlineFlag
+                  }
+            )
+            targetStrings
 
   -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris.
   -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where
@@ -470,7 +491,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
           distDirLayout
           (projectConfigShared config)
           (projectConfigBuildOnly config)
-          [ProjectPackageRemoteTarball uri | uri <- uris]
+          (map (fmap ProjectPackageRemoteTarball) uris)
 
     -- check for targets already in env
     let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
@@ -563,9 +584,9 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
 withProject
   :: Verbosity
   -> ProjectConfig
-  -> [String]
+  -> [WithConstraintSource String]
   -> Bool
-  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig)
+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource TargetSelector], ProjectConfig)
 withProject verbosity cliConfig targetStrings installLibs = do
   -- First, we need to learn about what's available to be installed.
   baseCtx <- establishProjectBaseContext reducedVerbosity cliConfig InstallCommand
@@ -598,29 +619,38 @@ withProject verbosity cliConfig targetStrings installLibs = do
     -- The ones who don't parse will have to be resolved in the project context.
     (unresolvedTargetStrings, parsedPackageIds) =
       partitionEithers $
-        flip map targetStrings $ \s ->
-          case eitherParsec s of
+        flip map targetStrings $ \target ->
+          case eitherParsec $ constraintPackage target of
             Right pkgId@PackageIdentifier{pkgVersion}
               | pkgVersion /= nullVersion ->
-                  pure pkgId
-            _ -> Left s
+                  pure $ target{constraintPackage = pkgId}
+            _ -> Left target
 
     -- For each packageId, we output a NamedPackage specifier (i.e. a package only known by
     -- its name) and a target selector.
     (parsedPkgSpecs, parsedTargets) =
       unzip
-        [ (mkNamedPackage pkgId, TargetPackageNamed (pkgName pkgId) targetFilter)
-        | pkgId <- parsedPackageIds
+        [ ( mkNamedPackage src pkgId
+          , withConstraint
+              { constraintPackage =
+                  TargetPackageNamed (pkgName pkgId) targetFilter
+              }
+          )
+        | withConstraint@WithConstraintSource
+            { constraintPackage = pkgId
+            , constraintConstraint = src
+            } <-
+            parsedPackageIds
         ]
 
     targetFilter = if installLibs then Just LibKind else Just ExeKind
 
 resolveTargetSelectorsInProjectBaseContext
   :: Verbosity
   -> ProjectBaseContext
-  -> [String]
+  -> [WithConstraintSource String]
   -> Maybe ComponentKindFilter
-  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource TargetSelector])
 resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targetFilter = do
   let reducedVerbosity = lessVerbose verbosity
 
@@ -648,10 +678,20 @@ resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targe
 withoutProject
   :: Verbosity
   -> ProjectConfig
-  -> [String]
-  -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
+  -> [WithConstraintSource String]
+  -> IO
+      ( [PackageSpecifier UnresolvedSourcePackage]
+      , [WithConstraintSource URI]
+      , [WithConstraintSource TargetSelector]
+      , ProjectConfig
+      )
 withoutProject verbosity globalConfig targetStrings = do
-  tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings
+  tss <-
+    traverse
+      ( sequenceA
+          . fmap (parseWithoutProjectTargetSelector verbosity)
+      )
+      targetStrings
   let
     ProjectConfigBuildOnly
       { projectConfigLogsDir
@@ -776,7 +816,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector
             spkg
               { srcpkgSource =
                   (srcpkgSource spkg)
-                    { packageLocation = LocalTarballPackage sdistPath
+                    { constraintPackage = LocalTarballPackage sdistPath
                     }
               }
       sdistize named = named
@@ -807,7 +847,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector
           TarGzArchive
           (distSdistFile distDirLayout (packageId pkg))
           pkg
-      NamedPackage _ _ ->
+      Named _ ->
         -- This may happen if 'extra-packages' are listed in the project file.
         -- We don't need to do extra work for NamedPackages since they will be
         -- fetched from Hackage rather than locally 'sdistize'-d. Note how,

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

@@ -121,6 +121,9 @@ import Distribution.Solver.Types.PackageConstraint
 import Distribution.Solver.Types.SourcePackage
   ( SourcePackage (..)
   )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 import Distribution.Types.BuildInfo
   ( BuildInfo (..)
   , emptyBuildInfo
@@ -538,11 +541,13 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
     -- but that would require another solver run for marginal advantages that
     -- will further shrink as 3.11 is adopted.
     multiReplCabalConstraint =
-      ( UserConstraint
-          (UserAnySetupQualifier (mkPackageName "Cabal"))
-          (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11])
-      , ConstraintSourceMultiRepl
-      )
+      WithConstraintSource
+        { constraintPackage =
+            UserConstraint
+              (UserAnySetupQualifier (mkPackageName "Cabal"))
+              (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11])
+        , constraintConstraint = ConstraintSourceMultiRepl
+        }
 
 -- | First version of GHC which supports multiple home packages
 minMultipleHomeUnitsVersion :: Version
@@ -866,6 +871,6 @@ lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared
 lProjectConfigShared f s = fmap (\x -> s{projectConfigShared = x}) (f (projectConfigShared s))
 {-# INLINE lProjectConfigShared #-}
 
-lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]
+lProjectConfigConstraints :: Lens' ProjectConfigShared [WithConstraintSource UserConstraint]
 lProjectConfigConstraints f s = fmap (\x -> s{projectConfigConstraints = x}) (f (projectConfigConstraints s))
 {-# INLINE lProjectConfigConstraints #-}

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

@@ -60,13 +60,15 @@ import Distribution.Client.TargetSelector
   )
 import Distribution.Client.Types
   ( PackageLocation (..)
-  , PackageLocationProvenance (..)
   , PackageSpecifier (..)
   , UnresolvedSourcePackage
   )
 import Distribution.Solver.Types.SourcePackage
   ( SourcePackage (..)
   )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 import Distribution.Utils.Path hiding
   ( (<.>)
   , (</>)
@@ -324,7 +326,7 @@ data OutputFormat
 packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
 packageToSdist verbosity projectRootDir format outputFile pkg = do
   let death = dieWithException verbosity $ ImpossibleHappened (show pkg)
-  dir0 <- case packageLocation $ srcpkgSource pkg of
+  dir0 <- case constraintPackage $ srcpkgSource pkg of
     LocalUnpackedPackage path -> pure (Right path)
     RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz)
     RemoteSourceRepoPackage{} -> death

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

@@ -67,9 +67,12 @@ import qualified System.Exit (exitSuccess)
 
 import Distribution.Client.Errors
 import Distribution.Client.Setup (CommonSetupFlags (..))
+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (ConstraintSourceCommandlineFlag))
+import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..))
 import GHC.Environment
   ( getFullArgs
   )
+import qualified Text.PrettyPrint as PP
 
 testCommand :: CommandUI (NixStyleFlags ())
 testCommand =
@@ -124,11 +127,21 @@ testCommand =
 -- "Distribution.Client.ProjectOrchestration"
 testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 testAction flags@NixStyleFlags{..} targetStrings globalFlags = do
+  let targetStrings' =
+        map
+          ( \target ->
+              WithConstraintSource
+                { constraintPackage = target
+                , constraintConstraint = ConstraintSourceCommandlineFlag
+                }
+          )
+          targetStrings
+
   baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
 
   targetSelectors <-
-    either (reportTargetSelectorProblems verbosity) return
-      =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings
+    either (reportTargetSelectorProblems verbosity . map constraintPackage) return
+      =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings'
 
   buildCtx <-
     runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
@@ -256,17 +269,22 @@ isSubComponentProblem pkgid name subcomponent =
   CustomTargetProblem $
     TargetProblemIsSubComponent pkgid name subcomponent
 
-reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a
+reportTargetProblems :: Verbosity -> Flag Bool -> [WithConstraintSource TestTargetProblem] -> IO a
 reportTargetProblems verbosity failWhenNoTestSuites problems =
   case (failWhenNoTestSuites, problems) of
-    (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) ->
-      dieWithException verbosity $ ReportTargetProblems problemsMessage
-    (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do
+    ( Flag True
+      , [ WithConstraintSource
+            { constraintPackage = CustomTargetProblem (TargetProblemNoTests _)
+            }
+          ]
+      ) ->
+        dieWithException verbosity $ ReportTargetProblems problemsMessage
+    (_, [WithConstraintSource{constraintPackage = CustomTargetProblem (TargetProblemNoTests selector)}]) -> do
       notice verbosity (renderAllowedNoTestsProblem selector)
       System.Exit.exitSuccess
     (_, _) -> dieWithException verbosity $ ReportTargetProblems problemsMessage
   where
-    problemsMessage = unlines . map renderTestTargetProblem $ problems
+    problemsMessage = unlines . map (prettyShow . fmap (PP.text . renderTestTargetProblem)) $ problems
 
 -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't
 --   @die@ when the target problem is 'TargetProblemNoTests'.