- mk_no_inst_err :: [PredType] -> SDoc
- mk_no_inst_err wanteds
- | Just givens <- getUserGivens ctxt
- = vcat [ addArising orig $ couldNotDeduce givens wanteds
- , show_fixes (fix1 : fixes2) ]
-
- | otherwise -- Top level
- = vcat [ addArising orig $
- ptext (sLit "No instance") <> plural wanteds
- <+> ptext (sLit "for") <+> pprTheta wanteds
- , show_fixes fixes2 ]
-
- where
- fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
- <+> ptext (sLit "to the context of")
- , nest 2 $ pprErrCtxtLoc ctxt ]
-
- fixes2 | null instance_dicts = []
- | otherwise = [sep [ptext (sLit "add an instance declaration for"),
- pprTheta instance_dicts]]
- instance_dicts = filterOut isTyVarClassPred wanteds
- -- Insts for which it is worth suggesting an adding an
- -- instance declaration. Exclude tyvar dicts.
+ givens = getUserGivens ctxt
+ overlapping_givens = unifiable_givens givens
+
+ unifiable_givens [] = []
+ unifiable_givens (gg:ggs)
+ | Just ggdoc <- matchable gg
+ = ggdoc : unifiable_givens ggs
+ | otherwise
+ = unifiable_givens ggs
+
+ matchable (evvars,gloc)
+ = case ev_vars_matching of
+ [] -> Nothing
+ _ -> Just $ hang (pprTheta ev_vars_matching)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+ where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+ ev_var_matches (ClassP clas' tys')
+ | clas' == clas
+ , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+ = True
+ ev_var_matches (ClassP clas' tys') =
+ any ev_var_matches (immSuperClasses clas' tys')
+ ev_var_matches _ = False
+
+
+reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
+
+----------------------
+quickFlattenTy :: TcType -> TcM TcType
+-- See Note [Flattening in error message generation]
+quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
+quickFlattenTy ty@(TyVarTy {}) = return ty
+quickFlattenTy ty@(ForAllTy {}) = return ty -- See
+quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
+ -- Don't flatten because of the danger or removing a bound variable
+quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
+ ; fy2 <- quickFlattenTy ty2
+ ; return (AppTy fy1 fy2) }
+quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
+ ; fy2 <- quickFlattenTy ty2
+ ; return (FunTy fy1 fy2) }
+quickFlattenTy (TyConApp tc tys)
+ | not (isSynFamilyTyCon tc)
+ = do { fys <- mapM quickFlattenTy tys
+ ; return (TyConApp tc fys) }
+ | otherwise
+ = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
+ -- Ignore the arguments of the type family funtys
+ ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
+ ; flat_resttys <- mapM quickFlattenTy resttys
+ ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
+\end{code}