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

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