Merge pull request #4884 from grayjay/issue-4781

Solver: Enforce dependencies on executables (fixes #4781).
haskell · Nov 22, 2017 · 272151f · 272151f
2 parents 95cd4eb + e11131a
commit 272151f
Show file tree

Hide file tree

Showing 15 changed files with 582 additions and 306 deletions.
diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs
@@ -172,7 +172,7 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr
 -- and furthermore we update the set of goals.
 --
 -- TODO: We could inline this above.
-addChildren bs@(BS { next = Instance qpn (PInfo fdeps fdefs _) }) =
+addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) =
   addChildren ((scopedExtendOpen qpn fdeps fdefs bs)
          { next = Goals })
 

diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs
@@ -16,8 +16,6 @@ module Distribution.Solver.Modular.Dependency (
   , FlaggedDep(..)
   , LDep(..)
   , Dep(..)
-  , IsExe(..)
-  , showDep
   , DependencyReason(..)
   , showDependencyReason
   , flattenFlaggedDeps
@@ -41,8 +39,6 @@ import Distribution.Client.Compat.Prelude hiding (pi)
 
 import Language.Haskell.Extension (Extension(..), Language(..))
 
-import Distribution.Text
-
 import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)
 import Distribution.Solver.Modular.Flag
 import Distribution.Solver.Modular.Package
@@ -52,6 +48,7 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 import Distribution.Solver.Types.ComponentDeps (Component(..))
 import Distribution.Solver.Types.PackagePath
+import Distribution.Types.UnqualComponentName
 
 {-------------------------------------------------------------------------------
   Constrained instances
@@ -102,27 +99,22 @@ flattenFlaggedDeps = concatMap aux
 type TrueFlaggedDeps  qpn = FlaggedDeps qpn
 type FalseFlaggedDeps qpn = FlaggedDeps qpn
 
--- | Is this dependency on an executable
-newtype IsExe = IsExe Bool
-  deriving (Eq, Show)
-
 -- | A 'Dep' labeled with the reason it was introduced.
 --
 -- 'LDep' intentionally has no 'Functor' instance because the type variable
 -- is used both to record the dependencies as well as who's doing the
 -- depending; having a 'Functor' instance makes bugs where we don't distinguish
 -- these two far too likely. (By rights 'LDep' ought to have two type variables.)
 data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
-  deriving (Eq, Show)
 
 -- | A dependency (constraint) associates a package name with a constrained
 -- instance. It can also represent other types of dependencies, such as
 -- dependencies on language extensions.
-data Dep qpn = Dep  IsExe qpn CI       -- ^ dependency on a package (possibly for executable)
-             | Ext  Extension          -- ^ dependency on a language extension
-             | Lang Language           -- ^ dependency on a language version
-             | Pkg  PkgconfigName VR   -- ^ dependency on a pkg-config package
-  deriving (Functor, Eq, Show)
+data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI  -- ^ dependency on a package (possibly for executable)
+             | Ext  Extension                          -- ^ dependency on a language extension
+             | Lang Language                           -- ^ dependency on a language version
+             | Pkg  PkgconfigName VR                   -- ^ dependency on a pkg-config package
+  deriving Functor
 
 -- | The reason that a dependency is active. It identifies the package and any
 -- flag and stanza choices that introduced the dependency. It contains
@@ -131,22 +123,6 @@ data Dep qpn = Dep  IsExe qpn CI       -- ^ dependency on a package (possibly fo
 data DependencyReason qpn = DependencyReason qpn [(Flag, FlagValue)] [Stanza]
   deriving (Functor, Eq, Show)
 
--- | Print a dependency.
-showDep :: LDep QPN -> String
-showDep (LDep dr (Dep (IsExe is_exe) qpn (Fixed i)       )) =
-  let DependencyReason qpn' _ _ = dr
-  in (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
-     showQPN qpn ++
-     (if is_exe then " (exe) " else "") ++ "==" ++ showI i
-showDep (LDep dr (Dep (IsExe is_exe) qpn (Constrained vr))) =
-  showDependencyReason dr ++ " => " ++ showQPN qpn ++
-  (if is_exe then " (exe) " else "") ++ showVR vr
-showDep (LDep _ (Ext ext))   = "requires " ++ display ext
-showDep (LDep _ (Lang lang)) = "requires " ++ display lang
-showDep (LDep _ (Pkg pn vr)) = "requires pkg-config package "
-                      ++ display pn ++ display vr
-                      ++ ", not found in the pkg-config database"
-
 -- | Print the reason that a dependency was introduced.
 showDependencyReason :: DependencyReason QPN -> String
 showDependencyReason (DependencyReason qpn flags stanzas) =
@@ -190,7 +166,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
     -- Suppose package B has a setup dependency on package A.
     -- This will be recorded as something like
     --
-    -- > LDep (DependencyReason "B") (Dep False "A" (Constrained AnyVersion))
+    -- > LDep (DependencyReason "B") (Dep Nothing "A" (Constrained AnyVersion))
     --
     -- Observe that when we qualify this dependency, we need to turn that
     -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier
@@ -202,13 +178,11 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
     goD (Ext  ext)    _    = Ext  ext
     goD (Lang lang)   _    = Lang lang
     goD (Pkg pkn vr)  _    = Pkg pkn vr
-    goD (Dep is_exe dep ci) comp
-      | isExeToBool is_exe = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) ci
-      | qBase  dep         = Dep is_exe (Q (PackagePath ns (QualBase  pn)) dep) ci
-      | qSetup comp        = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) ci
-      | otherwise          = Dep is_exe (Q (PackagePath ns inheritedQ) dep) ci
-
-    isExeToBool (IsExe b) = b
+    goD (Dep mExe dep ci) comp
+      | isJust mExe = Dep mExe (Q (PackagePath ns (QualExe   pn dep)) dep) ci
+      | qBase  dep  = Dep mExe (Q (PackagePath ns (QualBase  pn    )) dep) ci
+      | qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn    )) dep) ci
+      | otherwise   = Dep mExe (Q (PackagePath ns inheritedQ        ) dep) ci
 
     -- If P has a setup dependency on Q, and Q has a regular dependency on R, then
     -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup

