From c36a2f9b4fd728e359da3c700938cc56eef90738 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 4 Feb 2005 17:24:09 +0000 Subject: [PATCH] [project @ 2005-02-04 17:24:01 by simonpj] ------------------------------------------------------ Report top-level implicit parameter errors more nicely ------------------------------------------------------ Consider module Main where main = let ?x = 5 in print foo foo = woggle 3 woggle :: (?x :: Int) => Int -> Int woggle y = ?x + y GHC's current rules say that 'foo' is monomorphic, so we get foo :: Int but we also get an unbound top-level constraint (?x::Int). GHC 6.2 emits a message like: Unbound implicit parameter (?x::Int) arising from use of `woggle' at ... The point is that THERE IS NO WAY FOR THIS CONSTRAINT TO GET BOUND, because we don't have a top-level binding form for implicit parameters. So it's stupid for 'foo' to be monomorphic. This commit improves matters by giving a much nicer error message: Implicit parameters escape from the monomorphic top-level binding(s) of `foo': ?x::Int arising from use of `woggle' at tcfail130.hs:10:6-11 Probably fix: add type signatures for the top-level binding(s) When generalising the type(s) for `foo' --- ghc/compiler/typecheck/TcBinds.lhs | 17 ++++----- ghc/compiler/typecheck/TcEnv.lhs | 17 +++++---- ghc/compiler/typecheck/TcRnTypes.lhs | 10 ++++- ghc/compiler/typecheck/TcSimplify.lhs | 67 ++++++++++++++++++++++++++++----- 4 files changed, 83 insertions(+), 28 deletions(-) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 509bce7..f0de50a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -22,7 +22,8 @@ import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet ) import TcRnMonad import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId ) -import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, newLocalName, tcLookupLocalIds ) +import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, + newLocalName, tcLookupLocalIds, pprBinders ) import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) @@ -291,7 +292,7 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do -- TODO: location a bit awkward, but the mbinds have been -- dependency analysed and may no longer be adjacent addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ - generalise is_unres mono_bind_infos tc_ty_sigs lie_req + generalise top_lvl is_unres mono_bind_infos tc_ty_sigs lie_req -- FINALISE THE QUANTIFIED TYPE VARIABLES -- The quantified type variables often include meta type variables @@ -634,9 +635,9 @@ checkSigCtxt sig1 sig@(TcSigInfo { sig_tvs = tvs, sig_theta = theta, sig_tau = t \end{code} \begin{code} -generalise :: Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst] +generalise :: TopLevelFlag -> Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst] -> TcM ([TcTyVar], TcDictBinds, [TcId]) -generalise is_unrestricted mono_infos sigs lie_req +generalise top_lvl is_unrestricted mono_infos sigs lie_req | not is_unrestricted -- RESTRICTED CASE = -- Check signature contexts are empty do { checkTc (all is_mono_sig sigs) @@ -644,7 +645,8 @@ generalise is_unrestricted mono_infos sigs lie_req -- Now simplify with exactly that set of tyvars -- We have to squash those Methods - ; (qtvs, binds) <- tcSimplifyRestricted doc tau_tvs lie_req + ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndr_names + tau_tvs lie_req -- Check that signature type variables are OK ; final_qtvs <- checkSigsTyVars qtvs sigs @@ -890,9 +892,4 @@ restrictedBindCtxtErr binder_names genCtxt binder_names = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names - --- Used in error messages --- Use quotes for a single one; they look a bit "busy" for several -pprBinders [bndr] = quotes (ppr bndr) -pprBinders bndrs = pprWithCommas ppr bndrs \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5ebfe58..fe2cc1e 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -22,7 +22,7 @@ module TcEnv( tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, - wrongThingErr, + wrongThingErr, pprBinders, tcExtendRecEnv, -- For knot-tying @@ -47,12 +47,13 @@ module TcEnv( import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds ) import TcIface ( tcImportDecl ) +import TcRnTypes ( pprTcTyThingCategory ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, - tidyOpenType, pprTyThingCategory + tidyOpenType ) import qualified Type ( getTyVar_maybe ) import Id ( idName, isLocalId ) @@ -591,15 +592,17 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) %************************************************************************ \begin{code} +pprBinders :: [Name] -> SDoc +-- Used in error messages +-- Use quotes for a single one; they look a bit "busy" for several +pprBinders [bndr] = quotes (ppr bndr) +pprBinders bndrs = pprWithCommas ppr bndrs + notFound name = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) wrongThingErr expected thing name - = failWithTc (pp_thing thing <+> quotes (ppr name) <+> + = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected) - where - pp_thing (AGlobal thing) = pprTyThingCategory thing - pp_thing (ATyVar _ _) = ptext SLIT("Type variable") - pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier") \end{code} diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 2abdfa5..a89ebf3 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -20,7 +20,7 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTyThing(..), GadtRefinement, + TcTyThing(..), pprTcTyThingCategory, GadtRefinement, -- Template Haskell ThStage(..), topStage, topSpliceStage, @@ -48,7 +48,7 @@ import HscTypes ( FixityEnv, GenAvailInfo(..), AvailInfo, HscSource(..), availName, IsBootInterface, Deprecations ) import Packages ( PackageId ) -import Type ( Type, TvSubstEnv, pprParendType ) +import Type ( Type, TvSubstEnv, pprParendType, pprTyThingCategory ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) import InstEnv ( DFunId, InstEnv ) @@ -414,6 +414,12 @@ instance Outputable TcTyThing where -- Debugging only ifPprDebug (brackets (ppr g <> comma <> ppr tl <> comma <> ppr pl)) ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty ppr (AThing k) = text "AThing" <+> ppr k + +pprTcTyThingCategory :: TcTyThing -> SDoc +pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing +pprTcTyThingCategory (ATyVar _ _) = ptext SLIT("Type variable") +pprTcTyThingCategory (ATcId _ _ _) = ptext SLIT("Local identifier") +pprTcTyThingCategory (AThing _) = ptext SLIT("Kinded thing") \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 97aca4d..5c0a22d 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -38,7 +38,7 @@ import Inst ( lookupInst, LookupInstResult(..), Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, 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} @@ -1946,7 +1981,7 @@ tc_simplify_top is_interactive wanteds -- 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 @@ -2244,7 +2279,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)), + ptext SLIT("Probably fix: add type signatures for the top-level binding(s)")] + 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 -- 1.7.10.4