{-# LANGUAGE BangPatterns #-}

module Distribution.Solver.Modular.Message (
    Message(..),
    showMessages
  ) 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)
import Prelude hiding (pi)

import Distribution.Pretty (prettyShow) -- from Cabal

import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.MessageUtils
         (showUnsupportedExtension, showUnsupportedLanguage)
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
         ( FailReason(..), POption(..), ConflictingDep(..) )
import Distribution.Solver.Modular.Version
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Progress
import Distribution.Types.LibraryName
import Distribution.Types.UnqualComponentName

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

-- | Transforms the structured message type to actual messages (strings).
--
-- 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.
showMessages :: Progress Message a b -> Progress String a b
showMessages :: forall a b. Progress Message a b -> Progress String a b
showMessages = Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
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 String a b
    go :: forall a b. Int -> Progress Message a b -> Progress String a b
go !Int
_ (Done b
x)                           = b -> Progress String a b
forall step fail done. done -> Progress step fail done
Done b
x
    go !Int
_ (Fail a
x)                           = a -> Progress String a b
forall step fail done. fail -> Progress step fail done
Fail a
x
    -- complex patterns
    go !Int
l (Step (TryP QPN
qpn POption
i) (Step Message
Enter (Step (Failure ConflictSet
c FailReason
fr) (Step Message
Leave Progress Message a b
ms)))) =
        Int
-> QPN
-> [POption]
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
forall a b.
Int
-> QPN
-> [POption]
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
goPReject Int
l QPN
qpn [POption
i] ConflictSet
c FailReason
fr Progress Message a b
ms
    go !Int
l (Step (TryP QPN
qpn POption
i) (Step Message
Enter (Step (Skip Set Conflict
conflicts) (Step Message
Leave Progress Message a b
ms)))) =
        Int
-> QPN
-> [POption]
-> Set Conflict
-> Progress Message a b
-> Progress String a b
forall a b.
Int
-> QPN
-> [POption]
-> Set Conflict
-> Progress Message a b
-> Progress String a b
goPSkip Int
l QPN
qpn [POption
i] Set Conflict
conflicts Progress Message a b
ms
    go !Int
l (Step (TryF QFN
qfn Bool
b) (Step Message
Enter (Step (Failure ConflictSet
c FailReason
fr) (Step Message
Leave Progress Message a b
ms)))) =
        (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"rejecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QFN -> Bool -> String
showQFNBool QFN
qfn Bool
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> FailReason -> String
showFR ConflictSet
c FailReason
fr) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (TryS QSN
qsn Bool
b) (Step Message
Enter (Step (Failure ConflictSet
c FailReason
fr) (Step Message
Leave Progress Message a b
ms)))) =
        (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"rejecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QSN -> Bool -> String
showQSNBool QSN
qsn Bool
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> FailReason -> String
showFR ConflictSet
c FailReason
fr) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (Next (Goal (P QPN
_  ) GoalReason QPN
gr)) (Step (TryP QPN
qpn' POption
i) ms :: Progress Message a b
ms@(Step Message
Enter (Step (Next Goal QPN
_) Progress Message a b
_)))) =
        (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"trying: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> POption -> String
showQPNPOpt QPN
qpn' POption
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ GoalReason QPN -> String
showGR GoalReason QPN
gr) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (Next (Goal (P QPN
qpn) GoalReason QPN
gr)) (Step (Failure ConflictSet
_c FailReason
UnknownPackage) Progress Message a b
ms)) =
        (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"unknown package: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ GoalReason QPN -> String
showGR GoalReason QPN
gr) (Progress String a b -> Progress String a b)
-> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms
    -- standard display
    go !Int
l (Step Message
Enter                    Progress Message a b
ms) = Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Progress Message a b
ms
    go !Int
l (Step Message
Leave                    Progress Message a b
ms) = Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Progress Message a b
ms
    go !Int
l (Step (TryP QPN
qpn POption
i)             Progress Message a b
ms) = (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"trying: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> POption -> String
showQPNPOpt QPN
qpn POption
i) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (TryF QFN
qfn Bool
b)             Progress Message a b
ms) = (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"trying: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QFN -> Bool -> String
showQFNBool QFN
qfn Bool
b) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (TryS QSN
qsn Bool
b)             Progress Message a b
ms) = (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"trying: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QSN -> Bool -> String
showQSNBool QSN
qsn Bool
b) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (Next (Goal (P QPN
qpn) GoalReason QPN
gr)) Progress Message a b
ms) = (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ QPN -> GoalReason QPN -> String
showPackageGoal QPN
qpn GoalReason QPN
gr) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (Next Goal QPN
_)                 Progress Message a b
ms) = Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l     Progress Message a b
ms -- ignore flag goals in the log
    go !Int