diff --git a/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal-install/Distribution/Solver/Modular/Index.hs
@@ -13,19 +13,20 @@ import Distribution.Solver.Modular.Dependency
 import Distribution.Solver.Modular.Flag
 import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree
+import Distribution.Types.UnqualComponentName
 
 -- | An index contains information about package instances. This is a nested
 -- dictionary. Package names are mapped to instances, which in turn is mapped
 -- to info.
 type Index = Map PN (Map I PInfo)
 
 -- | Info associated with a package instance.
--- Currently, dependencies, flags and failure reasons.
+-- Currently, dependencies, executable names, flags and failure reasons.
 -- Packages that have a failure reason recorded for them are disabled
 -- globally, for reasons external to the solver. We currently use this
 -- for shadowing which essentially is a GHC limitation, and for
 -- installed packages that are broken.
-data PInfo = PInfo (FlaggedDeps PN) FlagInfo (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason)
 
 mkIndex :: [(PN, I, PInfo)] -> Index
 mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
@@ -39,7 +40,7 @@ defaultQualifyOptions idx = QO {
                               | -- Find all versions of base ..
                                 Just is <- [M.lookup base idx]
                                 -- .. which are installed ..
-                              , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is
+                              , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is
                                 -- .. and flatten all their dependencies ..
                               , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps
                               ]

diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs
@@ -70,8 +70,8 @@ convIPI' (ShadowPkgs sip) idx =
   where
 
     -- shadowing is recorded in the package info
-    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))
-    shadow x                                = x
+    shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed))
+    shadow x                                     = x
 
 -- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I.
 convId :: InstalledPackageInfo -> (PN, I)
@@ -84,8 +84,8 @@ convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
 convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)
 convIP idx ipi =
   case mapM (convIPId (DependencyReason pn [] []) comp idx) (IPI.depends ipi) of
-        Nothing  -> (pn, i, PInfo []  M.empty (Just Broken))
-        Just fds -> (pn, i, PInfo fds M.empty Nothing)
+        Nothing  -> (pn, i, PInfo [] [] M.empty (Just Broken))
+        Just fds -> (pn, i, PInfo fds [] M.empty Nothing)
  where
   (pn, i) = convId ipi
   -- 'sourceLibName' is unreliable, but for now we only really use this for
@@ -131,7 +131,7 @@ convIPId dr comp idx ipid =
   case SI.lookupUnitId idx ipid of
     Nothing  -> Nothing
     Just ipi -> let (pn, i) = convId ipi
-                in  Just (D.Simple (LDep dr (Dep (IsExe False) pn (Fixed i))) comp)
+                in  Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp)
                 -- NB: something we pick up from the
                 -- InstalledPackageIndex is NEVER an executable
 
@@ -192,7 +192,7 @@ convGPD os arch cinfo strfl solveExes pn
     addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn
     addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (s : ss)
   in
-    PInfo flagged_deps fds Nothing
+    PInfo flagged_deps (L.map fst exes) fds Nothing
 
 -- | Create a flagged dependency tree from a list @fds@ of flagged
 -- dependencies, using @f@ to form the tree node (@f@ will be
@@ -367,12 +367,11 @@ convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c
 
 -- | Convert a Cabal dependency on a library to a solver-specific dependency.
 convLibDep :: DependencyReason PN -> Dependency -> LDep PN
-convLibDep dr (Dependency pn vr) = LDep dr $ Dep (IsExe False) pn (Constrained vr)
+convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr)
 
--- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency.
--- TODO do something about the name of the exe component itself
+-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.
 convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN
-convExeDep dr (ExeDependency pn _ vr) = LDep dr $ Dep (IsExe True) pn (Constrained vr)
+convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr)
 
 -- | Convert setup dependencies
 convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN

diff --git a/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal-install/Distribution/Solver/Modular/Linking.hs
@@ -97,9 +97,9 @@ validateLinking index = (`runReader` initVS) . cata go
     goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
     goP qpn@(Q _pp pn) opt@(POption i _) r = do
       vs <- ask
-      let PInfo deps _ _ = vsIndex vs ! pn ! i
-          qdeps          = qualifyDeps (vsQualifyOptions vs) qpn deps
-          newSaved       = M.insert qpn qdeps (vsSaved vs)
+      let PInfo deps _ _ _ = vsIndex vs ! pn ! i
+          qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps
+          newSaved         = M.insert qpn qdeps (vsSaved vs)
       case execUpdateState (pickPOption qpn opt qdeps) vs of
         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
         Right vs'       -> local (const vs' { vsSaved = newSaved }) r
@@ -346,7 +346,7 @@ verifyLinkGroup lg =
       -- if a constructor is added to the datatype we won't notice it here
       Just i -> do
         vs <- get
-        let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i
+        let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i
             flags   = M.keys finfo
             stanzas = [TestStanzas, BenchStanzas]
         forM_ flags $ \fn -> do

diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs
@@ -14,10 +14,12 @@ import Distribution.Solver.Modular.Dependency
 import Distribution.Solver.Modular.Flag
 import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree
-         ( FailReason(..), POption(..) )
+         ( FailReason(..), POption(..), ConflictingDep(..) )
+import Distribution.Solver.Modular.Version
 import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
+import Distribution.Types.UnqualComponentName
 
 data Message =
     Enter           -- ^ increase indentation level
@@ -124,8 +126,13 @@ showGR UserGoal            = " (user goal)"
 showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"
 
 showFR :: ConflictSet -> FailReason -> String
-showFR _ InconsistentInitialConstraints   = " (inconsistent initial constraints)"
-showFR _ (Conflicting ds)                 = " (conflict: " ++ L.intercalate ", " (L.map showDep ds) ++ ")"
+showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ display ext ++ ")"
+showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ display lang ++ ")"
+showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)"
+showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
+showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
+showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")"
+showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)"
 showFR _ CannotInstall                    = " (only already installed instances can be used)"
 showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"
 showFR _ Shadowed                         = " (shadowed by another installed package with same version)"
@@ -148,3 +155,15 @@ showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE
 
 constraintSource :: ConstraintSource -> String
 constraintSource src = "constraint from " ++ showConstraintSource src
+
+showConflictingDep :: ConflictingDep -> String
+showConflictingDep (ConflictingDep dr mExe qpn ci) =
+  let DependencyReason qpn' _ _ = dr
+      exeStr = case mExe of
+                 Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
+                 Nothing  -> ""
+  in case ci of
+       Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
+                         showQPN qpn ++ exeStr ++ "==" ++ showI i
+       Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++
+                         exeStr ++ showVR vr
diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
 module Distribution.Solver.Modular.Tree
-    ( FailReason(..)
-    , POption(..)
+    ( POption(..)
     , Tree(..)
     , TreeF(..)
     , Weight
+    , FailReason(..)
+    , ConflictingDep(..)
     , ana
     , cata
     , inn
@@ -29,6 +30,8 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
 import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.Flag
 import Distribution.Solver.Types.PackagePath
+import Distribution.Types.UnqualComponentName
+import Language.Haskell.Extension (Extension, Language)
 
 type Weight = Double
 
@@ -92,8 +95,13 @@ data Tree d c =
 data POption = POption I (Maybe PackagePath)
   deriving (Eq, Show)
 
-data FailReason = InconsistentInitialConstraints
-                | Conflicting [LDep QPN]
+data FailReason = UnsupportedExtension Extension
+                | UnsupportedLanguage Language
+                | MissingPkgconfigPackage PkgconfigName VR
+                | NewPackageDoesNotMatchExistingConstraint ConflictingDep
+                | ConflictingConstraints ConflictingDep ConflictingDep
+                | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN)
+                | PackageRequiresMissingExe QPN UnqualComponentName
                 | CannotInstall
                 | CannotReinstall
                 | Shadowed
@@ -112,6 +120,10 @@ data FailReason = InconsistentInitialConstraints
                 | CyclicDependencies
   deriving (Eq, Show)
 
+-- | Information about a dependency involved in a conflict, for error messages.
+data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI
+  deriving (Eq, Show)
+
 -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'
 -- have the same meaning as in 'Tree'.
 data TreeF d c a =