Reinstate monomorphism-restriction warnings
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 12 Oct 2015 15:23:56 +0000 (16:23 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 12 Oct 2015 15:24:17 +0000 (16:24 +0100)
This patch is driven by Trac #10935, and reinstates the
-fwarn-monomorphism-restriction warning.  It was first lost in 2010:
d2ce0f52d "Super-monster patch implementing the new typechecker -- at
last"

I think the existing documentation is accurate; it is not even
turned on by -Wall.

I added one test.

compiler/typecheck/TcBinds.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcSimplify.hs
testsuite/tests/typecheck/should_compile/T10935.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T10935.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index 48abcc8..f927ffa 100644 (file)
@@ -653,7 +653,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
              sig_qtvs   = [ tv | (_, Just sig, _) <- mono_infos
                                , (_, tv) <- sig_tvs sig ]
        ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
-       ; (qtvs, givens, _mr_bites, ev_binds)
+       ; (qtvs, givens, ev_binds)
                  <- simplifyInfer tclvl mono sig_qtvs name_taus wanted
 
        ; let inferred_theta = map evVarPred givens
index b4bc782..529e6b2 100644 (file)
@@ -76,7 +76,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
 
        ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
 
-       ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
+       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
 
        ; (ex_vars, prov_dicts) <- tcCollectEx lpat'
        ; let univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
index 2c2e5d7..e2c8d4c 100644 (file)
@@ -1791,13 +1791,13 @@ tcRnExpr hsc_env rdr_expr
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
     ((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $
                                         tcInferRho rn_expr ;
-    ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
-                                      {-# SCC "simplifyInfer" #-}
-                                      simplifyInfer tclvl
-                                                    False {- No MR for now -}
-                                                    []    {- No sig vars -}
-                                                    [(fresh_it, res_ty)]
-                                                    lie ;
+    ((qtvs, dicts, _), lie_top) <- captureConstraints $
+                                   {-# SCC "simplifyInfer" #-}
+                                   simplifyInfer tclvl
+                                                 False {- No MR for now -}
+                                                 []    {- No sig vars -}
+                                                 [(fresh_it, res_ty)]
+                                                 lie ;
     -- Wanted constraints from static forms
     stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
 
index 8babe0f..720fdb9 100644 (file)
@@ -18,6 +18,7 @@ import Bag
 import Class         ( classKey )
 import Class         ( Class )
 import DynFlags      ( ExtensionFlag( Opt_AllowAmbiguousTypes )
+                     , WarningFlag ( Opt_WarnMonomorphism )
                      , DynFlags( solverIterations ) )
 import Inst
 import Id            ( idType )
@@ -393,16 +394,13 @@ simplifyInfer :: TcLevel               -- Used when generating the constraints
               -> WantedConstraints
               -> TcM ([TcTyVar],    -- Quantify over these type variables
                       [EvVar],      -- ... and these constraints (fully zonked)
-                      Bool,         -- The monomorphism restriction did something
-                                    --   so the results type is not as general as
-                                    --   it could be
                       TcEvBinds)    -- ... binding these evidence variables
 simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
   | isEmptyWC wanteds
   = do { gbl_tvs <- tcGetGlobalTyVars
        ; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus))
        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
-       ; return (qtkvs, [], False, emptyTcEvBinds) }
+       ; return (qtkvs, [], emptyTcEvBinds) }
 
   | otherwise
   = do { traceTc "simplifyInfer {"  $ vcat
@@ -473,8 +471,8 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
          -- Decide what type variables and constraints to quantify
        ; zonked_taus <- mapM (TcM.zonkTcType . snd) name_taus
        ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus
-       ; (qtvs, bound_theta, mr_bites)
-             <- decideQuantification apply_mr sig_qtvs quant_pred_candidates zonked_tau_tvs
+       ; (qtvs, bound_theta) <- decideQuantification apply_mr sig_qtvs name_taus
+                                                     quant_pred_candidates zonked_tau_tvs
 
          -- Emit an implication constraint for the
          -- remaining constraints from the RHS
@@ -525,11 +523,10 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
               , ptext (sLit "promote_tvs=") <+> ppr promote_tvs
               , ptext (sLit "bound_theta =") <+> vcat [ ppr v <+> dcolon <+> ppr (idType v)
                                                         | v <- bound_ev_vars]
-              , ptext (sLit "mr_bites =") <+> ppr mr_bites
               , ptext (sLit "qtvs =") <+> ppr qtvs
               , ptext (sLit "implic =") <+> ppr implic ]
 
-       ; return ( qtvs, bound_ev_vars, mr_bites, TcEvBinds ev_binds_var) }
+       ; return ( qtvs, bound_ev_vars, TcEvBinds ev_binds_var) }
 
 {-
 ************************************************************************
@@ -567,20 +564,30 @@ and the quantified constraints are empty.
 decideQuantification
     :: Bool                       -- Apply monomorphism restriction
     -> [TcTyVar]
+    -> [(Name, TcTauType)]        -- Variables to be generalised (just for error msg)
     -> [PredType] -> TcTyVarSet   -- Constraints and type variables from RHS
     -> TcM ( [TcTyVar]       -- Quantify over these tyvars (skolems)
-           , [PredType]      -- and this context (fully zonked)
-           , Bool )          -- Did the MR bite?
+           , [PredType])     -- and this context (fully zonked)
 -- See Note [Deciding quantification]
