cabal-install: stage-qualified package configuration (package build:*)

Cabal-described/src/Distribution/Described.hs

@@ -101,7 +101,7 @@ import Distribution.Types.TestType                 (TestType)
 import Distribution.Types.UnitId                   (UnitId)
 import Distribution.Types.UnqualComponentName      (UnqualComponentName)
 import Distribution.Utils.Path                     (SymbolicPath, RelativePath, FileOrDir(..), Pkg, Build)
-import Distribution.Verbosity                      (Verbosity, VerbosityFlags)
+import Distribution.Verbosity                      (VerbosityFlags)
 import Distribution.Version                        (Version, VersionRange)
 import Language.Haskell.Extension                  (Extension, Language, knownLanguages)
 

Cabal-syntax/src/Distribution/Fields/Parser.hs

@@ -57,9 +57,6 @@ import qualified Data.Text.Encoding       as T
 import qualified Data.Text.Encoding.Error as T
 #endif
 
--- $setup
--- >>> import Data.Either (isLeft)
-
 -- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream'
 -- wrapped around lexer's 'LexState' (without a prime)
 data LexState' = LexState' !LexState (LToken, LexState')
@@ -135,8 +132,32 @@ tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing
 tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing
 
 colon, openBrace, closeBrace :: Parser ()
+
+-- | A single section argument.
+--
+-- Section arguments may contain colons, e.g. a stage qualifier such as
+-- @build:pkg@ or @build:*@ in a @package@ stanza. At this point we are already
+-- committed to parsing section arguments (the field-versus-section choice is
+-- decided by whether the first token after the section name is a colon), so a
+-- colon here can only join adjacent argument tokens. A colon in this position
+-- was previously a parse error, so this accepts strictly more input.
 sectionArg :: Parser (SectionArg Position)
-sectionArg = tokSym' <|> tokStr <|> tokOther <?> "section parameter"
+sectionArg = do
+  arg0 <- sectionArgAtom
+  rest <- many (try (colon *> sectionArgAtom))
+  pure (foldl joinSectionArgColon arg0 rest)
+  where
+    sectionArgAtom = tokSym' <|> tokStr <|> tokOther <?> "section parameter"
+
+-- | Join two section arguments with a colon, reconstructing e.g. @build:pkg@
+-- from the @build@, @:@ and @pkg@ tokens.
+joinSectionArgColon :: SectionArg Position -> SectionArg Position -> SectionArg Position
+joinSectionArgColon a b =
+  SecArgOther (sectionArgAnn a) (sectionArgBytes a <> ":" <> sectionArgBytes b)
+  where
+    sectionArgBytes (SecArgName _ s) = s
+    sectionArgBytes (SecArgStr _ s) = s
+    sectionArgBytes (SecArgOther _ s) = s
 
 fieldSecName :: Parser (Name Position)
 fieldSecName = tokSym <?> "field or section name"
@@ -350,13 +371,14 @@ fieldInlineOrBraces name =
 --
 -- 'readFields' won't (necessarily) fail on invalid UTF8 data, but the reported positions may be off.
 --
--- __You may get weird errors on non-UTF8 input__, for example 'readFields' will fail on latin1 encoded non-breaking space:
+-- __You may get weird results on non-UTF8 input__, for example 'readFields'
+-- treats a latin1 encoded non-breaking space as a section name:
 --
--- >>> isLeft (readFields "\xa0 foo: bar")
--- True
+-- >>> readFields "\xa0 foo: bar"
+-- Right [Section (Name (Position 1 1) "\160") [SecArgOther (Position 1 3) "foo:bar"] []]
 --
--- That is rejected because parser thinks @\\xa0@ is a section name,
--- and section arguments may not contain colon.
+-- The parser thinks @\\xa0@ is a section name and @foo: bar@ a single
+-- (colon-joined) section argument.
 -- If there are just latin1 non-breaking spaces, they become part of the name:
 --
 -- >>> readFields "\xa0\&foo: bar"

cabal-install-solver/src/Distribution/Solver/Modular.hs

@@ -75,7 +75,7 @@ import Distribution.Simple.Setup
          ( BooleanFlag(..) )
 import Distribution.Simple.Utils
     ( ordNubBy )
-import Distribution.Verbosity ( VerbosityLevel (..), normal, verbose )
+import Distribution.Verbosity ( VerbosityLevel (..) )
 
 -- | Ties the two worlds together: classic cabal-install vs. the modular
 -- solver. Performs the necessary translations before and after.

cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs

@@ -261,7 +261,7 @@ alreadyLinked = error "addLinking called on tree that already contains linked no
 -- | Interface to the tree builder. Just takes an index and a list of package names,
 -- and computes the initial state and then the tree from there.
 buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason
-buildTree idx (IndependentGoals ind) igs =
+buildTree idx (IndependentGoals _ind) igs =
     build Linker {
         buildState = BS {
             index = idx

cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs

@@ -274,8 +274,7 @@ linkDeps target = \deps -> do
       (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()
 
     requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
-    requalify deps = do
-      vs <- get
+    requalify deps =
       return $ qualifyDeps target (unqualifyDeps deps)
 
 pickFlag :: QFN -> Bool -> UpdateState ()

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -34,7 +34,7 @@ import Distribution.Solver.Modular.Flag
 import Distribution.Solver.Modular.MessageUtils
     ( showUnsupportedExtension, showUnsupportedLanguage )
 import Distribution.Solver.Modular.Package
-    ( showI )
+    ( PI(PI), showI, showPI )
 import Distribution.Solver.Modular.Tree
     ( FailReason(..), POption(..), ConflictingDep(..) )
 import Distribution.Solver.Modular.Version
@@ -262,7 +262,7 @@ data MergedPackageConflict = MergedPackageConflict {
 showOption :: QPN -> POption -> String
 showOption qpn@(Q _pp pn) (POption i linkedTo) =
   case linkedTo of
-    Nothing  -> showQPN qpn ++ " == " ++ showI i
+    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption
     Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn
 
 -- | Shows a mixed list of instances and versions in a human-friendly way,

cabal-install-solver/src/Distribution/Solver/Modular/Package.hs

@@ -26,7 +26,7 @@ import Distribution.Pretty (prettyShow)
 
 import Distribution.Solver.Modular.Version
 import Distribution.Solver.Types.PackagePath
-import Distribution.Solver.Types.Stage (Stage, showStage)
+import Distribution.Solver.Types.Stage (Stage)
 
 -- | A package name.
 type PN = PackageName
@@ -57,9 +57,17 @@ data I = I Stage Ver Loc
   deriving (Eq, Ord, Show)
 
 -- | String representation of an instance.
+-- The stage is not shown here; it is carried by the qualified package name
+-- (see the 'Pretty' instance for 'Distribution.Solver.Types.PackagePath.QPN'),
+-- so an instance renders the same regardless of stage.
 showI :: I -> String
-showI (I s v (InRepo pn)) = intercalate ":" [showStage s, "source", prettyShow (PackageIdentifier pn v)]
-showI (I s _v (Inst uid)) = intercalate ":" [showStage s, "installed", prettyShow uid]
+showI (I _s v (InRepo _pn)) = showVer v
+showI (I _s v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid
+  where
+    extractPackageAbiHash xs =
+      case first reverse $ break (== '-') $ reverse (prettyShow xs) of
+        (ys, []) -> ys
+        (ys, _) -> '-' : ys
 
 -- | Package instance. A package name and an instance.
 data PI qpn = PI qpn I

cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs

@@ -201,7 +201,6 @@ validate = go
       svd            <- asks saved -- obtain saved dependencies
       aComps         <- asks availableComponents
       rComps         <- asks requiredComponents
-      qo             <- asks qualifyOptions
       -- obtain dependencies and index-dictated exclusions introduced by the choice
       let I stage _vr _loc = i
       let (PInfo deps comps _ mfr) = idx ! pn ! i

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

@@ -94,6 +94,10 @@ constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn ==
 constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn'
 constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False
 constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False
+-- A base-qualified dependency is never matched by a toplevel/setup/exe scope.
+constraintQualifierMatches (ScopeTarget _) (QualBase _) _ = False
+constraintQualifierMatches (ScopeAnySetupQualifier _) (QualBase _) _ = False
+constraintQualifierMatches (ScopeAnyExeQualifier _) (QualBase _) _ = False
 constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn'
 
 instance Pretty ConstraintScope where

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

@@ -15,7 +15,7 @@ import Prelude ()
 import Distribution.Package (PackageName)
 import Distribution.Pretty (pretty, flatStyle, Pretty)
 import qualified Text.PrettyPrint as Disp
-import Distribution.Solver.Types.Stage (Stage)
+import Distribution.Solver.Types.Stage (Stage (..))
 
 data PackagePath = PackagePath Stage Qualifier
   deriving (Eq, Ord, Show, Generic)
@@ -25,7 +25,16 @@ instance Structured PackagePath
 
 instance Pretty PackagePath where
   pretty (PackagePath stage qualifier) =
-    pretty stage <<>> Disp.text ":" <<>> pretty qualifier
+    dispStage stage <<>> pretty qualifier
+
+-- | Pretty-prints a build stage as a prefix. The result is either empty (for
+-- the default 'Host' stage) or ends in a colon, so it can be prepended onto a
+-- qualifier or package name. Keeping the 'Host' stage invisible means logs for
+-- ordinary (non-cross) builds, where every package is on the 'Host' stage,
+-- stay free of stage noise; only the 'Build' stage is called out explicitly.
+dispStage :: Stage -> Disp.Doc
+dispStage Host = Disp.empty
+dispStage Build = pretty Build <<>> Disp.colon
 
 -- | Qualifier of a package within a namespace (see 'PackagePath')
 data Qualifier =
@@ -64,6 +73,7 @@ instance Structured Qualifier
 
 instance Pretty Qualifier where
   pretty QualToplevel = Disp.text "toplevel"
+  pretty (QualBase pn) = pretty pn <<>> Disp.text ":base"
   pretty (QualSetup pn) = pretty pn <<>> Disp.text ":setup"
   pretty (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>
                             pretty pn2 <<>> Disp.text ":exe"
@@ -78,6 +88,7 @@ instance Pretty Qualifier where
 -- 'Base' qualifier, will always be @base@).
 dispQualifier :: Qualifier -> Disp.Doc
 dispQualifier QualToplevel = mempty
+dispQualifier (QualBase pn) = pretty pn <> Disp.text "."
 dispQualifier (QualSetup pn) = pretty pn <> Disp.text ":setup."
 dispQualifier (QualExe pn pn2) =
   pretty pn
@@ -97,7 +108,7 @@ type QPN = Qualified PackageName
 
 instance Pretty (Qualified PackageName) where
   pretty (Q (PackagePath stage qual) pn) =
-    pretty stage <<>> Disp.colon <<>> dispQualifier qual <<>> pretty pn
+    dispStage stage <<>> dispQualifier qual <<>> pretty pn
 
 -- | Pretty-prints a qualified package name.
 dispQPN :: QPN -> Disp.Doc

cabal-install/parser-tests/Tests/ParserTests.hs

@@ -48,6 +48,7 @@ import Distribution.Solver.Types.Settings
   , ReorderGoals (..)
   , StrongFlags (..)
   )
+import Distribution.Solver.Types.Stage (Stage (..))
 import Distribution.System (OS (..), buildOS)
 import Distribution.Types.CondTree (CondTree (..))
 import Distribution.Types.Flag (mkFlagAssignment)
@@ -84,6 +85,7 @@ parserTests =
     , testCase "read project-config-local-packages" testProjectConfigLocalPackages
     , testCase "read project-config-all-packages" testProjectConfigAllPackages
     , testCase "read project-config-specific-packages" testProjectConfigSpecificPackages
+    , testCase "read project-config-stage-packages" testProjectConfigStagePackages
     , testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat
     , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat
     , testCase "test program-locations concatenation" testProgramLocationsConcat
@@ -438,6 +440,42 @@ testProjectConfigSpecificPackages = do
         { packageConfigSharedLib = Flag True
         }
 
+testProjectConfigStagePackages :: Assertion
+testProjectConfigStagePackages = do
+  -- The legacy parser does not support stage-qualified package stanzas (it
+  -- would reject the @build:*@ argument), so we read with the parsec parser
+  -- only rather than 'readConfigDefault', which also runs the legacy parser.
+  config <- readConfigParsec "project-config-stage-packages"
+  assertEqual
+    "Parsed Config does not match expected"
+    expected
+    (projectConfigStagePackages (snd (condTreeData config)))
+  -- An unqualified 'package *' stanza is not stage-qualified: it lands in
+  -- 'projectConfigAllPackages' (which applies to every stage) rather than in
+  -- the stage map.
+  assertEqual
+    "Unqualified 'package *' should apply to all packages, not a single stage"
+    expectedAll
+    (projectConfigAllPackages (snd (condTreeData config)))
+  where
+    expected = MapMappend $ Map.fromList [(Build, expectedBuild), (Host, expectedHost)]
+    expectedAll :: PackageConfig
+    expectedAll =
+      mempty
+        { packageConfigStaticLib = Flag True
+        }
+    expectedBuild :: PackageConfig
+    expectedBuild =
+      mempty
+        { packageConfigSharedLib = Flag False
+        , packageConfigDynExe = Flag False
+        }
+    expectedHost :: PackageConfig
+    expectedHost =
+      mempty
+        { packageConfigSharedLib = Flag True
+        }
+
 testAllPackagesConcat :: Assertion
 testAllPackagesConcat = do
   (config, legacy) <- readConfigDefault "all-packages-concat"
@@ -566,6 +604,18 @@ verbosity = mkVerbosity defaultVerbosityHandles normal
 readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)
 readConfigDefault testSubDir = readConfig testSubDir "cabal.project"
 
+-- | Read a project config using the parsec parser only. Useful for syntax the
+-- legacy parser does not support (e.g. stage-qualified package stanzas).
+readConfigParsec :: FilePath -> IO ProjectConfigSkeleton
+readConfigParsec testSubDir = do
+  (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir "cabal.project"
+  exists <- liftIO $ doesFileExist projectConfigFp
+  assertBool ("projectConfig does not exist: " <> projectConfigFp) exists
+  httpTransport <- liftIO $ configureTransport verbosity [] Nothing
+  liftIO $
+    runRebuild testRootFp $
+      readProjectFileSkeletonParsec verbosity httpTransport distDirLayout "" ""
+
 readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)
 readConfig testSubDir projectFileName = do
   (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName

cabal-install/parser-tests/Tests/files/project-config-stage-packages/cabal.project

@@ -0,0 +1,9 @@
+package *
+    static: True
+
+package build:*
+    shared: False
+    executable-dynamic: False
+
+package host:*
+    shared: True

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

@@ -26,8 +26,7 @@ import Distribution.Compat.Lens
 import qualified Distribution.Types.Lens as L
 
 import Distribution.Client.CmdErrorMessages
-  ( ComponentKind (..)
-  , Plural (..)
+  ( Plural (..)
   , componentKind
   , renderComponentKind
   , renderListCommaAnd

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

@@ -139,8 +139,6 @@ import Distribution.Types.DependencySatisfaction
   )
 import Distribution.Verbosity
   ( VerbosityLevel (..)
-  , deafening
-  , normal
   )
 import Distribution.Version
 

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

@@ -37,8 +37,6 @@ import qualified Distribution.Simple.Setup as Cabal
 import Distribution.Simple.SetupHooks.Internal
 import qualified Distribution.Simple.Test as Cabal
 import Distribution.Simple.Utils
-import Distribution.Client.Toolchain (Toolchain (..))
-import Distribution.Solver.Types.Stage (Stage (..), getStage)
 import Distribution.System (Platform)
 import Distribution.Types.BuildType
 import Distribution.Types.ComponentRequestedSpec

cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs

@@ -88,7 +88,7 @@ import qualified Data.ByteString as BS
 import qualified Data.List.NonEmpty as NE
 
 import Control.Exception (Handler (..), SomeAsyncException, catches, onException)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist, removeFile)
+import System.Directory (canonicalizePath, createDirectoryIfMissing)
 import System.FilePath (takeDirectory, (</>))
 import System.IO (Handle, IOMode (AppendMode), withFile)
 import System.Semaphore (SemaphoreName (..))
@@ -492,7 +492,7 @@ buildAndInstallUnpackedPackage
           whenRebuild $ do
             noticeProgress ProgressBuilding
             timestamp <- beginUpdateFileMonitor
-            runBuild
+            _ <- runBuild
             -- Be sure to invalidate the cache if building throws an exception!
             -- If not, we'll abort execution with a stale recompilation cache.
             -- See ghc#24926 for an example of how this can go wrong.

cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs

@@ -44,8 +44,10 @@ projectConfigFieldGrammar source knownPrograms =
     <*> blurFieldGrammar L.projectConfigLocalPackages (packageConfigFieldGrammar knownPrograms)
     -- \^ PackageConfig to be applied to locally built packages, specified not inside a stanza
     <*> pure mempty
-  where
     -- \^ PackageConfig applied to explicitly named packages
+    <*> pure mempty
+    -- \^ PackageConfig applied to all packages of a given stage ('package build:*' etc.)
+  where
     provenance = Set.singleton (Explicit source)
 
 formatPackageVersionConstraints :: [PackageVersionConstraint] -> List CommaVCat (Identity PackageVersionConstraint) PackageVersionConstraint

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -644,6 +644,12 @@ convertLegacyProjectConfig
       , projectConfigAllPackages = configAllPackages
       , projectConfigLocalPackages = configLocalPackages
       , projectConfigSpecificPackage = fmap perPackage legacySpecificConfig
+      , -- The legacy parser has no stage-qualified ('package build:*' /
+        -- 'package host:*') stanzas. Its unqualified per-package configuration
+        -- flows into 'projectConfigAllPackages', 'projectConfigLocalPackages'
+        -- and 'projectConfigSpecificPackage', which apply to every stage (both
+        -- build and host); only the explicit stage map is empty here.
+        projectConfigStagePackages = mempty
       }
     where
       configAllPackages = convertLegacyPerPackageFlags g i h t b

cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs

@@ -60,6 +60,7 @@ import Distribution.Solver.Types.Settings
   , ReorderGoals (..)
   , StrongFlags (..)
   )
+import Distribution.Solver.Types.Stage (Stage)
 import Distribution.Types.PackageVersionConstraint
   ( PackageVersionConstraint
   )
@@ -109,6 +110,10 @@ projectConfigSpecificPackage :: Lens' ProjectConfig (MapMappend PackageName Pack
 projectConfigSpecificPackage f s = fmap (\x -> s{T.projectConfigSpecificPackage = x}) (f (T.projectConfigSpecificPackage s))
 {-# INLINEABLE projectConfigSpecificPackage #-}
 
+projectConfigStagePackages :: Lens' ProjectConfig (MapMappend Stage PackageConfig)
+projectConfigStagePackages f s = fmap (\x -> s{T.projectConfigStagePackages = x}) (f (T.projectConfigStagePackages s))
+{-# INLINEABLE projectConfigStagePackages #-}
+
 projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag VerbosityFlags)
 projectConfigVerbosity f s = fmap (\x -> s{T.projectConfigVerbosity = x}) (f (T.projectConfigVerbosity s))
 {-# INLINEABLE projectConfigVerbosity #-}