feat: add ScopeAnyExeQualifier

Author: andreabedini

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

@@ -60,6 +60,9 @@ data ConstraintQualifier
      -- | The package with the specified name when it has a
      -- setup qualifier.
    | ScopeAnySetupQualifier PackageName
+     -- | The package with the specified name when it has a
+     -- setup qualifier.
+   | ScopeAnyExeQualifier PackageName
      -- | The package with the specified name regardless of
      -- qualifier.
    | ScopeAnyQualifier PackageName
@@ -76,22 +79,25 @@ scopeToPackageName :: ConstraintScope -> PackageName
 scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn
 scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn
 scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeAnyExeQualifier pn)) = pn
 scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn
 
 constraintScopeMatches :: ConstraintScope -> QPN -> Bool
 constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') =
   maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn'
 
 constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool
-constraintQualifierMatches (ScopeTarget pn) q pn' =
-    q == QualToplevel && pn == pn'
-constraintQualifierMatches (ScopeQualified q pn) q' pn' =
-    q == q' && pn == pn'
-constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' =
-  pn == pn'
-constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' =
-    pn == pn'
-constraintQualifierMatches _ _ _ = False
+constraintQualifierMatches (ScopeTarget pn) QualToplevel pn' = pn == pn'
+constraintQualifierMatches (ScopeTarget _) (QualSetup _) _ = False
+constraintQualifierMatches (ScopeTarget _) (QualExe _ _) _ = False
+constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn'
+constraintQualifierMatches (ScopeAnySetupQualifier _) QualToplevel _ = False
+constraintQualifierMatches (ScopeAnySetupQualifier _) (QualExe _ _) _ = False
+constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn == pn'
+constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn'
+constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False
+constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False
+constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn'
 
 instance Pretty ConstraintScope where
   pretty (ConstraintScope mstage qualifier) =
@@ -101,6 +107,7 @@ instance Pretty ConstraintQualifier where
   pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
   pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
   pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn
+  pretty (ScopeAnyExeQualifier pn) = Disp.text "exe." <<>> pretty pn
   pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn
 
 -- | A package property is a logical predicate on packages.

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

@@ -627,6 +627,8 @@ data UserConstraintQualifier
     UserQualified UserQualifier PackageName
   | -- | Scope that applies to the package when it has a setup qualifier.
     UserAnySetupQualifier PackageName
+  | -- | Scope that applies to the package when it has a setup qualifier.
+    UserAnyExeQualifier PackageName
   | -- | Scope that applies to the package when it has any qualifier.
     UserAnyQualifier PackageName
   deriving (Eq, Show, Generic)
@@ -644,6 +646,8 @@ fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) =
   ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn)
 fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) =
   ConstraintScope mstage (ScopeAnySetupQualifier pn)
+fromUserConstraintScope (UserConstraintScope mstage (UserAnyExeQualifier pn)) =
+  ConstraintScope mstage (ScopeAnyExeQualifier pn)
 fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) =
   ConstraintScope mstage (ScopeAnyQualifier pn)
 
@@ -668,6 +672,7 @@ userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier
     scopePN (UserQualified _ pn) = pn
     scopePN (UserAnyQualifier pn) = pn
     scopePN (UserAnySetupQualifier pn) = pn
+    scopePN (UserAnyExeQualifier pn) = pn
 
 userToPackageConstraint :: UserConstraint -> PackageConstraint
 userToPackageConstraint (UserConstraintX scope prop) =
@@ -718,6 +723,7 @@ instance Parsec UserConstraint where
           withDot pn
             | pn == mkPackageName "any" = UserAnyQualifier <$> parsec
             | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
+            | pn == mkPackageName "exe" = UserAnyExeQualifier <$> parsec
             | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
 
           withColon :: PackageName -> m UserConstraintQualifier
@@ -732,17 +738,29 @@ instance Parsec UserConstraint where
 -- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint
 -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4]))))
 --
+-- >>> eitherParsec "any.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "setup.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "exe.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyExeQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
 -- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint
 -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
 --
--- >>> eitherParsec "setup.any source" :: Either String UserConstraint
--- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertySource)
---
+-- >>> eitherParsec "foo:exe:bar.abc > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "abc"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+----
 -- >>> eitherParsec "build:rts source" :: Either String UserConstraint
 -- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource)
 --
--- >>> eitherParsec "setup.any installed" :: Either String UserConstraint
--- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertyInstalled)
--- 
--- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint
--- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled)
+-- >>> eitherParsec "build:any.rts source" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserAnyQualifier (PackageName "rts"))) PackagePropertySource)
+--
+-- >>> eitherParsec "setup.ghc-internal installed" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "ghc-internal"))) PackagePropertyInstalled)
+--
+-- >>> eitherParsec "setup.ghc-internal installed" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "ghc-internal"))) PackagePropertyInstalled)