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

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index d433a8c..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,