X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=5db9c0ae0b53760d620fe0590903ea017f48efdf;hb=a42ead96edd42c362778e7420e45e911b379abd6;hp=beecfb427baf5bdc58b2c37879e68002ebc4ac66;hpb=f6f3819f37d73eeaaffa7bf45126ce73fb53e72b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index beecfb4..5db9c0a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -36,9 +36,9 @@ import Inst ( lookupInst, LookupInstResult(..), getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, - isIPDict, isInheritableInst, pprDFuns, pprDictsTheta + isInheritableInst, pprDFuns, pprDictsTheta ) -import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals ) +import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders ) import InstEnv ( lookupInstEnv, classInstances ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, @@ -47,7 +47,7 @@ import TcType ( TcTyVar, TcTyVarSet, ThetaType, tyVarsOfPred, tcEqType, pprPred ) import Id ( idType, mkUserLocal ) import Var ( TyVar ) -import Name ( getOccName, getSrcLoc ) +import Name ( Name, getOccName, getSrcLoc ) import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) @@ -57,6 +57,7 @@ import PrelNames ( splitName, fstName, sndName, integerTyConName, import Type ( zipTopTvSubst, substTheta, substTy ) import TysWiredIn ( pairTyCon, doubleTy ) import ErrUtils ( Message ) +import BasicTypes ( TopLevelFlag, isNotTopLevel ) import VarSet import VarEnv ( TidyEnv ) import FiniteMap @@ -508,6 +509,21 @@ you might not expect the addition to be done twice --- but it will if we follow the argument of Question 2 and generalise over ?y. +Question 4: top level +~~~~~~~~~~~~~~~~~~~~~ +At the top level, monomorhism makes no sense at all. + + module Main where + main = let ?x = 5 in print foo + + foo = woggle 3 + + woggle :: (?x :: Int) => Int -> Int + woggle y = ?x + y + +We definitely don't want (foo :: Int) with a top-level implicit parameter +(?x::Int) becuase there is no way to bind it. + Possible choices ~~~~~~~~~~~~~~~~ @@ -955,6 +971,8 @@ Plan D (a variant of plan B) tcSimplifyRestricted -- Used for restricted binding groups -- i.e. ones subject to the monomorphism restriction :: SDoc + -> TopLevelFlag + -> [Name] -- Things bound in this group -> TcTyVarSet -- Free in the type of the RHSs -> [Inst] -- Free in the RHSs -> TcM ([TcTyVar], -- Tyvars to quantify (zonked) @@ -963,7 +981,7 @@ tcSimplifyRestricted -- Used for restricted binding groups -- quantify over; by definition there are none. -- They are all thrown back in the LIE -tcSimplifyRestricted doc tau_tvs wanteds +tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- Zonk everything in sight = mappM zonkInst wanteds `thenM` \ wanteds' -> zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> @@ -984,8 +1002,6 @@ tcSimplifyRestricted doc tau_tvs wanteds constrained_tvs = tyVarsOfInsts constrained_dicts qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') `minusVarSet` constrained_tvs - try_me inst | isFreeWrtTyVars qtvs inst = Free - | otherwise = ReduceMe in traceTc (text "tcSimplifyRestricted" <+> vcat [ pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts, @@ -1005,11 +1021,30 @@ 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 + -- + -- At top level, we *do* squash methods becuase we want to + -- expose implicit parameters to the test that follows + let + is_nested_group = isNotTopLevel top_lvl + try_me inst | isFreeWrtTyVars qtvs inst, + (is_nested_group || isDict inst) = Free + | otherwise = ReduceMe + in reduceContextWithoutImprovement doc try_me wanteds' `thenM` \ (frees, binds, irreds) -> ASSERT( null irreds ) - extendLIEs frees `thenM_` - returnM (varSetElems qtvs, binds) + + -- See "Notes on implicit parameters, Question 4: top level" + if is_nested_group then + extendLIEs frees `thenM_` + returnM (varSetElems qtvs, binds) + else + let + (non_ips, bad_ips) = partition isClassDict frees + in + addTopIPErrs bndrs bad_ips `thenM_` + extendLIEs non_ips `thenM_` + returnM (varSetElems qtvs, binds) \end{code} @@ -1809,11 +1844,11 @@ We have to be careful here. If we are *given* d1:Ord a, and want to deduce (d2:C [a]) where class Ord a => C a where - instance Ord a => C [a] where ... + instance Ord [a] => C [a] where ... -Then we'll use the instance decl to deduce C [a] and then add the +Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the superclasses of C [a] to avails. But we must not overwrite the binding -for d1:Ord a (which is given) with a superclass selection or we'll just +for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just build a loop! Here's another variant, immortalised in tcrun020 @@ -1930,24 +1965,36 @@ tc_simplify_top is_interactive wanteds non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds) -- Collect together all the bad guys - bad_guys = non_stds ++ concat std_bads - (bad_ips, non_ips) = partition isIPDict bad_guys - (no_insts, ambigs) = partition no_inst non_ips - no_inst d = not (isTyVarDict d) - -- Previously, there was a more elaborate no_inst definition: - -- no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs - -- fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet - -- But that seems over-elaborate to me; it only bites for class decls with - -- fundeps like this: class C a b | -> b where ... + bad_guys = non_stds ++ concat std_bads + (non_ips, bad_ips) = partition isClassDict bad_guys + (ambigs, no_insts) = partition is_ambig non_ips + is_ambig d = not (tyVarsOfInst d `subVarSet` fixed_tvs) + fixed_tvs = oclose (fdPredsOfInsts irreds) emptyVarSet + -- If the dict has free type variables, it's almost certainly ambiguous, + -- and that's the first thing to fix. + -- Otherwise, addNoInstanceErrs does the right thing + -- I say "almost certain" because we might have + -- class C a b | a -> B where ... + -- plus an Inst (C Int x). Then the 'x' isn't ambiguous; it's just that + -- there's no instance decl for (C Int ...). Hence the oclose. in -- Report definite errors groupErrs (addNoInstanceErrs Nothing []) no_insts `thenM_` - addTopIPErrs bad_ips `thenM_` + strangeTopIPErrs bad_ips `thenM_` -- Deal with ambiguity errors, but only if - -- if there has not been an error so far; errors often - -- give rise to spurious ambiguous Insts + -- if there has not been an error so far: + -- errors often give rise to spurious ambiguous Insts. + -- For example: + -- f = (*) -- Monomorphic + -- g :: Num a => a -> a + -- g x = f x x + -- Here, we get a complaint when checking the type signature for g, + -- that g isn't polymorphic enough; but then we get another one when + -- dealing with the (Num a) context arising from f's definition; + -- we try to unify a with Int (to default it), but find that it's + -- already been unified with the rigid variable from g's type sig ifErrsM (returnM []) ( -- Complain about the ones that don't fall under @@ -2241,7 +2288,21 @@ addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts))) plural [x] = empty plural xs = char 's' -addTopIPErrs dicts +addTopIPErrs :: [Name] -> [Inst] -> TcM () +addTopIPErrs bndrs [] + = return () +addTopIPErrs bndrs ips + = addErrTcM (tidy_env, mk_msg tidy_ips) + where + (tidy_env, tidy_ips) = tidyInsts ips + mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from the monomorphic top-level binding(s) of"), + pprBinders bndrs <> colon], + nest 2 (vcat (map ppr_ip ips)), + monomorphism_fix] + ppr_ip ip = pprPred (dictPred ip) <+> pprInstLoc (instLoc ip) + +strangeTopIPErrs :: [Inst] -> TcM () +strangeTopIPErrs dicts -- Strange, becuase addTopIPErrs should have caught them all = groupErrs report tidy_dicts where (tidy_env, tidy_dicts) = tidyInsts dicts @@ -2259,7 +2320,6 @@ addNoInstanceErrs mb_what givens [] addNoInstanceErrs mb_what givens dicts = -- Some of the dicts are here because there is no instances -- and some because there are too many instances (overlap) - -- The first thing we do is separate them getDOpts `thenM` \ dflags -> tcGetInstEnvs `thenM` \ inst_envs -> let @@ -2275,7 +2335,8 @@ addNoInstanceErrs mb_what givens dicts | otherwise = case lookupInstEnv dflags inst_envs clas tys of -- The case of exactly one match and no unifiers means - -- a successful lookup. That can't happen here. + -- a successful lookup. That can't happen here, becuase + -- dicts only end up here if they didn't match in Inst.lookupInst #ifdef DEBUG ([m],[]) -> pprPanic "addNoInstanceErrs" (ppr dict) #endif @@ -2286,7 +2347,7 @@ addNoInstanceErrs mb_what givens dicts in -- Now generate a good message for the no-instance bunch - mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> + mk_probable_fix tidy_env2 no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> let no_inst_doc | null no_inst_dicts = empty | otherwise = vcat [addInstLoc no_inst_dicts heading, probable_fix] @@ -2302,7 +2363,7 @@ addNoInstanceErrs mb_what givens dicts = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> pprPred (dictPred dict))), sep [ptext SLIT("Matching instances") <> colon, - nest 2 (pprDFuns (dfuns ++ unifiers))], + nest 2 (vcat [pprDFuns dfuns, pprDFuns unifiers])], ASSERT( not (null matches) ) if not (isSingleton matches) then -- Two or more matches @@ -2315,21 +2376,27 @@ addNoInstanceErrs mb_what givens dicts where dfuns = [df | (_, (_,_,df)) <- matches] - mk_probable_fix tidy_env Nothing dicts -- Top level - = mkMonomorphismMsg tidy_env dicts - mk_probable_fix tidy_env (Just what) dicts -- Nested (type signatures, instance decls) - = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 fix1, nest 2 fix2]) + mk_probable_fix tidy_env dicts + = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 (vcat fixes)]) where - fix1 = sep [ptext SLIT("Add") <+> pprDictsTheta dicts, - ptext SLIT("to the") <+> what] + fixes = add_ors (fix1 ++ fix2) - fix2 | null instance_dicts = empty - | otherwise = ptext SLIT("Or add an instance declaration for") - <+> pprDictsTheta instance_dicts + fix1 = case mb_what of + Nothing -> [] -- Top level + Just what -> -- Nested (type signatures, instance decls) + [ sep [ ptext SLIT("add") <+> pprDictsTheta dicts, + ptext SLIT("to the") <+> what] ] + + fix2 | null instance_dicts = [] + | otherwise = [ ptext SLIT("add an instance declaration for") + <+> pprDictsTheta instance_dicts ] instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)] -- Insts for which it is worth suggesting an adding an instance declaration -- Exclude implicit parameters, and tyvar dicts + add_ors :: [SDoc] -> [SDoc] -- The empty case should not happen + add_ors [] = ptext SLIT("[No suggested fixes]") -- Strange + add_ors (f1:fs) = f1 : map (ptext SLIT("or") <+>) fs addTopAmbigErrs dicts -- Divide into groups that share a common set of ambiguous tyvars @@ -2343,40 +2410,39 @@ addTopAmbigErrs dicts report :: [(Inst,[TcTyVar])] -> TcM () report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars - = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> + = mkMonomorphismMsg tidy_env tvs `thenM` \ (tidy_env, mono_msg) -> setSrcSpan (instLocSrcSpan (instLoc inst)) $ -- the location of the first one will do for the err message addErrTcM (tidy_env, msg $$ mono_msg) where dicts = map fst pairs msg = sep [text "Ambiguous type variable" <> plural tvs <+> - pprQuotedList tvs <+> in_msg, + pprQuotedList tvs <+> in_msg, nest 2 (pprDictsInFull dicts)] - in_msg | isSingleton dicts = text "in the top-level constraint:" - | otherwise = text "in these top-level constraints:" + in_msg = text "in the constraint" <> plural dicts <> colon -mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message) +mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message) -- There's an error with these Insts; if they have free type variables -- it's probably caused by the monomorphism restriction. -- Try to identify the offending variable -- ASSUMPTION: the Insts are fully zonked -mkMonomorphismMsg tidy_env insts - | isEmptyVarSet inst_tvs - = returnM (tidy_env, empty) - | otherwise - = findGlobals inst_tvs tidy_env `thenM` \ (tidy_env, docs) -> +mkMonomorphismMsg tidy_env inst_tvs + = findGlobals (mkVarSet inst_tvs) tidy_env `thenM` \ (tidy_env, docs) -> returnM (tidy_env, mk_msg docs) - where - inst_tvs = tyVarsOfInsts insts - - mk_msg [] = empty -- This happens in things like - -- f x = show (read "foo") - -- whre monomorphism doesn't play any role + mk_msg [] = ptext SLIT("Probable fix: add a type signature that fixes these type variable(s)") + -- This happens in things like + -- 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), - ptext SLIT("Probable fix: give these definition(s) an explicit type signature")] + monomorphism_fix + ] +monomorphism_fix :: SDoc +monomorphism_fix = ptext SLIT("Probable fix:") <+> + (ptext SLIT("give these definition(s) an explicit type signature") + $$ ptext SLIT("or use -fno-monomorphism-restriction")) warnDefault dicts default_ty = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->