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