Commit aca101dd authored by simonpj's avatar simonpj

[project @ 2005-03-09 14:26:56 by simonpj]

Fix the superclass translation for instance decls
			Merge to STABLE

There is a long-standing difficulty whereby it's surprisingly easy 
to accidentally generate an entirely-bogus recursive dictionary when 
generating the definitions for the superclasses of an instance decl.

The problem arises because the default story is that whenever we
add a constraint to our pile of solved constraints, we automatically
add all its superclasses.  But that is simply wrong when we are trying
to generate superclasses. 

Solution: do no auto-superclass addition when solving the superclass
constraints of an instance declaration.  I think should fix it once and
for all.  

	tcrun021, tcrun033 are test cases

tcrun033 showed up the bug; thanks to Simon Foster and Ralf Laemmel.
parent 0d197643
...@@ -12,7 +12,7 @@ module Inst ( ...@@ -12,7 +12,7 @@ module Inst (
tidyInsts, tidyMoreInsts, tidyInsts, tidyMoreInsts,
newDictsFromOld, newDicts, newDictsAtLoc, cloneDict, newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
newOverloadedLit, newIPDict, newOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstCall, tcInstStupidTheta, tcInstClassOp, tcInstCall, tcInstStupidTheta,
...@@ -22,7 +22,7 @@ module Inst ( ...@@ -22,7 +22,7 @@ module Inst (
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred, instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..), lookupInst, LookupInstResult(..), lookupPred,
tcExtendLocalInstEnv, tcGetInstEnvs, tcExtendLocalInstEnv, tcGetInstEnvs,
isDict, isClassDict, isMethod, isDict, isClassDict, isMethod,
...@@ -228,21 +228,20 @@ cloneDict :: Inst -> TcM Inst ...@@ -228,21 +228,20 @@ cloneDict :: Inst -> TcM Inst
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq -> cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc) returnM (Dict (setNameUnique nm uniq) ty loc)
newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst] newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta newDictAtLoc inst_loc pred
= do { uniq <- newUnique
; return (mkDict inst_loc uniq pred) }
-- Local function, similar to newDicts, newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
-- but with slightly different interface
newDictsAtLoc :: InstLoc
-> TcThetaType
-> TcM [Inst]
newDictsAtLoc inst_loc theta newDictsAtLoc inst_loc theta
= newUniqueSupply `thenM` \ us -> = newUniqueSupply `thenM` \ us ->
returnM (zipWith mk_dict (uniqsFromSupply us) theta) returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
mkDict inst_loc uniq pred
= Dict name pred inst_loc
where where
mk_dict uniq pred = Dict (mkPredName uniq loc pred) name = mkPredName uniq (instLocSrcLoc inst_loc) pred
pred inst_loc
loc = instLocSrcLoc inst_loc
-- For vanilla implicit parameters, there is only one in scope -- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself -- at any time, so we used to use the name of the implicit parameter itself
...@@ -683,30 +682,13 @@ lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc) ...@@ -683,30 +682,13 @@ lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
(HsVar (instToId method_inst))) rat_lit)) (HsVar (instToId method_inst))) rat_lit))
-- Dictionaries -- Dictionaries
lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) lookupInst (Dict _ pred loc)
= do { pkg_ie <- loadImportedInsts clas tys = do { mb_result <- lookupPred pred
-- Suck in any instance decls that may be relevant ; case mb_result of {
; tcg_env <- getGblEnv Nothing -> return NoInstance ;
; dflags <- getDOpts Just (tenv, dfun_id) -> do
; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
(matches, unifs) -> do
{ traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches,
text "unifs" <+> ppr unifs])
; return NoInstance } } }
-- In the case of overlap (multiple matches) we report
-- NoInstance here. That has the effect of making the
-- context-simplifier return the dict as an irreducible one.
-- Then it'll be given to addNoInstanceErrs, which will do another
-- lookupInstEnv to get the detailed info about what went wrong.
lookupInst (Dict _ _ _) = returnM NoInstance
----------------- -- tenv is a substitution that instantiates the dfun_id
instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
instantiate_dfun tenv dfun_id pred loc
= -- tenv is a substitution that instantiates the dfun_id
-- to match the requested result type. -- to match the requested result type.
-- --
-- We ASSUME that the dfun is quantified over the very same tyvars -- We ASSUME that the dfun is quantified over the very same tyvars
...@@ -717,27 +699,19 @@ instantiate_dfun tenv dfun_id pred loc ...@@ -717,27 +699,19 @@ instantiate_dfun tenv dfun_id pred loc
-- dfun :: forall a b. C a b, Ord b => D [a] -- dfun :: forall a b. C a b, Ord b => D [a]
-- We instantiate b to a flexi type variable -- it'll presumably -- We instantiate b to a flexi type variable -- it'll presumably
-- become fixed later via functional dependencies -- become fixed later via functional dependencies
traceTc (text "lookupInst success" <+> { use_stage <- getStage
vcat [text "dict" <+> ppr pred, ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_` (topIdLvl dfun_id) use_stage
-- Record that this dfun is needed
record_dfun_usage dfun_id `thenM_`
getStage `thenM` \ use_stage ->
checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage `thenM_`
-- It's possible that not all the tyvars are in -- It's possible that not all the tyvars are in
-- the substitution, tenv. For example: -- the substitution, tenv. For example:
-- instance C X a => D X where ... -- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C) -- (presumably there's a functional dependency in class C)
-- Hence the open_tvs to instantiate any un-substituted tyvars. -- Hence the open_tvs to instantiate any un-substituted tyvars.
let ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
(tyvars, rho) = tcSplitForAllTys (idType dfun_id) open_tvs = filter (`notElemTvSubst` tenv) tyvars
open_tvs = filter (`notElemTvSubst` tenv) tyvars ; open_tvs' <- mappM tcInstTyVar open_tvs
in ; let
mappM tcInstTyVar open_tvs `thenM` \ open_tvs' ->
let
tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs') tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
-- Since the open_tvs' are freshly made, they cannot possibly be captured by -- Since the open_tvs' are freshly made, they cannot possibly be captured by
-- any nested for-alls in rho. So the in-scope set is unchanged -- any nested for-alls in rho. So the in-scope set is unchanged
...@@ -745,25 +719,57 @@ instantiate_dfun tenv dfun_id pred loc ...@@ -745,25 +719,57 @@ instantiate_dfun tenv dfun_id pred loc
(theta, _) = tcSplitPhiTy dfun_rho (theta, _) = tcSplitPhiTy dfun_rho
ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
(map (substTyVar tenv') tyvars) (map (substTyVar tenv') tyvars)
in ; if null theta then
if null theta then
returnM (SimpleInst ty_app) returnM (SimpleInst ty_app)
else else do
newDictsAtLoc loc theta `thenM` \ dicts -> { dicts <- newDictsAtLoc loc theta
let ; let rhs = mkHsDictApp ty_app (map instToId dicts)
rhs = mkHsDictApp ty_app (map instToId dicts) ; returnM (GenInst dicts rhs)
in }}}}
returnM (GenInst dicts rhs)
---------------
record_dfun_usage dfun_id = do lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
dflags <- getDOpts -- Look up a class constraint in the instance environment
let dfun_name = idName dfun_id lookupPred pred@(ClassP clas tys)
dfun_mod = nameModule dfun_name = do { pkg_ie <- loadImportedInsts clas tys
if isInternalName dfun_name || not (isHomeModule dflags dfun_mod) -- Suck in any instance decls that may be relevant
then return () -- internal, or in another package ; tcg_env <- getGblEnv
else do tcg_env <- getGblEnv ; dflags <- getDOpts
updMutVar (tcg_inst_uses tcg_env) ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
(`addOneToNameSet` idName dfun_id) ([(tenv, (_,_,dfun_id))], [])
-> do { traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ])
-- Record that this dfun is needed
; record_dfun_usage dfun_id
; return (Just (tenv, dfun_id)) } ;
(matches, unifs)
-> do { traceTc (text "lookupInst fail" <+>
vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches,
text "unifs" <+> ppr unifs])
-- In the case of overlap (multiple matches) we report
-- NoInstance here. That has the effect of making the
-- context-simplifier return the dict as an irreducible one.
-- Then it'll be given to addNoInstanceErrs, which will do another
-- lookupInstEnv to get the detailed info about what went wrong.
; return Nothing }
}}
lookupPred ip_pred = return Nothing
record_dfun_usage dfun_id
= do { dflags <- getDOpts
; let dfun_name = idName dfun_id
dfun_mod = nameModule dfun_name
; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
then return () -- internal, or in another package
else do { tcg_env <- getGblEnv
; updMutVar (tcg_inst_uses tcg_env)
(`addOneToNameSet` idName dfun_id) }}
tcGetInstEnvs :: TcM (InstEnv, InstEnv) tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env -- Gets both the external-package inst-env
......
...@@ -26,7 +26,7 @@ import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, ...@@ -26,7 +26,7 @@ import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv,
) )
import TcHsType ( kcHsSigType, tcHsKindedType ) import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars ) import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, substTys ) import Type ( zipOpenTvSubst, substTheta, substTys )
import DataCon ( classDataCon ) import DataCon ( classDataCon )
import Class ( classBigSig ) import Class ( classBigSig )
...@@ -338,7 +338,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) ...@@ -338,7 +338,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
-- Default-method Ids may be mentioned in synthesised RHSs, -- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment. -- but they'll already be in the environment.
------------------
-- Typecheck the methods -- Typecheck the methods
let -- These insts are in scope; quite a few, eh? let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
...@@ -348,10 +347,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) ...@@ -348,10 +347,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
op_items binds `thenM` \ (meth_ids, meth_binds) -> op_items binds `thenM` \ (meth_ids, meth_binds) ->
-- Figure out bindings for the superclass context -- Figure out bindings for the superclass context
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts -- Don't include this_dict in the 'givens', else
`thenM` \ (sc_binds_inner, sc_binds_outer) -> -- sc_dicts get bound by just selecting from this_dict!!
addErrCtxt superClassCtxt
-- It's possible that the superclass stuff might have done unification (tcSimplifySuperClasses inst_tyvars'
dfun_arg_dicts
sc_dicts) `thenM` \ sc_binds ->
-- It's possible that the superclass stuff might unified one
-- of the inst_tyavars' with something in the envt
checkSigTyVars inst_tyvars' `thenM_` checkSigTyVars inst_tyvars' `thenM_`
-- Deal with 'SPECIALISE instance' pragmas by making them -- Deal with 'SPECIALISE instance' pragmas by making them
...@@ -411,7 +415,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) ...@@ -411,7 +415,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
dict_bind = noLoc (VarBind this_dict_id dict_rhs) dict_bind = noLoc (VarBind this_dict_id dict_rhs)
all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds) all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
main_bind = noLoc $ AbsBinds main_bind = noLoc $ AbsBinds
inst_tyvars' inst_tyvars'
...@@ -421,8 +425,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) ...@@ -421,8 +425,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
in in
showLIE (text "instance") `thenM_` showLIE (text "instance") `thenM_`
returnM (unitBag main_bind `unionBags` returnM (unitBag main_bind `unionBags`
prag_binds `unionBags` prag_binds )
sc_binds_outer)
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
...@@ -515,65 +518,6 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' ...@@ -515,65 +518,6 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars')
\end{code} \end{code}
Note: [Superclass loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
We have to be very, very careful when generating superclasses, lest we
accidentally build a loop. Here's an example:
class S a
class S a => C a where { opc :: a -> a }
class S b => D b where { opd :: b -> b }
instance C Int where
opc = opd
instance D Int where
opd = opc
From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
Simplifying, we may well get:
$dfCInt = :C ds1 (opd dd)
dd = $dfDInt
ds1 = $p1 dd
Notice that we spot that we can extract ds1 from dd.
Alas! Alack! We can do the same for (instance D Int):
$dfDInt = :D ds2 (opc dc)
dc = $dfCInt
ds2 = $p1 dc
And now we've defined the superclass in terms of itself.
Solution: treat the superclass context separately, and simplify it
all the way down to nothing on its own. Don't toss any 'free' parts
out to be simplified together with other bits of context.
Hence the tcSimplifyTop below.
At a more basic level, don't include this_dict in the context wrt
which we simplify sc_dicts, else sc_dicts get bound by just selecting
from this_dict!!
\begin{code}
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
= addErrCtxt superClassCtxt $
getLIE (tcSimplifyCheck doc inst_tyvars'
dfun_arg_dicts
sc_dicts) `thenM` \ (sc_binds1, sc_lie) ->
-- We must simplify this all the way down
-- lest we build superclass loops
-- See Note [Superclass loops] above
tcSimplifyTop sc_lie `thenM` \ sc_binds2 ->
returnM (sc_binds1, sc_binds2)
where
doc = ptext SLIT("instance declaration superclass context")
\end{code}
------------------------------ ------------------------------
[Inline dfuns] Inlining dfuns unconditionally [Inline dfuns] Inlining dfuns unconditionally
......
...@@ -10,6 +10,7 @@ module TcSimplify ( ...@@ -10,6 +10,7 @@ module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyToDicts, tcSimplifyIPs,
tcSimplifySuperClasses,
tcSimplifyTop, tcSimplifyInteractive, tcSimplifyTop, tcSimplifyInteractive,
tcSimplifyBracket, tcSimplifyBracket,
...@@ -32,19 +33,19 @@ import Inst ( lookupInst, LookupInstResult(..), ...@@ -32,19 +33,19 @@ import Inst ( lookupInst, LookupInstResult(..),
instToId, tyVarsOfInsts, cloneDict, instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred, ipNamesOfInsts, ipNamesOfInst, dictPred,
instBindingRequired, fdPredsOfInst, instBindingRequired, fdPredsOfInst,
newDictsFromOld, tcInstClassOp, newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, getDictClassTys, isTyVarDict, instLoc,
instLoc, zonkInst, tidyInsts, tidyMoreInsts, zonkInst, tidyInsts, tidyMoreInsts,
Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
isInheritableInst, pprDFuns, pprDictsTheta isInheritableInst, pprDFuns, pprDictsTheta
) )
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders ) import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders )
import InstEnv ( lookupInstEnv, classInstances ) import InstEnv ( lookupInstEnv, classInstances )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType,
mkClassPred, isOverloadedTy, mkTyConApp, mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, tcEqType, pprPred ) tyVarsOfPred, tcEqType, pprPred, mkPredTy )
import Id ( idType, mkUserLocal ) import Id ( idType, mkUserLocal )
import Var ( TyVar ) import Var ( TyVar )
import Name ( Name, getOccName, getSrcLoc ) import Name ( Name, getOccName, getSrcLoc )
...@@ -665,7 +666,7 @@ inferLoop doc tau_tvs wanteds ...@@ -665,7 +666,7 @@ inferLoop doc tau_tvs wanteds
try_me inst try_me inst
| isFreeWhenInferring qtvs inst = Free | isFreeWhenInferring qtvs inst = Free
| isClassDict inst = DontReduceUnlessConstant -- Dicts | isClassDict inst = DontReduceUnlessConstant -- Dicts
| otherwise = ReduceMe -- Lits and Methods | otherwise = ReduceMe NoSCs -- Lits and Methods
in in
traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds,
ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
...@@ -778,12 +779,13 @@ tcSimplifyCheck ...@@ -778,12 +779,13 @@ tcSimplifyCheck
-- global type variables in the environment; so you don't -- global type variables in the environment; so you don't
-- need to worry about setting them before calling tcSimplifyCheck -- need to worry about setting them before calling tcSimplifyCheck
tcSimplifyCheck doc qtvs givens wanted_lie tcSimplifyCheck doc qtvs givens wanted_lie
= tcSimplCheck doc get_qtvs = ASSERT( all isSkolemTyVar qtvs )
givens wanted_lie `thenM` \ (qtvs', binds) -> do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie
returnM binds ; extendLIEs frees
; return binds }
where where
-- get_qtvs = zonkTcTyVarsAndFV qtvs -- get_qtvs = zonkTcTyVarsAndFV qtvs
get_qtvs = return (mkVarSet qtvs) get_qtvs = return (mkVarSet qtvs) -- All skolems
-- tcSimplifyInferCheck is used when we know the constraints we are to simplify -- tcSimplifyInferCheck is used when we know the constraints we are to simplify
...@@ -798,7 +800,9 @@ tcSimplifyInferCheck ...@@ -798,7 +800,9 @@ tcSimplifyInferCheck
TcDictBinds) -- Bindings TcDictBinds) -- Bindings
tcSimplifyInferCheck doc tau_tvs givens wanted_lie tcSimplifyInferCheck doc tau_tvs givens wanted_lie
= tcSimplCheck doc get_qtvs givens wanted_lie = do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie
; extendLIEs frees
; return (qtvs', binds) }
where where
-- Figure out which type variables to quantify over -- Figure out which type variables to quantify over
-- You might think it should just be the signature tyvars, -- You might think it should just be the signature tyvars,
...@@ -825,17 +829,16 @@ tcSimplifyInferCheck doc tau_tvs givens wanted_lie ...@@ -825,17 +829,16 @@ tcSimplifyInferCheck doc tau_tvs givens wanted_lie
Here is the workhorse function for all three wrappers. Here is the workhorse function for all three wrappers.
\begin{code} \begin{code}
tcSimplCheck doc get_qtvs givens wanted_lie tcSimplCheck doc get_qtvs want_scs givens wanted_lie
= check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> = do { (qtvs, frees, binds, irreds) <- check_loop givens wanted_lie
-- Complain about any irreducible ones -- Complain about any irreducible ones
mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> ; if not (null irreds)
groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_` then do { givens' <- mappM zonkInst given_dicts_and_ips
; groupErrs (addNoInstanceErrs (Just doc) givens') irreds }
-- Done else return ()
extendLIEs frees `thenM_`
returnM (qtvs, binds)
; returnM (qtvs, frees, binds) }
where where
given_dicts_and_ips = filter (not . isMethod) givens given_dicts_and_ips = filter (not . isMethod) givens
-- For error reporting, filter out methods, which are -- For error reporting, filter out methods, which are
...@@ -854,7 +857,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie ...@@ -854,7 +857,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie
-- When checking against a given signature we always reduce -- When checking against a given signature we always reduce
-- until we find a match against something given, or can't reduce -- until we find a match against something given, or can't reduce
try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
| otherwise = ReduceMe | otherwise = ReduceMe want_scs
in in
reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
...@@ -867,6 +870,62 @@ tcSimplCheck doc get_qtvs givens wanted_lie ...@@ -867,6 +870,62 @@ tcSimplCheck doc get_qtvs givens wanted_lie
\end{code} \end{code}
%************************************************************************
%* *
tcSimplifySuperClasses
%* *
%************************************************************************
Note [SUPERCLASS-LOOP 1]
~~~~~~~~~~~~~~~~~~~~~~~~
We have to be very, very careful when generating superclasses, lest we
accidentally build a loop. Here's an example:
class S a
class S a => C a where { opc :: a -> a }
class S b => D b where { opd :: b -> b }
instance C Int where
opc = opd
instance D Int where
opd = opc
From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
Simplifying, we may well get:
$dfCInt = :C ds1 (opd dd)
dd = $dfDInt
ds1 = $p1 dd
Notice that we spot that we can extract ds1 from dd.
Alas! Alack! We can do the same for (instance D Int):
$dfDInt = :D ds2 (opc dc)
dc = $dfCInt
ds2 = $p1 dc
And now we've defined the superclass in terms of itself.
Solution: never generate a superclass selectors at all when
satisfying the superclass context of an instance declaration.
Two more nasty cases are in
tcrun021
tcrun033
\begin{code}
tcSimplifySuperClasses qtvs givens sc_wanteds
= ASSERT( all isSkolemTyVar qtvs )
do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds
; binds2 <- tc_simplify_top doc False NoSCs frees
; return (binds1 `unionBags` binds2) }
where
get_qtvs = return (mkVarSet qtvs)
doc = ptext SLIT("instance declaration superclass context")
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{tcSimplifyRestricted} \subsection{tcSimplifyRestricted}
...@@ -1028,7 +1087,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds ...@@ -1028,7 +1087,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
is_nested_group = isNotTopLevel top_lvl is_nested_group = isNotTopLevel top_lvl
try_me inst | isFreeWrtTyVars qtvs inst, try_me inst | isFreeWrtTyVars qtvs inst,
(is_nested_group || isDict inst) = Free (is_nested_group || isDict inst) = Free
| otherwise = ReduceMe | otherwise = ReduceMe AddSCs
in in
reduceContextWithoutImprovement reduceContextWithoutImprovement
doc try_me wanteds' `thenM` \ (frees, binds, irreds) -> doc try_me wanteds' `thenM` \ (frees, binds, irreds) ->
...@@ -1086,7 +1145,7 @@ want to get ...@@ -1086,7 +1145,7 @@ want to get
forall dIntegralInt. forall dIntegralInt.
fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
because the scsel will mess up matching. Instead we want because the scsel will mess up RULE matching. Instead we want
forall dIntegralInt, dNumInt. forall dIntegralInt, dNumInt.
fromIntegral Int Int dIntegralInt dNumInt = id Int fromIntegral Int Int dIntegralInt dNumInt = id Int
...@@ -1108,7 +1167,7 @@ tcSimplifyToDicts wanteds ...@@ -1108,7 +1167,7 @@ tcSimplifyToDicts wanteds
-- Reduce methods and lits only; stop as soon as we get a dictionary -- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = KeepDictWithoutSCs -- See notes above re "WithoutSCs" try_me inst | isDict inst = KeepDictWithoutSCs -- See notes above re "WithoutSCs"
| otherwise = ReduceMe | otherwise = ReduceMe NoSCs
\end{code} \end{code}
...@@ -1164,7 +1223,7 @@ tcSimplifyIPs given_ips wanteds ...@@ -1164,7 +1223,7 @@ tcSimplifyIPs given_ips wanteds
-- Simplify any methods that mention the implicit parameter -- Simplify any methods that mention the implicit parameter
try_me inst | isFreeWrtIPs ip_set inst = Free try_me inst | isFreeWrtIPs ip_set inst = Free
| otherwise = ReduceMe | otherwise = ReduceMe NoSCs
simpl_loop givens wanteds simpl_loop givens wanteds
= mappM zonkInst givens `thenM` \ givens' -> = mappM zonkInst givens `thenM` \ givens' ->
...@@ -1236,7 +1295,7 @@ bindInstsOfLocalFuns wanteds local_ids ...@@ -1236,7 +1295,7 @@ bindInstsOfLocalFuns wanteds local_ids
overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
-- so it's worth building a set, so that -- so it's worth building a set, so that
-- lookup (in isMethodFor) is faster -- lookup (in isMethodFor) is faster
try_me inst | isMethod inst = ReduceMe try_me inst | isMethod inst = ReduceMe NoSCs
| otherwise = Free | otherwise = Free