l (Step (Skip Set Conflict
conflicts)         Progress Message a b
ms) =
        -- 'Skip' should always be handled by 'goPSkip' in the case above.
        (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"skipping: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Set Conflict -> String
showConflicts Set Conflict
conflicts) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (Message
Success)                Progress Message a b
ms) = (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"done") (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)
    go !Int
l (Step (Failure ConflictSet
c FailReason
fr)           Progress Message a b
ms) = (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> String
showFailure ConflictSet
c FailReason
fr) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)

    showPackageGoal :: QPN -> QGoalReason -> String
    showPackageGoal :: QPN -> GoalReason QPN -> String
showPackageGoal QPN
qpn GoalReason QPN
gr = String
"next goal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ GoalReason QPN -> String
showGR GoalReason QPN
gr

    showFailure :: ConflictSet -> FailReason -> String
    showFailure :: ConflictSet -> FailReason -> String
showFailure ConflictSet
c FailReason
fr = String
"fail" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> FailReason -> String
showFR ConflictSet
c FailReason
fr

    -- special handler for many subsequent package rejections
    goPReject :: Int
              -> QPN
              -> [POption]
              -> ConflictSet
              -> FailReason
              -> Progress Message a b
              -> Progress String a b
    goPReject :: forall a b.
Int
-> QPN
-> [POption]
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
goPReject Int
l QPN
qpn [POption]
is ConflictSet
c FailReason
fr (Step (TryP QPN
qpn' POption
i) (Step Message
Enter (Step (Failure ConflictSet
_ FailReason
fr') (Step Message
Leave Progress Message a b
ms))))
      | QPN
qpn QPN -> QPN -> Bool
forall a. Eq a => a -> a -> Bool
== QPN
qpn' Bool -> Bool -> Bool
&& FailReason
fr FailReason -> FailReason -> Bool
forall a. Eq a => a -> a -> Bool
== FailReason
fr' = Int
-> QPN
-> [POption]
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
forall a b.
Int
-> QPN
-> [POption]
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
goPReject Int
l QPN
qpn (POption
i POption -> [POption] -> [POption]
forall a. a -> [a] -> [a]
: [POption]
is) ConflictSet
c FailReason
fr Progress Message a b
ms
    goPReject Int
l QPN
qpn [POption]
is ConflictSet
c FailReason
fr Progress Message a b
ms =
        (Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l (String -> Progress String a b -> Progress String a b)
-> String -> Progress String a b -> Progress String a b
forall a b. (a -> b) -> a -> b
$ String
"rejecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((POption -> String) -> [POption] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (QPN -> POption -> String
showQPNPOpt QPN
qpn) ([POption] -> [POption]
forall a. [a] -> [a]
reverse [POption]
is)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> FailReason -> String
showFR ConflictSet
c FailReason
fr) (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)

    -- Handle many subsequent skipped package instances.
    goPSkip :: Int
            -> QPN
            -> [POption]
            -> Set CS.Conflict
            -> Progress Message a b
            -> Progress String a b
    goPSkip :: forall a b.
Int
-> QPN
-> [POption]
-> Set Conflict
-> Progress Message a b
-> Progress String a b
goPSkip Int
l QPN
qpn [POption]
is Set Conflict
conflicts (Step (TryP QPN
qpn' POption
i) (Step Message
Enter (Step (Skip Set Conflict
conflicts') (Step Message
Leave Progress Message a b
ms))))
      | QPN
qpn QPN -> QPN -> Bool
forall a. Eq a => a -> a -> Bool
== QPN
qpn' Bool -> Bool -> Bool
&& Set Conflict
conflicts Set Conflict -> Set Conflict -> Bool
forall a. Eq a => a -> a -> Bool
== Set Conflict
conflicts' = Int
-> QPN
-> [POption]
-> Set Conflict
-> Progress Message a b
-> Progress String a b
forall a b.
Int
-> QPN
-> [POption]
-> Set Conflict
-> Progress Message a b
-> Progress String a b
goPSkip Int
l QPN
qpn (POption
i POption -> [POption] -> [POption]
forall a. a -> [a] -> [a]
: [POption]
is) Set Conflict
conflicts Progress Message a b
ms
    goPSkip Int
l QPN
qpn [POption]
is Set Conflict
conflicts Progress Message a b
ms =
      let msg :: String