-decideQuantification apply_mr sig_qtvs constraints zonked_tau_tvs
+decideQuantification apply_mr sig_qtvs name_taus constraints zonked_tau_tvs
   | apply_mr     -- Apply the Monomorphism restriction
   = do { gbl_tvs <- tcGetGlobalTyVars
        ; let constrained_tvs = tyVarsOfTypes constraints
              mono_tvs = gbl_tvs `unionVarSet` constrained_tvs
              mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs
        ; qtvs <- quantify_tvs mono_tvs zonked_tau_tvs
-       ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs, ppr qtvs])
-       ; return (qtvs, [], mr_bites) }
+       ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs
+                                                , ppr qtvs, ppr mr_bites])
+
+       -- Warn about the monomorphism restriction
+       ; warn_mono <- woptM Opt_WarnMonomorphism
+       ; warnTc (warn_mono && mr_bites) $
+         hang (ptext (sLit "The Monomorphism Restriction applies to the binding")
+               <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs)
+             2 (ptext (sLit "Consider giving a type signature for")
+                <+> if isSingleton bndrs then pp_bndrs else ptext (sLit "these binders"))
+
+       ; return (qtvs, []) }
 
   | otherwise
   = do { gbl_tvs <- tcGetGlobalTyVars
@@ -596,9 +603,11 @@ decideQuantification apply_mr sig_qtvs constraints zonked_tau_tvs
 
        ; traceTc "decideQuantification 2" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs
                                                 , ppr tau_tvs_plus, ppr qtvs, ppr min_theta])
-       ; return (qtvs, min_theta, False) }
+       ; return (qtvs, min_theta) }
 
   where
+    bndrs    = map fst name_taus
+    pp_bndrs = pprWithCommas (quotes . ppr) bndrs
     quantify_tvs mono_tvs tau_tvs   -- See Note [Which type variable to quantify]
       | null sig_qtvs = quantifyTyVars mono_tvs tau_tvs
       | otherwise     = quantifyTyVars (mono_tvs `delVarSetList`    sig_qtvs)
diff --git a/testsuite/tests/typecheck/should_compile/T10935.hs b/testsuite/tests/typecheck/should_compile/T10935.hs
new file mode 100644 (file)
index 0000000..9817ec8
--- /dev/null
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-}
+
+module T10935 where
+
+f x = let y = x+1 in (y,y)
diff --git a/testsuite/tests/typecheck/should_compile/T10935.stderr b/testsuite/tests/typecheck/should_compile/T10935.stderr
new file mode 100644 (file)
index 0000000..0519ecb
--- /dev/null
@@ -0,0 +1 @@
\ No newline at end of file
index 8f6aeae..42af77a 100644 (file)
@@ -477,3 +477,4 @@ test('update-existential', normal, compile, [''])
 test('T10347', expect_broken(10347), compile, [''])
 test('T10770a', expect_broken(10770), compile, [''])
 test('T10770b', expect_broken(10770), compile, [''])
+test('T10935', normal, compile, [''])