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

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