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

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE LambdaCase #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4
   5 module Distribution.Solver.Modular.Message (
   6     Message(..),
   7     showMessages
   8   ) where
   9
  10 import qualified Data.List as L
  11 import Data.Map (Map)
  12 import qualified Data.Map as M
  13 import Data.Set (Set)
  14 import qualified Data.Set as S
  15 import Data.Maybe (catMaybes, mapMaybe, isJust)
  16 import Prelude hiding (pi)
  17
  18 import Distribution.Pretty (prettyShow) -- from Cabal
  19
  20 import qualified Distribution.Solver.Modular.ConflictSet as CS
  21 import Distribution.Solver.Modular.Dependency
  22 import Distribution.Solver.Modular.Flag ( QFN, QSN )
  23 import qualified Distribution.Solver.Modular.Flag as Flag ( showQFN, showQFNBool, showQSN, showQSNBool )
  24 import Distribution.Solver.Modular.MessageUtils
  25          (showUnsupportedExtension, showUnsupportedLanguage)
  26 import Distribution.Solver.Modular.Package
  27 import Distribution.Solver.Modular.Tree
  28          ( FailReason(..), POption(..), ConflictingDep(..) )
  29 import Distribution.Solver.Modular.Version
  30 import Distribution.Solver.Types.ConstraintSource
  31 import Distribution.Solver.Types.PackagePath
  32 import Distribution.Solver.Types.Progress
  33 import Distribution.Solver.Types.ProjectConfigPath (docProjectConfigPathFailReason)
  34 import Distribution.Types.LibraryName
  35 import Distribution.Types.UnqualComponentName
  36 import Text.PrettyPrint (nest, render)
  37
  38 data Message =
  39     Enter           -- ^ increase indentation level
  40   | Leave           -- ^ decrease indentation level
  41   | TryP QPN POption
  42   | TryF QFN Bool
  43   | TryS QSN Bool
  44   | Next (Goal QPN)
  45   | Skip (Set CS.Conflict)
  46   | Success
  47   | Failure ConflictSet FailReason
  48
  49 -- | Transforms the structured message type to actual messages (strings).
  50 --
  51 -- The log contains level numbers, which are useful for any trace that involves
  52 -- backtracking, because only the level numbers will allow to keep track of
  53 -- backjumps.
  54 showMessages :: Progress Message a b -> Progress String a b
  55 showMessages = go 0
  56   where
  57     -- 'go' increments the level for a recursive call when it encounters
  58     -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.
  59     go :: Int -> Progress Message a b -> Progress String a b
  60     go !_ (Done x)                           = Done x
  61     go !_ (Fail x)                           = Fail x
  62     -- complex patterns
  63     go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
  64         goPReject l qpn [i] c fr ms
  65     go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =
  66         goPSkip l qpn [i] conflicts ms
  67     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
  68         (atLevel l $ blurbQFNBool Rejecting qfn b ++ showFR c fr) (go l ms)
  69     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
  70         (atLevel l $ blurbQSNBool Rejecting qsn b ++ showFR c fr) (go l ms)
  71     go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
  72         (atLevel l $ blurbOption Trying qpn' i ++ showGR gr) (go l ms)
  73     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
  74         atLevel l ("unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms
  75     -- standard display
  76     go !l (Step Enter                    ms) = go (l+1) ms
  77     go !l (Step Leave                    ms) = go (l-1) ms
  78     go !l (Step (TryP qpn i)             ms) = (atLevel l $ blurbOption Trying qpn i) (go l ms)
  79     go !l (Step (TryF qfn b)             ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms)
  80     go !l (Step (TryS qsn b)             ms) = (atLevel l $ blurbQSNBool Trying qsn b) (go l ms)
  81     go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)
  82     go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log
  83     go !l (Step (Skip conflicts)         ms) =
  84         -- 'Skip' should always be handled by 'goPSkip' in the case above.
  85         (atLevel l $ blurb Skipping ++ showConflicts conflicts) (go l ms)
  86     go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)
  87     go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)
  88
  89     showPackageGoal :: QPN -> QGoalReason -> String
  90     showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr
  91
  92     showFailure :: ConflictSet -> FailReason -> String
  93     showFailure c fr = "fail" ++ showFR c fr
  94
  95     -- special handler for many subsequent package rejections
  96     goPReject :: Int
  97               -> QPN
  98               -> [POption]
  99               -> ConflictSet
 100               -> FailReason
 101               -> Progress Message a b
 102               -> Progress String a b
 103     goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
 104       | qpn == qpn' && fr == fr' =
 105         -- By prepending (i : is) we reverse the order of the instances.
 106         goPReject l qpn (i : is) c fr ms
 107     goPReject l qpn is c fr ms =
 108         (atLevel l $ blurbOptions Rejecting qpn (reverse is) ++ showFR c fr)
 109         (go l ms)
 110
 111     -- Handle many subsequent skipped package instances.
 112     goPSkip :: Int
 113             -> QPN
 114             -> [POption]
 115             -> Set CS.Conflict
 116             -> Progress Message a b
 117             -> Progress String a b
 118     goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
 119       | qpn == qpn' && conflicts == conflicts' =
 120         -- By prepending (i : is) we reverse the order of the instances.
 121         goPSkip l qpn (i : is) conflicts ms
 122     goPSkip l qpn is conflicts ms =
 123       let msg = blurbOptions Skipping qpn (reverse is) ++ showConflicts conflicts
 124       in atLevel l msg (go l ms)
 125
 126     -- write a message with the current level number
 127     atLevel :: Int -> String -> Progress String a b -> Progress String a b
 128     atLevel l x xs =
 129       let s = show l
 130       in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs
 131
 132 -- | Display the set of 'Conflicts' for a skipped package version.
 133 showConflicts :: Set CS.Conflict -> String
 134 showConflicts conflicts =
 135     " (has the same characteristics that caused the previous version to fail: "
 136      ++ conflictMsg ++ ")"
 137   where
 138     conflictMsg :: String
 139     conflictMsg =
 140       if S.member CS.OtherConflict conflicts
 141       then
 142         -- This case shouldn't happen, because an unknown conflict should not
 143         -- cause a version to be skipped.
 144         "unknown conflict"
 145       else let mergedConflicts =
 146                    [ showConflict qpn conflict
 147                    | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ]
 148            in if L.null mergedConflicts
 149               then
 150                   -- This case shouldn't happen unless backjumping is turned off.
 151                   "none"
 152               else L.intercalate "; " mergedConflicts
 153
 154     -- Merge conflicts to simplify the log message.
 155     mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict
 156     mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList
 157       where
 158         mergeConflict :: MergedPackageConflict
 159                       -> MergedPackageConflict
 160                       -> MergedPackageConflict
 161         mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict {
 162               isGoalConflict =
 163                   isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2
 164             , versionConstraintConflict =
 165                   L.nub $ versionConstraintConflict mergedConflict1
 166                        ++ versionConstraintConflict mergedConflict2
 167             , versionConflict =
 168                   mergeVersionConflicts (versionConflict mergedConflict1)
 169                                         (versionConflict mergedConflict2)
 170             }
 171           where
 172             mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2)
 173             mergeVersionConflicts (Just vr1) Nothing    = Just vr1
 174             mergeVersionConflicts Nothing    (Just vr2) = Just vr2
 175             mergeVersionConflicts Nothing    Nothing    = Nothing
 176
 177         toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict)
 178         toMergedConflict (CS.GoalConflict qpn) =
 179             Just (qpn, MergedPackageConflict True [] Nothing)
 180         toMergedConflict (CS.VersionConstraintConflict qpn v) =
 181             Just (qpn, MergedPackageConflict False [v] Nothing)
 182         toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =
 183             Just (qpn, MergedPackageConflict False [] (Just vr))
 184         toMergedConflict CS.OtherConflict = Nothing
 185
 186     showConflict :: QPN -> MergedPackageConflict -> String
 187     showConflict qpn mergedConflict = L.intercalate "; " conflictStrings
 188       where
 189         conflictStrings = catMaybes [
 190             case () of
 191               () | isGoalConflict mergedConflict -> Just $
 192                      "depends on '" ++ showQPN qpn ++ "'" ++
 193                          (if null (versionConstraintConflict mergedConflict)
 194                           then ""
 195                           else " but excludes "
 196                                 ++ showVersions (versionConstraintConflict mergedConflict))
 197                  | not $ L.null (versionConstraintConflict mergedConflict) -> Just $
 198                      "excludes '" ++ showQPN qpn
 199                       ++ "' " ++ showVersions (versionConstraintConflict mergedConflict)
 200                  | otherwise -> Nothing
 201           , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'")
 202              <$> versionConflict mergedConflict
 203           ]
 204
 205         showVersions []  = "no versions"
 206         showVersions [v] = "version " ++ showVer v
 207         showVersions vs  = "versions " ++ L.intercalate ", " (map showVer vs)
 208
 209 -- | All conflicts related to one package, used for simplifying the display of
 210 -- a 'Set CS.Conflict'.
 211 data MergedPackageConflict = MergedPackageConflict {
 212     isGoalConflict :: Bool
 213   , versionConstraintConflict :: [Ver]
 214   , versionConflict :: Maybe VR
 215   }
 216
 217 data ProgressAction =
 218     Trying
 219   | Skipping
 220   | Rejecting
 221
 222 blurb :: ProgressAction -> String
 223 blurb = \case
 224   Trying -> "trying: "
 225   Skipping -> "skipping: "
 226   Rejecting -> "rejecting: "
 227
 228 blurbQFNBool :: ProgressAction -> QFN -> Bool -> String
 229 blurbQFNBool a q b = blurb a ++ Flag.showQFNBool q b
 230
 231 blurbQSNBool :: ProgressAction -> QSN -> Bool -> String
 232 blurbQSNBool a q b = blurb a ++ Flag.showQSNBool q b
 233
 234 blurbOption :: ProgressAction -> QPN -> POption -> String
 235 blurbOption a q p = blurb a ++ showOption q p
 236
 237 blurbOptions :: ProgressAction -> QPN -> [POption] -> String
 238 blurbOptions a q ps = blurb a ++ showOptions q ps
 239
 240 showOption :: QPN -> POption -> String
 241 showOption qpn@(Q _pp pn) (POption i linkedTo) =
 242   case linkedTo of
 243     Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption
 244     Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)
 245
 246 -- | Shows a mixed list of instances and versions in a human-friendly way,
 247 -- abbreviated.
 248 -- >>> showOptions foobarQPN [v0, v1]
 249 -- "foo-bar; 0, 1"
 250 -- >>> showOptions foobarQPN [v0]
 251 -- "foo-bar-0"
 252 -- >>> showOptions foobarQPN [i0, i1]
 253 -- "foo-bar; 0/installed-inplace, 1/installed-inplace"
 254 -- >>> showOptions foobarQPN [i0, v1]
 255 -- "foo-bar; 0/installed-inplace, 1"
 256 -- >>> showOptions foobarQPN [v0, i1]
 257 -- "foo-bar; 0, 1/installed-inplace"
 258 -- >>> showOptions foobarQPN []
 259 -- "unexpected empty list of versions"
 260 -- >>> showOptions foobarQPN [k1, k2]
 261 -- "foo-bar; foo-bar~>bazqux.foo-bar-1, foo-bar~>bazqux.foo-bar-2"
 262 -- >>> showOptions foobarQPN [v0, i1, k2]
 263 -- "foo-bar; 0, 1/installed-inplace, foo-bar~>bazqux.foo-bar-2"
 264 showOptions :: QPN -> [POption] -> String
 265 showOptions _ [] = "unexpected empty list of versions"
 266 showOptions q [x] = showOption q x
 267 showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", "
 268   [if isJust linkedTo
 269     then showOption q x
 270     else showI i -- Don't show the package, just the version
 271   | x@(POption i linkedTo) <- xs
 272   ])
 273
 274 showGR :: QGoalReason -> String
 275 showGR UserGoal            = " (user goal)"
 276 showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"
 277
 278 showFR :: ConflictSet -> FailReason -> String
 279 showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")"
 280 showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")"
 281 showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)"
 282 showFR _ (MissingPkgconfigProgram pn vr)  = " (pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ " is needed but no pkg-config executable was found or querying it failed)"
 283 showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
 284 showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
 285 showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"
 286 showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")"
 287 showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")"
 288 showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"
 289 showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"
 290 showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)"
 291 showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"
 292 showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"
 293 showFR _ Shadowed                         = " (shadowed by another installed package with same version)"
 294 showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"
 295 showFR _ UnknownPackage                   = " (unknown package)"
 296 showFR _ (GlobalConstraintVersion vr (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc)
 297 showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"
 298 showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"
 299 showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"
 300 showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"
 301 showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"
 302 showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"
 303 showFR _ MultipleInstances                = " (multiple instances)"
 304 showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"
 305 showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"
 306 showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ prettyShow ver ++ ")"
 307 -- The following are internal failures. They should not occur. In the
 308 -- interest of not crashing unnecessarily, we still just print an error
 309 -- message though.
 310 showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ Flag.showQFN qfn ++ ")"
 311 showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.showQSN qsn ++ ")"
 312 showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
 313
 314 showExposedComponent :: ExposedComponent -> String
 315 showExposedComponent (ExposedLib LMainLibName)       = "library"
 316 showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"
 317 showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"
 318
 319 constraintSource :: ConstraintSource -> String
 320 constraintSource src = "constraint from " ++ showConstraintSource src
 321
 322 showConflictingDep :: ConflictingDep -> String
 323 showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
 324   let DependencyReason qpn' _ _ = dr
 325       componentStr = case comp of
 326                        ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"
 327                        ExposedLib LMainLibName      -> ""
 328                        ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"
 329   in case ci of
 330        Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
 331                          showQPN qpn ++ componentStr ++ "==" ++ showI i
 332        Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++
 333                          componentStr ++ showVR vr
 334
 335 -- $setup
 336 -- >>> import Distribution.Solver.Types.PackagePath
 337 -- >>> import Distribution.Types.Version
 338 -- >>> import Distribution.Types.UnitId
 339 -- >>> let foobarPN = PackagePath DefaultNamespace QualToplevel
 340 -- >>> let bazquxPN = PackagePath (Independent $ mkPackageName "bazqux") QualToplevel
 341 -- >>> let foobarQPN = Q foobarPN (mkPackageName "foo-bar")
 342 -- >>> let v0 = POption (I (mkVersion [0]) InRepo) Nothing
 343 -- >>> let v1 = POption (I (mkVersion [1]) InRepo) Nothing
 344 -- >>> let i0 = POption (I (mkVersion [0]) (Inst $ mkUnitId "foo-bar-0-inplace")) Nothing
 345 -- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing
 346 -- >>> let k1 = POption (I (mkVersion [1]) InRepo) (Just bazquxPN)
 347 -- >>> let k2 = POption (I (mkVersion [2]) InRepo) (Just bazquxPN)