msg = String
"skipping: "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((POption -> String) -> [POption] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (QPN -> POption -> String
showQPNPOpt QPN
qpn) ([POption] -> [POption]
forall a. [a] -> [a]
reverse [POption]
is))
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Set Conflict -> String
showConflicts Set Conflict
conflicts
      in Int -> String -> Progress String a b -> Progress String a b
forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l String
msg (Int -> Progress Message a b -> Progress String a b
forall a b. Int -> Progress Message a b -> Progress String a b
go Int
l Progress Message a b
ms)

    -- write a message with the current level number
    atLevel :: Int -> String -> Progress String a b -> Progress String a b
    atLevel :: forall a b.
Int -> String -> Progress String a b -> Progress String a b
atLevel Int
l String
x Progress String a b
xs =
      let s :: String
s = Int -> String
forall a. Show a => a -> String
show Int
l
      in  String -> Progress String a b -> Progress String a b
forall step fail done.
step -> Progress step fail done -> Progress step fail done
Step (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'_' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) Progress String a b
xs

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

    -- Merge conflicts to simplify the log message.
    mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict
    mergeConflicts :: Set Conflict -> Map QPN MergedPackageConflict
mergeConflicts = (MergedPackageConflict
 -> MergedPackageConflict -> MergedPackageConflict)
