Solver: Store names of required executables for build-tool-depends dependencies.

This commit changes the field of type 'IsExe' in the 'Dep' data type to
type 'Maybe UnqualComponentName'.  It also adds the executable name to error
messages that previously just contained "(exe)".

Author: grayjay

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 })
 

cabal-install/Distribution/Solver/Modular/Dependency.hs

@@ -16,7 +16,6 @@ module Distribution.Solver.Modular.Dependency (
   , FlaggedDep(..)
   , LDep(..)
   , Dep(..)
-  , IsExe(..)
   , DependencyReason(..)
   , showDependencyReason
   , flattenFlaggedDeps
@@ -49,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
@@ -99,10 +99,6 @@ 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
@@ -114,10 +110,10 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
 -- | 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
+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
@@ -170,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
@@ -182,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

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
                               ]

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

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

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

@@ -19,6 +19,7 @@ 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
@@ -154,11 +155,13 @@ constraintSource :: ConstraintSource -> String
 constraintSource src = "constraint from " ++ showConstraintSource src
 
 showConflictingDep :: ConflictingDep -> String
-showConflictingDep (ConflictingDep dr (IsExe is_exe) qpn (Fixed i)       ) =
+showConflictingDep (ConflictingDep dr mExe qpn ci) =
   let DependencyReason qpn' _ _ = dr
-  in (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
-     showQPN qpn ++
-     (if is_exe then " (exe) " else "") ++ "==" ++ showI i
-showConflictingDep (ConflictingDep dr (IsExe is_exe) qpn (Constrained vr)) =
-  showDependencyReason dr ++ " => " ++ showQPN qpn ++
-  (if is_exe then " (exe) " else "") ++ showVR vr
+      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

cabal-install/Distribution/Solver/Modular/Tree.hs

@@ -30,6 +30,7 @@ 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
@@ -118,7 +119,7 @@ data FailReason = UnsupportedExtension Extension
   deriving (Eq, Show)
 
 -- | Information about a dependency involved in a conflict, for error messages.
-data ConflictingDep = ConflictingDep (DependencyReason QPN) IsExe QPN CI
+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'

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

@@ -37,6 +37,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
 
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
+import Distribution.Types.UnqualComponentName
 
 #ifdef DEBUG_CONFLICT_SETS
 import GHC.Stack (CallStack)
@@ -124,16 +125,16 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment
 type PPreAssignment = Map QPN MergedPkgDep
 
 -- | A dependency on a package, including its DependencyReason.
-data PkgDep = PkgDep (DependencyReason QPN) IsExe QPN CI
+data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI
 
 -- | MergedPkgDep records constraints about the instances that can still be
 -- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a
 -- list of version ranges paired with the goals / variables that introduced
 -- them. It also records whether a package is a build-tool dependency, for use
 -- in log messages.
 data MergedPkgDep =
-    MergedDepFixed IsExe (DependencyReason QPN) I
-  | MergedDepConstrained IsExe [VROrigin]
+    MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I
+  | MergedDepConstrained (Maybe UnqualComponentName) [VROrigin]
 
 -- | Version ranges paired with origins.
 type VROrigin = (VR, DependencyReason QPN)
@@ -185,7 +186,7 @@ validate = cata go
       svd            <- asks saved -- obtain saved dependencies
       qo             <- asks qualifyOptions
       -- obtain dependencies and index-dictated exclusions introduced by the choice
-      let (PInfo deps _ mfr) = idx ! pn ! i
+      let (PInfo deps _ _ mfr) = idx ! pn ! i
       -- qualify the deps in the current scope
       let qdeps = qualifyDeps qo qpn deps
       -- the new active constraints are given by the instance we have chosen,
@@ -328,9 +329,9 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle
     extendSingle a (LDep dr (Pkg pn vr))  =
       if pkgPresent pn vr then Right a
                           else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr)
-    extendSingle a (LDep dr (Dep is_exe qpn ci)) =
-      let mergedDep = M.findWithDefault (MergedDepConstrained (IsExe False) []) qpn a
-      in  case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr is_exe qpn ci) of
+    extendSingle a (LDep dr (Dep mExe qpn ci)) =
+      let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn a
+      in  case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of
             Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')
             Right x           -> Right x
 
