X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=cf2974856180d35d367c8ee77ed5844524fe2ca3;hb=7a7a635688c768eb7bbeec37768d4d963581c9db;hp=cd3da492bf6016d7ad0431e33387013c621c6990;hpb=296058a1cafa80dec0b3f998348bce7c65f668b0;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index cd3da49..cf29748 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -2856,6 +2856,7 @@ disambiguate doc interactive dflags insts
 
   where
    extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags
+   		       -- See also Trac #1974
    ovl_strings = dopt Opt_OverloadedStrings dflags
 
    unaries :: [(Inst, Class, TcTyVar)]  -- (C tv) constraints
@@ -2902,12 +2903,16 @@ disambigGroup :: [Type]			-- The default types
 	      -> TcM ()	-- Just does unification, to fix the default types
 
 disambigGroup default_tys dicts
-  = try_default default_tys
+  = do { mb_chosen_ty <- try_default default_tys
+       ; case mb_chosen_ty of
+            Nothing        -> return ()
+            Just chosen_ty -> do { unifyType chosen_ty (mkTyVarTy tyvar) 
+	    	 	         ; warnDefault dicts chosen_ty } }
   where
     (_,_,tyvar) = ASSERT(not (null dicts)) head dicts	-- Should be non-empty
     classes = [c | (_,c,_) <- dicts]
 
-    try_default [] = return ()
+    try_default [] = return Nothing
     try_default (default_ty : default_tys)
       = tryTcLIE_ (try_default default_tys) $
     	do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes]
@@ -2917,10 +2922,7 @@ disambigGroup default_tys dicts
 		-- For example, if Real a is reqd, but the only type in the
 		-- default list is Int.
 
-		-- After this we can't fail
-	   ; warnDefault dicts default_ty
-	   ; unifyType default_ty (mkTyVarTy tyvar) 
-	   ; return () -- TOMDO: do something with the coercion
+	   ; return (Just default_ty) -- TOMDO: do something with the coercion
 	   }