- check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
- -- Right msg => overlap message
- -- Left inst => no instance
- check_overlap inst_envs pred@(ClassP clas tys)
- = case lookupInstEnv inst_envs clas tys of
- ([], _) -> Left pred -- No match
+ mk_no_inst_err :: [PredType] -> SDoc
+ mk_no_inst_err wanteds
+ | null givens -- Top level
+ = vcat [ addArising orig $
+ ptext (sLit "No instance") <> plural min_wanteds
+ <+> ptext (sLit "for") <+> pprTheta min_wanteds
+ , show_fixes (fixes2 ++ fixes3) ]
+
+ | otherwise
+ = vcat [ couldNotDeduce givens (min_wanteds, orig)
+ , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
+ where
+ givens = getUserGivens ctxt
+ min_wanteds = mkMinimalBySCs wanteds
+ fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
+ <+> ptext (sLit "to the context of")
+ , nest 2 $ pprErrCtxtLoc ctxt ]
+
+ fixes2 = case instance_dicts of
+ [] -> []
+ [_] -> [sep [ptext (sLit "add an instance declaration for"),
+ pprTheta instance_dicts]]
+ _ -> [sep [ptext (sLit "add instance declarations for"),
+ pprTheta instance_dicts]]
+ fixes3 = case orig of
+ DerivOrigin -> [drv_fix]
+ _ -> []
+
+ instance_dicts = filterOut isTyVarClassPred min_wanteds
+ -- Insts for which it is worth suggesting an adding an
+ -- instance declaration. Exclude tyvar dicts.
+
+ drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
+ nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
+
+ show_fixes :: [SDoc] -> SDoc
+ show_fixes [] = empty
+ show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
+ nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
+
+reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
+ -> PredType -> TcM (Maybe PredType)
+-- Report an overlap error if this class constraint results
+-- from an overlap (returning Nothing), otherwise return (Just pred)
+reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
+ = do { tys_flat <- mapM quickFlattenTy tys
+ -- Note [Flattening in error message generation]
+
+ ; case lookupInstEnv inst_envs clas tys_flat of
+ ([], _) -> return (Just pred) -- No match