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,
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 )
import Type ( zipTopTvSubst, substTheta, substTy )
import TysWiredIn ( pairTyCon, doubleTy )
import ErrUtils ( Message )
+import BasicTypes ( TopLevelFlag, isNotTopLevel )
import VarSet
import VarEnv ( TidyEnv )
import FiniteMap
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
~~~~~~~~~~~~~~~~
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)
-- 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' ->
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,
-- 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}
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
-- Collect together all the bad guys
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.
+ (ambigs, no_insts) = partition isTyVarDict non_ips
+ -- If the dict has no type constructors involved, it must be ambiguous,
+ -- except I suppose that another error with fundeps maybe should have
+ -- constrained those type variables
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
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
-- Insts for which it is worth suggesting an adding an instance declaration
-- Exclude implicit parameters, and tyvar dicts
- add_ors :: [SDoc] -> [SDoc]
+ 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
-- 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 ->
projects / ghc-hetmet.git / blobdiff