-> [(QPN, MergedPackageConflict)] -> Map QPN MergedPackageConflict
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith MergedPackageConflict
-> MergedPackageConflict -> MergedPackageConflict
mergeConflict ([(QPN, MergedPackageConflict)] -> Map QPN MergedPackageConflict)
-> (Set Conflict -> [(QPN, MergedPackageConflict)])
-> Set Conflict
-> Map QPN MergedPackageConflict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Conflict -> Maybe (QPN, MergedPackageConflict))
-> [Conflict] -> [(QPN, MergedPackageConflict)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Conflict -> Maybe (QPN, MergedPackageConflict)
toMergedConflict ([Conflict] -> [(QPN, MergedPackageConflict)])
-> (Set Conflict -> [Conflict])
-> Set Conflict
-> [(QPN, MergedPackageConflict)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Conflict -> [Conflict]
forall a. Set a -> [a]
S.toList
      where
        mergeConflict :: MergedPackageConflict
                      -> MergedPackageConflict
                      -> MergedPackageConflict
        mergeConflict :: MergedPackageConflict
-> MergedPackageConflict -> MergedPackageConflict
mergeConflict MergedPackageConflict
mergedConflict1 MergedPackageConflict
mergedConflict2 = MergedPackageConflict {
              isGoalConflict :: Bool
isGoalConflict =
                  MergedPackageConflict -> Bool
isGoalConflict MergedPackageConflict
mergedConflict1 Bool -> Bool -> Bool
|| MergedPackageConflict -> Bool
isGoalConflict MergedPackageConflict
mergedConflict2
            , versionConstraintConflict :: [Ver]
versionConstraintConflict =
                  [Ver] -> [Ver]
forall a. Eq a => [a] -> [a]
L.nub ([Ver] -> [Ver]) -> [Ver] -> [Ver]
forall a b. (a -> b) -> a -> b
$ MergedPackageConflict -> [Ver]
versionConstraintConflict MergedPackageConflict
mergedConflict1
                       [Ver] -> [Ver] -> [Ver]
forall a. [a] -> [a] -> [a]
++ MergedPackageConflict -> [Ver]
versionConstraintConflict MergedPackageConflict
mergedConflict2
            , versionConflict :: Maybe VR
versionConflict =
                  Maybe VR -> Maybe VR -> Maybe VR
mergeVersionConflicts (MergedPackageConflict -> Maybe VR
versionConflict MergedPackageConflict
mergedConflict1)
                                        (MergedPackageConflict -> Maybe VR
versionConflict MergedPackageConflict
mergedConflict2)
            }
          where
            mergeVersionConflicts :: Maybe VR -> Maybe VR -> Maybe VR
mergeVersionConflicts (Just VR
vr1) (Just VR
vr2) = VR -> Maybe VR
forall a. a -> Maybe a
Just (VR
vr1 VR -> VR -> VR
.||. VR
vr2)
            mergeVersionConflicts (Just VR
vr1) Maybe VR
Nothing    = VR -> Maybe VR
forall a. a -> Maybe a
Just VR
vr1
            mergeVersionConflicts Maybe VR
Nothing    (Just VR
vr2) = VR -> Maybe VR
forall a. a -> Maybe a
Just VR
vr2
            mergeVersionConflicts Maybe VR
Nothing    Maybe VR
Nothing    = Maybe VR
forall a. Maybe a
Nothing

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

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

        showVersions :: [Ver] -> String
showVersions []  = String
"no versions"
        showVersions [Ver
v] = String
"version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ver -> String
showVer Ver
v
        showVersions [Ver]
vs  = String
"versions " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((Ver -> String) -> [Ver] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ver -> String
showVer [Ver]
vs)

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

showQPNPOpt :: QPN -> POption -> String
showQPNPOpt :: QPN -> POption -> String
showQPNPOpt qpn :: QPN
qpn@(Q PackagePath
_pp PackageName
pn) (POption I
i Maybe PackagePath
linkedTo) =
  case Maybe PackagePath
linkedTo of
    Maybe PackagePath
Nothing  -> PI QPN -> String
showPI (QPN -> I -> PI QPN
forall qpn. qpn -> I -> PI qpn
PI QPN
qpn I
i) -- Consistent with prior to POption
    Just PackagePath
pp' -> QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PI QPN -> String
showPI (QPN -> I -> PI QPN
forall qpn. qpn -> I -> PI qpn
PI (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q PackagePath
pp' PackageName
pn) I
i)

showGR :: QGoalReason -> String
showGR :: GoalReason QPN -> String
showGR GoalReason QPN
UserGoal            = String
" (user goal)"
showGR (DependencyGoal DependencyReason QPN
dr) = String
" (dependency of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DependencyReason QPN -> String
showDependencyReason DependencyReason QPN
dr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

showFR :: ConflictSet -> FailReason -> String
showFR :: ConflictSet -> FailReason -> String
showFR ConflictSet
_ (UnsupportedExtension Extension
ext)       = String
" (conflict: requires " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Extension -> String
showUnsupportedExtension Extension
ext String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (UnsupportedLanguage Language
lang)       = String
" (conflict: requires " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Language -> String
showUnsupportedLanguage Language
lang String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (MissingPkgconfigPackage PkgconfigName
pn PkgconfigVersionRange
vr)  = String
" (conflict: pkg-config package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PkgconfigName -> String
forall a. Pretty a => a -> String
prettyShow PkgconfigName
pn String -> String -> String
forall a. [a] -> [a] -> [a]
++ PkgconfigVersionRange -> String
forall a. Pretty a => a -> String
prettyShow PkgconfigVersionRange
vr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", not found in the pkg-config database)"
showFR ConflictSet
_ (NewPackageDoesNotMatchExistingConstraint ConflictingDep
d) = String
" (conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictingDep -> String
showConflictingDep ConflictingDep
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (ConflictingConstraints ConflictingDep
d1 ConflictingDep
d2)   = String
" (conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((ConflictingDep -> String) -> [ConflictingDep] -> [String]
forall a b. (a -> b) -> [a] -> [b]
L.map ConflictingDep -> String
showConflictingDep [ConflictingDep
d1, ConflictingDep
d2]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (NewPackageIsMissingRequiredComponent ExposedComponent
comp DependencyReason QPN
dr) = String
" (does not contain " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExposedComponent -> String
showExposedComponent ExposedComponent
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", which is required by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DependencyReason QPN -> String
showDependencyReason DependencyReason QPN
dr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (NewPackageHasPrivateRequiredComponent ExposedComponent
comp DependencyReason QPN
dr) = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExposedComponent -> String
showExposedComponent ExposedComponent
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is private, but it is required by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DependencyReason QPN -> String
showDependencyReason DependencyReason QPN
dr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (NewPackageHasUnbuildableRequiredComponent ExposedComponent
comp DependencyReason QPN
dr) = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExposedComponent -> String
showExposedComponent ExposedComponent
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not buildable in the current environment, but it is required by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DependencyReason QPN -> String
showDependencyReason DependencyReason QPN
dr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (PackageRequiresMissingComponent QPN
qpn ExposedComponent
comp) = String
" (requires " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExposedComponent -> String
showExposedComponent ExposedComponent
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but the component does not exist)"
showFR ConflictSet
_ (PackageRequiresPrivateComponent QPN
qpn ExposedComponent
comp) = String
" (requires " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExposedComponent -> String
showExposedComponent ExposedComponent
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but the component is private)"
showFR ConflictSet
_ (PackageRequiresUnbuildableComponent QPN
qpn ExposedComponent
comp) = String
" (requires " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExposedComponent -> String
showExposedComponent ExposedComponent
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but the component is not buildable in the current environment)"
showFR ConflictSet
_ FailReason
CannotInstall                    = String
" (only already installed instances can be used)"
showFR ConflictSet
_ FailReason
CannotReinstall                  = String
" (avoiding to reinstall a package with same version but new dependencies)"
showFR ConflictSet
_ FailReason
NotExplicit                      = String
" (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"
showFR ConflictSet
_ FailReason
Shadowed                         = String
" (shadowed by another installed package with same version)"
showFR ConflictSet
_ (Broken UnitId
u)                       = String
" (package is broken, missing dependency " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ FailReason
UnknownPackage                   = String
" (unknown package)"
showFR ConflictSet
_ (GlobalConstraintVersion VR
vr ConstraintSource
src) = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstraintSource -> String
constraintSource ConstraintSource
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requires " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VR -> String
forall a. Pretty a => a -> String
prettyShow VR
vr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (GlobalConstraintInstalled ConstraintSource
src)  = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstraintSource -> String
constraintSource ConstraintSource
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requires installed instance)"
showFR ConflictSet
_ (GlobalConstraintSource ConstraintSource
src)     = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstraintSource -> String
constraintSource ConstraintSource
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requires source instance)"
showFR ConflictSet
_ (GlobalConstraintFlag ConstraintSource
src)       = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstraintSource -> String
constraintSource ConstraintSource
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requires opposite flag selection)"
showFR ConflictSet
_ FailReason
ManualFlag                       = String
" (manual flag can only be changed explicitly)"
showFR ConflictSet
c FailReason
Backjump                         = String
" (backjumping, conflict set: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showConflictSet ConflictSet
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ FailReason
MultipleInstances                = String
" (multiple instances)"
showFR ConflictSet
c (DependenciesNotLinked String
msg)      = String
" (dependencies not linked: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; conflict set: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showConflictSet ConflictSet
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
c FailReason
CyclicDependencies               = String
" (cyclic dependencies; conflict set: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showConflictSet ConflictSet
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (UnsupportedSpecVer Ver
ver)         = String
" (unsupported spec-version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ver -> String
forall a. Pretty a => a -> String
prettyShow Ver
ver String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
-- 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 ConflictSet
_ (MalformedFlagChoice QFN
qfn)        = String
" (INTERNAL ERROR: MALFORMED FLAG CHOICE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QFN -> String
showQFN QFN
qfn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ (MalformedStanzaChoice QSN
qsn)      = String
" (INTERNAL ERROR: MALFORMED STANZA CHOICE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QSN -> String
showQSN QSN
qsn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showFR ConflictSet
_ FailReason
EmptyGoalChoice                  = String
" (INTERNAL ERROR: EMPTY GOAL CHOICE)"

