X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=911e2ff12d8a7f6c4d7a86da0040bb0ce6d19dbd;hb=0560e796f1d813582e066a5f2bec2684c71df44d;hp=7311ae0be82c2bca14d14a707bb84016aaa87302;hpb=d4b95ea994e850f2c85e418b5625874fd25b0ebf;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 7311ae0..911e2ff 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1202,9 +1202,22 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	; gbl_tvs' <- tcGetGlobalTyVars
 	; constrained_dicts' <- mappM zonkInst constrained_dicts
 
-	; let constrained_tvs' = tyVarsOfInsts constrained_dicts'
-	      qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
-			 `minusVarSet` constrained_tvs'
+	; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs'
+				-- As in tcSimplifyInfer
+
+		-- Do not quantify over constrained type variables:
+		-- this is the monomorphism restriction
+	      constrained_tvs' = tyVarsOfInsts constrained_dicts'
+	      qtvs = qtvs1 `minusVarSet` constrained_tvs'
+	      pp_bndrs = pprWithCommas (quotes . ppr) bndrs
+
+	-- Warn in the mono
+	; warn_mono <- doptM Opt_WarnMonomorphism
+	; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
+		 (vcat[ ptext SLIT("the Monomorphism Restriction applies to the binding")
+				<> plural bndrs <+> ptext SLIT("for") <+> pp_bndrs,
+			ptext SLIT("Consider giving a type signature for") <+> pp_bndrs])
+
 	; traceTc (text "tcSimplifyRestricted" <+> vcat [
 		pprInsts wanteds, pprInsts constrained_dicts',
 		ppr _binds,
@@ -2320,8 +2333,8 @@ disambigGroup default_tys dicts
 getDefaultTys :: Bool -> Bool -> TcM [Type]
 getDefaultTys extended_deflts ovl_strings
   = do	{ mb_defaults <- getDeclaredDefaultTys
-	; case mb_defaults of
-	   Just tys -> return tys	-- User-supplied defaults
+	; case mb_defaults of {
+	   Just tys -> return tys ;	-- User-supplied defaults
 	   Nothing  -> do
 
 	-- No use-supplied default
@@ -2334,7 +2347,7 @@ getDefaultTys extended_deflts ovl_strings
 			++
 		  [integer_ty,doubleTy]
 			++
-		  opt_deflt ovl_strings string_ty) }}
+		  opt_deflt ovl_strings string_ty) } } }
   where
     opt_deflt True  ty = [ty]
     opt_deflt False ty = []