diff options
Diffstat (limited to 'compiler/GHC/Tc/Errors/Ppr.hs')
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 127 |
1 files changed, 65 insertions, 62 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index d1ea6d93e2..a736a40871 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -226,11 +226,17 @@ instance Diagnostic TcRnMessage where <+> text "with" <+> quotes (ppr n2)) 2 (hang (text "both bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) - TcRnPartialTypeSigBadQuantifier n fn_name hs_ty + TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty -> mkSimpleDecorated $ hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + 2 (vcat [ hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) + , extra ]) + where + extra | Just rhs_ty <- m_unif_ty + = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] + | otherwise + = empty TcRnMissingSignature what _ _ -> mkSimpleDecorated $ case what of @@ -294,9 +300,6 @@ instance Diagnostic TcRnMessage where text "in the type of a term:") 2 (pprType ty) , text "(GHC does not yet support this)" ] - TcRnIllegalEqualConstraints ty - -> mkSimpleDecorated $ - text "Illegal equational constraint" <+> pprType ty TcRnBadQuantPredHead ty -> mkSimpleDecorated $ hang (text "Quantified predicate must have a class or type variable head:") @@ -744,8 +747,6 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnVDQInTermType{} -> ErrorWithoutFlag - TcRnIllegalEqualConstraints{} - -> ErrorWithoutFlag TcRnBadQuantPredHead{} -> ErrorWithoutFlag TcRnIllegalTupleConstraint{} @@ -982,8 +983,6 @@ instance Diagnostic TcRnMessage where -> noHints TcRnVDQInTermType{} -> noHints - TcRnIllegalEqualConstraints{} - -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] TcRnBadQuantPredHead{} -> noHints TcRnIllegalTupleConstraint{} @@ -1531,7 +1530,7 @@ pprTcSolverReportMsg _ (UserTypeError ty) = pprUserTypeErrorTy ty pprTcSolverReportMsg ctxt (ReportHoleError hole err) = pprHoleError ctxt hole err -pprTcSolverReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = +pprTcSolverReportMsg _ (CannotUnifyWithPolytype item tv1 ty2) = vcat [ (if isSkolemTyVar tv1 then text "Cannot equate type variable" else text "Cannot instantiate unification variable") @@ -1539,13 +1538,13 @@ pprTcSolverReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] where what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel pprTcSolverReportMsg _ - (Mismatch { mismatch_ea = add_ea - , mismatch_ct = ct - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 }) - = addArising (ctOrigin ct) msg + (Mismatch { mismatch_ea = add_ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 }) + = addArising (errorItemOrigin item) msg where msg | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || @@ -1576,9 +1575,9 @@ pprTcSolverReportMsg _ padding = length herald1 - length herald2 - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } + is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } - what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) + what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) conc :: [String] -> String conc = foldr1 add_space @@ -1605,9 +1604,9 @@ pprTcSolverReportMsg _ pprTcSolverReportMsg ctxt (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_ct = ct - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 + , teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 , teq_mismatch_expected = exp , teq_mismatch_actual = act , teq_mismatch_what = mb_thing }) @@ -1628,21 +1627,21 @@ pprTcSolverReportMsg ctxt Just thing -> quotes (ppr thing) <+> text "has kind" , quotes (pprWithTYPE act) ] | Just nargs_msg <- num_args_msg - , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig = nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ ea_looks_same ty1 ty2 exp act - , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig = pprTcSolverReportMsg ctxt ea_msg -- The mismatched types are /inside/ exp and act - | let mismatch_err = Mismatch False ct ty1 ty2 + | let mismatch_err = Mismatch False item ty1 ty2 errs = case mk_ea_msg ctxt Nothing level orig of Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ] Right ea_err -> [ mismatch_err, ea_err ] = vcat $ map (pprTcSolverReportMsg ctxt) errs - ct_loc = ctLoc ct - orig = ctOrigin ct + ct_loc = errorItemCtLoc item + orig = errorItemOrigin item level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel thing_msg (Just thing) _ levity = quotes (ppr thing) <+> text "is" <+> levity @@ -1683,7 +1682,7 @@ pprTcSolverReportMsg _ (FixedRuntimeRepError origs_and_tys) = ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty)] in vcat $ map (uncurry combine_origin_ty) origs_and_tys -pprTcSolverReportMsg _ (SkolemEscape ct implic esc_skols) = +pprTcSolverReportMsg _ (SkolemEscape item implic esc_skols) = let esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols @@ -1703,7 +1702,7 @@ pprTcSolverReportMsg _ (SkolemEscape ct implic esc_skols) = ppr (getLclEnvLoc (ic_env implic)) ] ] where what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel pprTcSolverReportMsg _ (UntouchableVariable tv implic) | Implic { ic_given = given, ic_info = skol_info } <- implic = sep [ quotes (ppr tv) <+> text "is untouchable" @@ -1711,9 +1710,9 @@ pprTcSolverReportMsg _ (UntouchableVariable tv implic) , nest 2 $ text "bound by" <+> ppr skol_info , nest 2 $ text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ] -pprTcSolverReportMsg _ (BlockedEquality ct) = +pprTcSolverReportMsg _ (BlockedEquality item) = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) + 2 (ppr (errorItemPred item)) , text "Doing so would be ill-kinded." ] pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = text "Expecting" <+> speakN (abs n) <+> @@ -1722,16 +1721,16 @@ pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = more | n == 1 = text "more argument to" | otherwise = text "more arguments to" -- n > 1 -pprTcSolverReportMsg ctxt (UnboundImplicitParams (ct :| cts)) = +pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = let givens = getUserGivens ctxt in if null givens - then addArising (ctOrigin ct) $ + then addArising (errorItemOrigin item) $ sep [ text "Unbound implicit parameter" <> plural preds , nest 2 (pprParendTheta preds) ] - else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (ct :| cts) Nothing) + else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) where - preds = map ctPred (ct : cts) -pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) + preds = map errorItemPred (item : items) +pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) = main_msg $$ case supplementary of Left infos @@ -1741,17 +1740,17 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) where main_msg | null useful_givens - = addArising (ctOrigin ct) no_instance_msg + = addArising orig no_instance_msg | otherwise - = vcat [ addArising (ctOrigin ct) no_deduce_msg + = vcat [ addArising orig no_deduce_msg , vcat (pp_givens useful_givens) ] supplementary = case mb_extra of Nothing -> Left [] Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig - (wanted, wanteds) = (ctPred ct, map ctPred others) - orig = ctOrigin ct + (wanted, wanteds) = (errorItemPred item, map errorItemPred others) + orig = errorItemOrigin item no_instance_msg | null others , Just (tc, _) <- splitTyConApp_maybe wanted @@ -1765,13 +1764,13 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) = text "Could not deduce" <+> pprParendType wanted | otherwise = text "Could not deduce:" <+> pprTheta wanteds -pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt ct ambigs) = +pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) = pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+> - pprArising (ctOrigin ct) $$ - text "prevents the constraint" <+> quotes (pprParendType $ ctPred ct) + pprArising (errorItemOrigin item) $$ + text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) <+> text "from being solved." pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) - (CannotResolveInstance ct unifiers candidates imp_errs suggs binds) + (CannotResolveInstance item unifiers candidates imp_errs suggs binds) = vcat [ pprTcSolverReportMsg ctxt no_inst_msg @@ -1794,11 +1793,11 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) , vcat $ map ppr imp_errs , vcat $ map ppr suggs ] where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred -- See Note [Highlighting ambiguous type variables] - (ambig_kvs, ambig_tvs) = ambigTkvsOfCt ct + (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred ambigs = ambig_kvs ++ ambig_tvs has_ambigs = not (null ambigs) useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) @@ -1812,9 +1811,9 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) no_inst_msg :: TcSolverReportMsg no_inst_msg | lead_with_ambig - = AmbiguityPreventsSolvingCt ct (ambig_kvs, ambig_tvs) + = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) | otherwise - = CouldNotDeduce useful_givens (ct :| []) Nothing + = CouldNotDeduce useful_givens (item :| []) Nothing -- Report "potential instances" only when the constraint arises -- directly from the user's use of an overloaded function @@ -1866,7 +1865,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) = hang (text "use a standalone 'deriving instance' declaration,") 2 (text "so you can specify the instance context yourself") -pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches unifiers) = +pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = vcat [ addArising orig $ (text "Overlapping instances for" @@ -1903,8 +1902,8 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches , text "when compiling the other instance declarations"] ])] where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred tyCoVars = tyCoVarsOfTypesList tys famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys @@ -1926,7 +1925,7 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches Just (clas', tys') -> clas' == clas && isJust (tcMatchTys tys tys') Nothing -> False -pprTcSolverReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = +pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) = vcat [ addArising orig (text "Unsafe overlapping instances for" <+> pprType (mkClassPred clas tys)) , sep [text "The matching instance is:", @@ -1939,8 +1938,8 @@ pprTcSolverReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = ] ] where - orig = ctOrigin ct - pred = ctPred ct + orig = errorItemOrigin item + pred = errorItemPred item (clas, tys) = getClassPredTys pred {- ********************************************************************* @@ -2475,6 +2474,9 @@ pprArising :: CtOrigin -> SDoc -- We've done special processing for TypeEq, KindEq, givens pprArising (TypeEqOrigin {}) = empty pprArising (KindEqOrigin {}) = empty +pprArising (AmbiguityCheckOrigin {}) = empty -- the "In the ambiguity check" context + -- is sufficient; this would just be + -- repetitive pprArising orig | isGivenOrigin orig = empty | otherwise = pprCtOrigin orig @@ -2614,9 +2616,10 @@ ea_looks_same ty1 ty2 exp act -- when the types really look the same. However, -- (TYPE 'LiftedRep) and Type both print the same way. -mk_ea_msg :: SolverReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg +mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind + -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg -- Constructs a "Couldn't match" message --- The (Maybe Ct) says whether this is the main top-level message (Just) +-- The (Maybe ErrorItem) says whether this is the main top-level message (Just) -- or a supplementary message (Nothing) mk_ea_msg ctxt at_top level (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) @@ -2625,13 +2628,13 @@ mk_ea_msg ctxt at_top level = Right $ KindMismatch { kmismatch_what = thing , kmismatch_expected = exp , kmismatch_actual = act } - | Just ct <- at_top + | Just item <- at_top , let mismatch = Mismatch - { mismatch_ea = True - , mismatch_ct = ct - , mismatch_ty1 = exp - , mismatch_ty2 = act } + { mismatch_ea = True + , mismatch_item = item + , mismatch_ty1 = exp + , mismatch_ty2 = act } = Right $ if expanded_syns then mkTcReportWithInfo mismatch [ea_expanded] |