Commit c36a2f9b authored by simonpj's avatar simonpj
Browse files

[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'
parent 6ac3317e
......@@ -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}
......@@ -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}
......@@ -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}
......
......@@ -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
......
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