Ensure that instance overlap errors are report properly

This (annoyingly) requires us to re-flatten the class predicate.
See Note [Flattening in error message generation]

compiler/typecheck/TcErrors.lhs

@@ -573,43 +573,10 @@ Warn of loopy local equalities that were dropped.
 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()	
 reportDictErrs ctxt wanteds orig
   = do { inst_envs <- tcGetInstEnvs
-       ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
-       ; unless (null others) $
-         addErrorReport ctxt (mk_no_inst_err others) 
-       ; mapM_ (addErrorReport ctxt) overlaps }
+       ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
+       ; unless (null non_overlaps) $
+         addErrorReport ctxt (mk_no_inst_err non_overlaps) }
   where
-    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
-		-- The case of exactly one match and no unifiers means a
-		-- successful lookup.  That can't happen here, because dicts
-		-- only end up here if they didn't match in Inst.lookupInst
-		([_],[])
-		 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
-		res -> Right (mk_overlap_msg pred res)
-    check_overlap _ _ = panic "check_overlap"
-
-    mk_overlap_msg pred (matches, unifiers)
-      = ASSERT( not (null matches) )
-        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
-				<+> pprPred pred)
-    	     ,	sep [ptext (sLit "Matching instances") <> colon,
-    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
-	     ,	if not (isSingleton matches)
-    		then 	-- Two or more matches
-		     empty
-    		else 	-- One match, plus some unifiers
-		ASSERT( not (null unifiers) )
-		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
-	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
-			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
-			      ptext (sLit "when compiling the other instance declarations")])]
-      where
-    	ispecs = [ispec | (ispec, _) <- matches]
-
     mk_no_inst_err :: [PredType] -> SDoc
     mk_no_inst_err wanteds
       | Just givens <- getUserGivens ctxt
@@ -639,6 +606,94 @@ reportDictErrs ctxt wanteds orig
 	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
+		-- The case of exactly one match and no unifiers means a
+		-- successful lookup.  That can't happen here, because dicts
+		-- only end up here if they didn't match in Inst.lookupInst
+		([_],[])
+		 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
+                res          -> do { addErrorReport ctxt (mk_overlap_msg res)
+                                   ; return Nothing } }
+  where
+    mk_overlap_msg (matches, unifiers)
+      = ASSERT( not (null matches) )
+        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
+				<+> pprPred pred)
+    	     ,	sep [ptext (sLit "Matching instances") <> colon,
+    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+	     ,	if not (isSingleton matches)
+    		then 	-- Two or more matches
+		     empty
+    		else 	-- One match, plus some unifiers
+		ASSERT( not (null unifiers) )
+		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
+	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
+			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+			      ptext (sLit "when compiling the other instance declarations")])]
+      where
+    	ispecs = [ispec | (ispec, _) <- matches]
+
+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}
+
+Note [Flattening in error message generation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (C (Maybe (F x))), where F is a type function, and we have
+instances
+                C (Maybe Int) and C (Maybe a)
+Since (F x) might turn into Int, this is an overlap situation, and
+indeed (because of flattening) the main solver will have refrained
+from solving.  But by the time we get to error message generation, we've
+un-flattened the constraint.  So we must *re*-flatten it before looking
+up in the instance environment, lest we only report one matching
+instance when in fact there are two.
+
+Re-flattening is pretty easy, because we don't need to keep track of
+evidence.  We don't re-use the code in TcCanonical because that's in
+the TcS monad, and we are in TcM here.
+
+Note [Quick-flatten polytypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
+flattening any further.  After all, there can be no instance declarations
+that match such things.  And flattening under a for-all is problematic
+anyway; consider C (forall a. F a)
+
+\begin{code}
 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 reportAmbigErrs ctxt skols ambigs 
 -- Divide into groups that share a common set of ambiguous tyvars
@@ -778,7 +833,6 @@ We want to give a reasonably helpful error message for ambiguity
 arising from *runtime* skolems in the debugger.  These
 are created by in RtClosureInspect.zonkRTTIType.  
 
-
 %************************************************************************
 %*									*
                  Error from the canonicaliser