From 0560e796f1d813582e066a5f2bec2684c71df44d Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 25 Apr 2007 10:18:32 +0000
Subject: [PATCH] Add -fwarn-monomorphism-restriction (on by default) to warn
 when the MR is used

Users often trip up on the Dreaded Monomorphism Restriction.  This
warning flag tells you when the MR springs into action.

Currently it's on by default, but we could change that.
---
 compiler/main/DynFlags.hs         |    3 +++
 compiler/typecheck/TcRnMonad.lhs  |    2 +-
 compiler/typecheck/TcSimplify.lhs |   19 ++++++++++++++++---
 docs/users_guide/flags.xml        |    7 +++++++
 docs/users_guide/using.xml        |   14 ++++++++++++++
 5 files changed, 41 insertions(+), 4 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index fa5ae4b..d5f5edd 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -148,6 +148,7 @@ data DynFlag
    | Opt_WarnOverlappingPatterns
    | Opt_WarnSimplePatterns
    | Opt_WarnTypeDefaults
+   | Opt_WarnMonomorphism
    | Opt_WarnUnusedBinds
    | Opt_WarnUnusedImports
    | Opt_WarnUnusedMatches
@@ -583,6 +584,7 @@ standardWarnings
 	Opt_WarnOverlappingPatterns,
 	Opt_WarnMissingFields,
 	Opt_WarnMissingMethods,
+	Opt_WarnMonomorphism,
 	Opt_WarnDuplicateExports
       ]
 
@@ -1023,6 +1025,7 @@ fFlags = [
   ( "warn-overlapping-patterns", 	Opt_WarnOverlappingPatterns ),
   ( "warn-simple-patterns",      	Opt_WarnSimplePatterns ),
   ( "warn-type-defaults",        	Opt_WarnTypeDefaults ),
+  ( "warn-monomorphism-restriction",   	Opt_WarnMonomorphism ),
   ( "warn-unused-binds",         	Opt_WarnUnusedBinds ),
   ( "warn-unused-imports",       	Opt_WarnUnusedImports ),
   ( "warn-unused-matches",       	Opt_WarnUnusedMatches ),
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index f0303c1..e2cbc22 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -732,7 +732,7 @@ addWarnTcM :: (TidyEnv, Message) -> TcM ()
 addWarnTcM (env0, msg)
  = do { ctxt <- getErrCtxt ;
 	ctxt_msgs <- do_ctxt env0 ctxt ;
-	addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
+	addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
 
 warnTc :: Bool -> Message -> TcM ()
 warnTc warn_if_true warn_msg
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,
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 1de581d..5426ad8 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -839,6 +839,13 @@
 	  </row>
 
 	  <row>
+	    <entry><option>-fwarn-monomorphism-restriction</option></entry>
+	    <entry>warn when the Monomorphism Restriction is applied</entry>
+	    <entry>dynamic</entry>
+	    <entry><option>-fno-warn-monomorphism-restriction</option></entry>
+	  </row>
+
+	  <row>
 	    <entry><option>-fwarn-unused-binds</option></entry>
 	    <entry>warn about bindings that are unused</entry>
 	    <entry>dynamic</entry>
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index 82d7afe..88f9e5e 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1136,6 +1136,20 @@ f "2"    = 2
       </varlistentry>
 
       <varlistentry>
+	<term><option>-fwarn-monomorphism-restriction</option>:</term>
+	<listitem>
+	  <indexterm><primary><option>-fwarn-monomorphism-restriction</option></primary></indexterm>
+	  <indexterm><primary>monomorphism restriction, warning</primary></indexterm>
+	  <para>Have the compiler warn/inform you where in your source
+          the Haskell Monomorphism Restriction is applied.  If applied silently
+	  the MR can give rise to unexpected behaviour, so it can be helpful
+	  to have an explicit warning that it is being applied.</para>
+
+	  <para>This warning is on by default.</para>
+	</listitem>
+      </varlistentry>
+
+      <varlistentry>
 	<term><option>-fwarn-unused-binds</option>:</term>
 	<listitem>
 	  <indexterm><primary><option>-fwarn-unused-binds</option></primary></indexterm>
-- 
1.7.10.4