showExposedComponent :: ExposedComponent -> String
showExposedComponent :: ExposedComponent -> String
showExposedComponent (ExposedLib LibraryName
LMainLibName)       = String
"library"
showExposedComponent (ExposedLib (LSubLibName UnqualComponentName
name)) = String
"library '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
showExposedComponent (ExposedExe UnqualComponentName
name)               = String
"executable '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

constraintSource :: ConstraintSource -> String
constraintSource :: ConstraintSource -> String
constraintSource ConstraintSource
src = String
"constraint from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstraintSource -> String
showConstraintSource ConstraintSource
src

showConflictingDep :: ConflictingDep -> String
showConflictingDep :: ConflictingDep -> String
showConflictingDep (ConflictingDep DependencyReason QPN
dr (PkgComponent QPN
qpn ExposedComponent
comp) CI
ci) =
  let DependencyReason QPN
qpn' Map Flag FlagValue
_ Set Stanza
_ = DependencyReason QPN
dr
      componentStr :: String
componentStr = case ExposedComponent
comp of
                       ExposedExe UnqualComponentName
exe               -> String
" (exe " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
exe String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                       ExposedLib LibraryName
LMainLibName      -> String
""
                       ExposedLib (LSubLibName UnqualComponentName
lib) -> String
" (lib " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  in case CI
ci of
       Fixed I
i        -> (if QPN
qpn QPN -> QPN -> Bool
forall a. Eq a => a -> a -> Bool
/= QPN
qpn' then DependencyReason QPN -> String
showDependencyReason DependencyReason QPN
dr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" => " else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
componentStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"==" String -> String -> String
forall a. [a] -> [a] -> [a]
++ I -> String
showI I
i
       Constrained VR
vr -> DependencyReason QPN -> String
showDependencyReason DependencyReason QPN
dr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QPN -> String
showQPN QPN
qpn String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
componentStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ VR -> String
showVR VR
vr