@@ -340,8 +341,8 @@ extendWithPackageChoice :: PI QPN
                         -> PPreAssignment
                         -> Either (ConflictSet, FailReason) PPreAssignment
 extendWithPackageChoice (PI qpn i) ppa =
-  let mergedDep = M.findWithDefault (MergedDepConstrained (IsExe False) []) qpn ppa
-      newChoice = PkgDep (DependencyReason qpn [] []) (IsExe False) qpn (Fixed i)
+  let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn ppa
+      newChoice = PkgDep (DependencyReason qpn [] []) Nothing qpn (Fixed i)
   in  case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of
         Left (c, (d, _d')) -> -- Don't include the package choice in the
                               -- FailReason, because it is redundant.
@@ -370,46 +371,49 @@ merge ::
   (?loc :: CallStack) =>
 #endif
   MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
-merge (MergedDepFixed is_exe1 vs1 i1) (PkgDep vs2 is_exe2 p ci@(Fixed i2))
-  | i1 == i2  = Right $ MergedDepFixed (mergeIsExe is_exe1 is_exe2) vs1 i1
+merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2))
+  | i1 == i2  = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i1
   | otherwise =
       Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
-           , ( ConflictingDep vs1 is_exe1 p (Fixed i1)
-             , ConflictingDep vs2 is_exe2 p ci ) )
+           , ( ConflictingDep vs1 mExe1 p (Fixed i1)
+             , ConflictingDep vs2 mExe2 p ci ) )
 
-merge (MergedDepFixed is_exe1 vs1 i@(I v _)) (PkgDep vs2 is_exe2 p ci@(Constrained vr))
-  | checkVR vr v = Right $ MergedDepFixed (mergeIsExe is_exe1 is_exe2) vs1 i
+merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr))
+  | checkVR vr v = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i
   | otherwise    =
       Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
-           , ( ConflictingDep vs1 is_exe1 p (Fixed i)
-             , ConflictingDep vs2 is_exe2 p ci ) )
+           , ( ConflictingDep vs1 mExe1 p (Fixed i)
+             , ConflictingDep vs2 mExe2 p ci ) )
 
-merge (MergedDepConstrained is_exe1 vrOrigins) (PkgDep vs2 is_exe2 p ci@(Fixed i@(I v _))) =
+merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) =
     go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...
   where
     go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
-    go [] = Right (MergedDepFixed (mergeIsExe is_exe1 is_exe2) vs2 i)
+    go [] = Right (MergedDepFixed (mergeExes mExe1 mExe2) vs2 i)
     go ((vr, vs1) : vros)
        | checkVR vr v = go vros
        | otherwise    =
            Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
-                , ( ConflictingDep vs1 is_exe1 p (Constrained vr)
-                  , ConflictingDep vs2 is_exe2 p ci ) )
+                , ( ConflictingDep vs1 mExe1 p (Constrained vr)
+                  , ConflictingDep vs2 mExe2 p ci ) )
 
-merge (MergedDepConstrained is_exe1 vrOrigins) (PkgDep vs2 is_exe2 _ (Constrained vr)) =
-    Right (MergedDepConstrained (mergeIsExe is_exe1 is_exe2) $
+merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) =
+    Right (MergedDepConstrained (mergeExes mExe1 mExe2) $
 
     -- TODO: This line appends the new version range, to preserve the order used
     -- before a refactoring. Consider prepending the version range, if there is
     -- no negative performance impact.
     vrOrigins ++ [(vr, vs2)])
 
--- TODO: This function isn't correct, because cabal may need to build both libs
--- and exes for a package. The merged value is only used to determine whether to
--- print "(exe)" next to conflicts in log message, though. It should be removed
--- when component-based solving is implemented.
-mergeIsExe :: IsExe -> IsExe -> IsExe
-mergeIsExe (IsExe ie1) (IsExe ie2) = IsExe (ie1 || ie2)
+-- TODO: This function isn't correct, because cabal may need to build libs
+-- and/or multiple exes for a package. The merged value is only used to
+-- determine whether to print the name of an exe next to conflicts in log
+-- message, though. It should be removed when component-based solving is
+-- implemented.
+mergeExes :: Maybe UnqualComponentName
+          -> Maybe UnqualComponentName
+          -> Maybe UnqualComponentName
+mergeExes = (<|>)
 
 -- | Interface.
 validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c