From: simonpj <unknown>
Date: Thu, 22 Mar 2001 11:20:36 +0000 (+0000)
Subject: [project @ 2001-03-22 11:20:36 by simonpj]
X-Git-Tag: Approximately_9120_patches~2342
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f4742cfc2308a9816b2340a8ab2508821b587903;p=ghc-hetmet.git

[project @ 2001-03-22 11:20:36 by simonpj]
Improve error message for ambiguity
---

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 445c519..ddd4f76 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -48,7 +48,7 @@ import Type		( Type, Kind, PredType(..), ThetaType, SigmaType, TauType,
 			  tyVarsOfType, tyVarsOfPred, mkForAllTys,
 			  isUnboxedTupleType, isForAllTy, isIPPred
 			)
-import PprType		( pprType, pprPred )
+import PprType		( pprType, pprTheta, pprPred )
 import Subst		( mkTopTyVarSubst, substTy )
 import CoreFVs		( idFreeTyVars )
 import Id		( mkLocalId, idName, idType )
@@ -565,12 +565,23 @@ checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau
     tau_vars	      = tyVarsOfType tau
     extended_tau_vars = grow theta tau_vars
 
+	-- Hack alert.  If there are no tyvars, (ppr sigma_ty) will print
+	-- something strange like {Eq k} -> k -> k, because there is no
+	-- ForAll at the top of the type.  Since this is going to the user
+	-- we want it to look like a proper Haskell type even then; hence the hack
+	-- 
+	-- This shows up in the complaint about
+	--	case C a where
+	--	  op :: Eq a => a -> a
+    ppr_sigma	      | null forall_tyvars = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
+		      | otherwise	   = ppr sigma_ty 
+
     is_ambig ct_var   = (ct_var `elem` forall_tyvars) &&
 		        not (ct_var `elemVarSet` extended_tau_vars)
     is_free ct_var    = not (ct_var `elem` forall_tyvars)
     
-    check_pred pred = checkTc (not any_ambig)                 (ambigErr pred sigma_ty) `thenTc_`
-	    	      checkTc (isIPPred pred || not all_free) (freeErr  pred sigma_ty)
+    check_pred pred = checkTc (not any_ambig)                 (ambigErr pred ppr_sigma) `thenTc_`
+	    	      checkTc (isIPPred pred || not all_free) (freeErr  pred ppr_sigma)
              where 
 	    	ct_vars	  = varSetElems (tyVarsOfPred pred)
 	    	all_free  = all is_free ct_vars
@@ -965,16 +976,16 @@ wrongThingErr expected thing name
     pp_thing (ATcId _)  	  = ptext SLIT("Local identifier")
     pp_thing (AThing _) 	  = ptext SLIT("Utterly bogus")
 
-ambigErr pred ty
+ambigErr pred ppr_ty
   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
-	 nest 4 (ptext SLIT("for the type:") <+> ppr ty),
+	 nest 4 (ptext SLIT("for the type:") <+> ppr_ty),
 	 nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
 		 ptext SLIT("must be reachable from the type after the =>"))]
 
-freeErr pred ty
+freeErr pred ppr_ty
   = sep [ptext SLIT("The constraint") <+> quotes (pprPred pred) <+>
 		   ptext SLIT("does not mention any of the universally quantified type variables"),
-	 nest 4 (ptext SLIT("in the type") <+> quotes (ppr ty))
+	 nest 4 (ptext SLIT("in the type") <+> quotes ppr_ty)
     ]
 
 polyArgTyErr ty = ptext SLIT("Illegal polymorphic type as argument:")   <+> ppr ty