X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=f5afb360f61db482729290aa4c652470cf9d0f9d;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=9e1f4d7432b5ecbe323427661fac2327a0252f24;hpb=fcf37c94ff61dd721daed3515b492586f47af74a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 9e1f4d7..f5afb36 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -35,7 +35,7 @@ import Inst ( lookupInst, LookupInstResult(..), instBindingRequired, instCanBeGeneralised, newDictsFromOld, tcInstClassOp, getDictClassTys, isTyVarDict, - instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts, + instLoc, zonkInst, tidyInsts, tidyMoreInsts, Inst, pprInsts, pprInstsInFull, isIPDict, isInheritableInst ) @@ -63,7 +63,7 @@ import VarEnv ( TidyEnv ) import FiniteMap import Outputable import ListSetOps ( equivClasses ) -import Util ( zipEqual ) +import Util ( zipEqual, isSingleton ) import List ( partition ) import CmdLineOpts \end{code} @@ -741,7 +741,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie = -- Step 1 mappM zonkInst givens `thenM` \ givens' -> mappM zonkInst wanteds `thenM` \ wanteds' -> - get_qtvs `thenM` \ qtvs' -> + get_qtvs `thenM` \ qtvs' -> -- Step 2 let @@ -785,14 +785,13 @@ tcSimplifyRestricted doc tau_tvs wanteds -- foo = f (3::Int) -- We want to infer the polymorphic type -- foo :: forall b. b -> b - let - try_me inst = ReduceMe -- Reduce as far as we can. Don't stop at - -- dicts; the idea is to get rid of as many type - -- variables as possible, and we don't want to stop - -- at (say) Monad (ST s), because that reduces - -- immediately, with no constraint on s. - in - simpleReduceLoop doc try_me wanteds `thenM` \ (_, _, constrained_dicts) -> + + -- 'reduceMe': Reduce as far as we can. Don't stop at + -- dicts; the idea is to get rid of as many type + -- variables as possible, and we don't want to stop + -- at (say) Monad (ST s), because that reduces + -- immediately, with no constraint on s. + simpleReduceLoop doc reduceMe wanteds `thenM` \ (foo_frees, foo_binds, constrained_dicts) -> -- Next, figure out the tyvars we will quantify over zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> @@ -802,6 +801,10 @@ tcSimplifyRestricted doc tau_tvs wanteds qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs) `minusVarSet` constrained_tvs in + traceTc (text "tcSimplifyRestricted" <+> vcat [ + pprInsts wanteds, pprInsts foo_frees, pprInsts constrained_dicts, + ppr foo_binds, + ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_` -- The first step may have squashed more methods than -- necessary, so try again, this time knowing the exact @@ -816,19 +819,28 @@ tcSimplifyRestricted doc tau_tvs wanteds -- Remember that we may need to do *some* simplification, to -- (for example) squash {Monad (ST s)} into {}. It's not enough -- just to float all constraints - mappM zonkInst wanteds `thenM` \ wanteds' -> + restrict_loop doc qtvs wanteds + -- We still need a loop because improvement can take place + -- E.g. if we have (C (T a)) and the instance decl + -- instance D Int b => C (T a) where ... + -- and there's a functional dependency for D. Then we may improve + -- the tyep variable 'b'. + +restrict_loop doc qtvs wanteds + = mappM zonkInst wanteds `thenM` \ wanteds' -> + zonkTcTyVarsAndFV (varSetElems qtvs) `thenM` \ qtvs' -> let - try_me inst | isFreeWrtTyVars qtvs inst = Free - | otherwise = ReduceMe + try_me inst | isFreeWrtTyVars qtvs' inst = Free + | otherwise = ReduceMe in reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> - ASSERT( no_improvement ) - ASSERT( null irreds ) - -- No need to loop because simpleReduceLoop will have - -- already done any improvement necessary - - extendLIEs frees `thenM_` - returnM (varSetElems qtvs, binds) + if no_improvement then + ASSERT( null irreds ) + extendLIEs frees `thenM_` + returnM (varSetElems qtvs', binds) + else + restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) -> + returnM (qtvs1, binds `AndMonoBinds` binds1) \end{code} @@ -907,12 +919,10 @@ this bracket again at its usage site. \begin{code} tcSimplifyBracket :: [Inst] -> TcM () tcSimplifyBracket wanteds - = simpleReduceLoop doc try_me wanteds `thenM_` + = simpleReduceLoop doc reduceMe wanteds `thenM_` returnM () - where - doc = text "tcSimplifyBracket" - try_me inst = ReduceMe + doc = text "tcSimplifyBracket" \end{code} @@ -1608,6 +1618,8 @@ It's OK: the final zonking stage should zap y to (), which is fine. \begin{code} tcSimplifyTop :: [Inst] -> TcM TcDictBinds +-- The TcLclEnv should be valid here, solely to improve +-- error message generation for the monomorphism restriction tcSimplifyTop wanteds = getLclEnv `thenM` \ lcl_env -> traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_` @@ -1953,15 +1965,25 @@ addTopInstanceErrs tidy_env tidy_dicts addTopAmbigErrs (tidy_env, tidy_dicts) - = groupErrs report tidy_dicts +-- Divide into groups that share a common set of ambiguous tyvars + = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) where - report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> - addErrTcM (tidy_env, mk_msg dicts $$ mono_msg) - mk_msg dicts = addInstLoc dicts $ - sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs, - nest 2 (text "in the constraint" <> plural dicts <+> pprInsts dicts)] - where - ambig_tvs = varSetElems (tyVarsOfInsts dicts) + tvs_of :: Inst -> [TcTyVar] + tvs_of d = varSetElems (tyVarsOfInst d) + cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 + + report :: [(Inst,[TcTyVar])] -> TcM () + report pairs@((_,tvs) : _) -- The pairs share a common set of ambiguous tyvars + = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> + addErrTcM (tidy_env, msg $$ mono_msg) + where + dicts = map fst pairs + msg = sep [text "Ambiguous type variable" <> plural tvs <+> + pprQuotedList tvs <+> in_msg, + nest 2 (pprInstsInFull dicts)] + in_msg | isSingleton dicts = text "in the top-level constraint:" + | otherwise = text "in these top-level constraints:" + mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message) -- There's an error with these Insts; if they have free type variables @@ -1982,7 +2004,8 @@ mkMonomorphismMsg tidy_env insts -- f x = show (read "foo") -- whre monomorphism doesn't play any role mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"), - nest 2 (vcat docs)] + nest 2 (vcat docs), + ptext SLIT("Probable fix: give these definition(s) an explicit type signature")] warnDefault dicts default_ty = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->