Message.hs

{-# LANGUAGE BangPatterns #-}

module Distribution.Solver.Modular.Message (
    Message(..),
    summarizeMessages,
    renderSummarizedMessage,
  ) where

import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Maybe (catMaybes, mapMaybe, isJust)
import Prelude hiding (pi)

import Distribution.Pretty ( prettyShow ) -- from Cabal

import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Dependency
    ( Var(P),
      ConflictSet,
      showConflictSet,
      QGoalReason,
      GoalReason(DependencyGoal, UserGoal),
      Goal(Goal),
      DependencyReason(DependencyReason),
      ExposedComponent(..),
      PkgComponent(PkgComponent),
      CI(Constrained, Fixed),
      showDependencyReason )
import Distribution.Solver.Modular.Flag
    ( QSN, QFN, showQFNBool, showQSNBool, showQFN, showQSN )
import Distribution.Solver.Modular.MessageUtils
    ( showUnsupportedExtension, showUnsupportedLanguage )
import Distribution.Solver.Modular.Package
    ( PI(PI), showI, showPI )
import Distribution.Solver.Modular.Tree
    ( FailReason(..), POption(..), ConflictingDep(..) )
import Distribution.Solver.Modular.Version
    ( VR, Ver, showVer, showVR, (.||.) )

import Distribution.Solver.Types.ConstraintSource
    ( ConstraintSource (..), showConstraintSource )
import Distribution.Solver.Types.PackagePath
    ( QPN, Qualified(Q), showQPN )
import Distribution.Solver.Types.Progress
    ( Progress(..) )
import Distribution.Solver.Types.ProjectConfigPath
    ( docProjectConfigPathFailReason)
import Distribution.Solver.Types.SummarizedMessage
    ( Entry(..), EntryAtLevel(..), SummarizedMessage(..) )
import Distribution.Types.LibraryName
    ( LibraryName(LSubLibName, LMainLibName) )
import Distribution.Types.UnqualComponentName
    ( unUnqualComponentName )

import Text.PrettyPrint ( nest, render )

-- A data type to hold log information from the modular solver.
data Message =
    Enter           -- ^ increase indentation level
  | Leave           -- ^ decrease indentation level
  | TryP QPN POption
  | TryF QFN Bool
  | TryS QSN Bool
  | Next (Goal QPN)
  | Skip (Set CS.Conflict)
  | Success
  | Failure ConflictSet FailReason

renderSummarizedMessage :: SummarizedMessage -> String
renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i
renderSummarizedMessage (StringMsg s) = s

displayMessageAtLevel :: EntryAtLevel -> String
displayMessageAtLevel (AtLevel l msg) =
  let s = show l
  in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg

displayMessage :: Entry -> String
displayMessage (EntryPackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
displayMessage (EntryRejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
displayMessage (EntryRejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
displayMessage (EntrySkipping cs) = "skipping: " ++ showConflicts cs
displayMessage (EntryTryingF qfn b) = "trying: " ++ showQFNBool qfn b
displayMessage (EntryTryingP qpn i) = "trying: " ++ showOption qpn i
displayMessage (EntryTryingNewP qpn i gr) = "trying: " ++ showOption qpn i ++ showGR gr
displayMessage (EntryTryingS qsn b) = "trying: " ++ showQSNBool qsn b
displayMessage (EntryUnknownPackage qpn gr) = "unknown package: " ++ showQPN qpn ++ showGR gr
displayMessage EntrySuccess = "done"
displayMessage (EntryFailure c fr) = "fail" ++ showFR c fr
displayMessage (EntrySkipMany qsn b cs) = "skipping: " ++ showOptions qsn b ++ " " ++ showConflicts cs
-- Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
-- the following line aims to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
--
displayMessage (EntryRejectMany qpn is c fr) = "rejecting: " ++ showOptions qpn is ++ showFR c fr

-- | Transforms the structured message type to actual messages (SummarizedMessage s).
--
-- The log contains level numbers, which are useful for any trace that involves
-- backtracking, because only the level numbers will allow to keep track of
-- backjumps.
summarizeMessages :: Progress Message a b -> Progress SummarizedMessage a b
summarizeMessages = go 0
  where
    -- 'go' increments the level for a recursive call when it encounters
    -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.
    go :: Int -> Progress Message a b -> Progress SummarizedMessage a b
    go !_ (Done x)                           = Done x
    go !_ (Fail x)                           = Fail x

    -- complex patterns
    go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
        goPReject l qpn [i] c fr ms

    go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =
        goPSkip l qpn [i] conflicts ms

    go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
        Step (SummarizedMsg $ AtLevel l (EntryRejectF qfn b c fr)) (go l ms)

    go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
        Step (SummarizedMsg $ AtLevel l (EntryRejectS qsn b c fr)) (go l ms)

    -- "Trying ..." message when a new goal is started
    go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
        Step (SummarizedMsg $ AtLevel l (EntryTryingNewP qpn' i gr)) (go l ms)

    go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
        Step (SummarizedMsg $ AtLevel l (EntryUnknownPackage qpn gr)) (go l ms)

    -- standard display
    go !l (Step Enter                    ms) = go (l+1) ms
    go !l (Step Leave                    ms) = go (l-1) ms

    go !l (Step (TryP qpn i)             ms) = Step (SummarizedMsg $ AtLevel l (EntryTryingP qpn i)) (go l ms)
    go !l (Step (TryF qfn b)             ms) = Step (SummarizedMsg $ AtLevel l (EntryTryingF qfn b)) (go l ms)
    go !l (Step (TryS qsn b)             ms) = Step (SummarizedMsg $ AtLevel l (EntryTryingS qsn b)) (go l ms)
    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMsg $ AtLevel l (EntryPackageGoal qpn gr)) (go l ms)
    go !l (Step (Next _)                 ms) = go l ms -- ignore flag goals in the log

    -- 'Skip' should always be handled by 'goPSkip' in the case above.
    go !l (Step (Skip conflicts)         ms) = Step (SummarizedMsg $ AtLevel l (EntrySkipping conflicts)) (go l ms)
    go !l (Step (Success)                ms) = Step (SummarizedMsg $ AtLevel l EntrySuccess) (go l ms)
    go !l (Step (Failure c fr)           ms) = Step (SummarizedMsg $ AtLevel l (EntryFailure c fr)) (go l ms)

    -- special handler for many subsequent package rejections
    goPReject :: Int
              -> QPN
              -> [POption]
              -> ConflictSet
              -> FailReason
              -> Progress Message a b
              -> Progress SummarizedMessage a b
    goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
      | qpn == qpn' && fr == fr' =
        -- By prepending (i : is) we reverse the order of the instances.
        goPReject l qpn (i : is) c fr ms
    goPReject l qpn is c fr ms =
        Step (SummarizedMsg $ AtLevel l (EntryRejectMany qpn (reverse is) c fr)) (go l ms)

    -- Handle many subsequent skipped package instances.
    goPSkip :: Int
            -> QPN
            -> [POption]
            -> Set CS.Conflict
            -> Progress Message a b
            -> Progress SummarizedMessage a b
    goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
      | qpn == qpn' && conflicts == conflicts' =
        -- By prepending (i : is) we reverse the order of the instances.
        goPSkip l qpn (i : is) conflicts ms
    goPSkip l qpn is conflicts ms =
       Step (SummarizedMsg $ AtLevel l (EntrySkipMany qpn (reverse is) conflicts)) (go l ms)

-- | Display the set of 'Conflicts' for a skipped package version.
showConflicts :: Set CS.Conflict -> String
showConflicts conflicts =
    "(has the same characteristics that caused the previous version to fail: "
     ++ conflictMsg ++ ")"
  where
    conflictMsg :: String
    conflictMsg =
      if S.member CS.OtherConflict conflicts
      then
        -- This case shouldn't happen, because an unknown conflict should not
        -- cause a version to be skipped.
        "unknown conflict"
      else let mergedConflicts =
                   [ showConflict qpn conflict
                   | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ]
           in if L.null mergedConflicts
              then
                  -- This case shouldn't happen unless backjumping is turned off.
                  "none"
              else L.intercalate "; " mergedConflicts

    -- Merge conflicts to simplify the log message.
    mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict
    mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList
      where
        mergeConflict :: MergedPackageConflict
                      -> MergedPackageConflict
                      -> MergedPackageConflict
        mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict {
              isGoalConflict =
                  isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2
            , versionConstraintConflict =
                  L.nub $ versionConstraintConflict mergedConflict1
                       ++ versionConstraintConflict mergedConflict2
            , versionConflict =
                  mergeVersionConflicts (versionConflict mergedConflict1)
                                        (versionConflict mergedConflict2)
            }
          where
            mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2)
            mergeVersionConflicts (Just vr1) Nothing    = Just vr1
            mergeVersionConflicts Nothing    (Just vr2) = Just vr2
            mergeVersionConflicts Nothing    Nothing    = Nothing

        toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict)
        toMergedConflict (CS.GoalConflict qpn) =
            Just (qpn, MergedPackageConflict True [] Nothing)
        toMergedConflict (CS.VersionConstraintConflict qpn v) =
            Just (qpn, MergedPackageConflict False [v] Nothing)
        toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =
            Just (qpn, MergedPackageConflict False [] (Just vr))
        toMergedConflict CS.OtherConflict = Nothing

    showConflict :: QPN -> MergedPackageConflict -> String
    showConflict qpn mergedConflict = L.intercalate "; " conflictStrings
      where
        conflictStrings = catMaybes [
            case () of
              () | isGoalConflict mergedConflict -> Just $
                     "depends on '" ++ showQPN qpn ++ "'" ++
                         (if null (versionConstraintConflict mergedConflict)
                          then ""
                          else " but excludes "
                                ++ showVersions (versionConstraintConflict mergedConflict))
                 | not $ L.null (versionConstraintConflict mergedConflict) -> Just $
                     "excludes '" ++ showQPN qpn
                      ++ "' " ++ showVersions (versionConstraintConflict mergedConflict)
                 | otherwise -> Nothing
          , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'")
             <$> versionConflict mergedConflict
          ]

        showVersions []  = "no versions"
        showVersions [v] = "version " ++ showVer v
        showVersions vs  = "versions " ++ L.intercalate ", " (map showVer vs)

-- | All conflicts related to one package, used for simplifying the display of
-- a 'Set CS.Conflict'.
data MergedPackageConflict = MergedPackageConflict {
    isGoalConflict :: Bool
  , versionConstraintConflict :: [Ver]
  , versionConflict :: Maybe VR
  }

showOption :: QPN -> POption -> String
showOption qpn@(Q _pp pn) (POption i linkedTo) =
  case linkedTo of
    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption
    Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn

-- | Shows a mixed list of instances and versions in a human-friendly way,
-- abbreviated.
-- >>> showOptions foobarQPN [v0, v1]
-- "foo-bar; 0, 1"
-- >>> showOptions foobarQPN [v0]
-- "foo-bar-0"
-- >>> showOptions foobarQPN [i0, i1]
-- "foo-bar; 0/installed-inplace, 1/installed-inplace"
-- >>> showOptions foobarQPN [i0, v1]
-- "foo-bar; 0/installed-inplace, 1"
-- >>> showOptions foobarQPN [v0, i1]
-- "foo-bar; 0, 1/installed-inplace"
-- >>> showOptions foobarQPN []
-- "unexpected empty list of versions"
-- >>> showOptions foobarQPN [k1, k2]
-- "foo-bar; foo-bar~>bazqux.foo-bar-1, foo-bar~>bazqux.foo-bar-2"
-- >>> showOptions foobarQPN [v0, i1, k2]
-- "foo-bar; 0, 1/installed-inplace, foo-bar~>bazqux.foo-bar-2"
showOptions :: QPN -> [POption] -> String
showOptions _ [] = "unexpected empty list of versions"
showOptions q [x] = showOption q x
showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", "
  [if isJust linkedTo
    then showOption q x
    else showI i -- Don't show the package, just the version
  | x@(POption i linkedTo) <- xs
  ])

showGR :: QGoalReason -> String
showGR UserGoal            = " (user goal)"
showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"

showFR :: ConflictSet -> FailReason -> String
showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")"
showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")"
showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)"
showFR _ (MissingPkgconfigProgram pn vr)  = " (pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ " is needed but no pkg-config executable was found or querying it failed)"
showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"
showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")"
showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")"
showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"
showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"
showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)"
showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"
showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"
showFR _ Shadowed                         = " (shadowed by another installed package with same version)"
showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"
showFR _ UnknownPackage                   = " (unknown package)"
showFR _ (GlobalConstraintVersion vr (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc)
showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"
showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"
showFR _ (GlobalConstraintInstalledSpecificUnitId unitId src)  = " (" ++ constraintSource src ++ " requires installed instance with unit id " ++ prettyShow unitId ++ ")"
showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"
showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"
showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"
showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"
showFR _ MultipleInstances                = " (multiple instances)"
showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"
showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"
showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ prettyShow ver ++ ")"
-- The following are internal failures. They should not occur. In the
-- interest of not crashing unnecessarily, we still just print an error
-- message though.
showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"
showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"

showExposedComponent :: ExposedComponent -> String
showExposedComponent (ExposedLib LMainLibName)       = "library"
showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"
showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"

constraintSource :: ConstraintSource -> String
constraintSource src = "constraint from " ++ showConstraintSource src

showConflictingDep :: ConflictingDep -> String
showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
  let DependencyReason qpn' _ _ = dr
      componentStr = case comp of
                       ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"
                       ExposedLib LMainLibName      -> ""
                       ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"
  in case ci of
       Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
                         showQPN qpn ++ componentStr ++ "==" ++ showI i
       Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++
                         componentStr ++ showVR vr

-- $setup
-- >>> import Distribution.Solver.Modular.Package
-- >>> import Distribution.Solver.Types.PackagePath
-- >>> import Distribution.Types.PackageName
-- >>> import Distribution.Types.Version
-- >>> import Distribution.Types.UnitId
-- >>> let foobarPN = PackagePath DefaultNamespace QualToplevel
-- >>> let bazquxPN = PackagePath (Independent $ mkPackageName "bazqux") QualToplevel
-- >>> let foobarQPN = Q foobarPN (mkPackageName "foo-bar")
-- >>> let v0 = POption (I (mkVersion [0]) InRepo) Nothing
-- >>> let v1 = POption (I (mkVersion [1]) InRepo) Nothing
-- >>> let i0 = POption (I (mkVersion [0]) (Inst $ mkUnitId "foo-bar-0-inplace")) Nothing
-- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing
-- >>> let k1 = POption (I (mkVersion [1]) InRepo) (Just bazquxPN)
-- >>> let k2 = POption (I (mkVersion [2]) InRepo) (Just bazquxPN)