Commit f8fbf385 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Reinstate monomorphism-restriction warnings

This patch is driven by Trac #10935, and reinstates the
-fwarn-monomorphism-restriction warning.  It was first lost in 2010:
d2ce0f52 "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.
parent 6b7bad92
......@@ -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
......
......@@ -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
......
......@@ -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 ;
......
......@@ -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)
......
{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-}
module T10935 where
f x = let y = x+1 in (y,y)
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment