Commit aca101dd authored by simonpj's avatar simonpj
Browse files

[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 (
tidyInsts, tidyMoreInsts,
newDictsFromOld, newDicts, newDictsAtLoc, cloneDict,
newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
newOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstCall, tcInstStupidTheta,
......@@ -22,7 +22,7 @@ module Inst (
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..),
lookupInst, LookupInstResult(..), lookupPred,
tcExtendLocalInstEnv, tcGetInstEnvs,
isDict, isClassDict, isMethod,
......@@ -228,21 +228,20 @@ cloneDict :: Inst -> TcM Inst
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc)
newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
newDictAtLoc inst_loc pred
= do { uniq <- newUnique
; return (mkDict inst_loc uniq pred) }
-- Local function, similar to newDicts,
-- but with slightly different interface
newDictsAtLoc :: InstLoc
-> TcThetaType
-> TcM [Inst]
newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
newDictsAtLoc inst_loc theta
= 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
mk_dict uniq pred = Dict (mkPredName uniq loc pred)
pred inst_loc
loc = instLocSrcLoc inst_loc
name = mkPredName uniq (instLocSrcLoc inst_loc) pred
-- 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
......@@ -683,30 +682,13 @@ lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
(HsVar (instToId method_inst))) rat_lit))
-- Dictionaries
lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
= do { pkg_ie <- loadImportedInsts clas tys
-- Suck in any instance decls that may be relevant
; tcg_env <- getGblEnv
; dflags <- getDOpts
; 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
lookupInst (Dict _ pred loc)
= do { mb_result <- lookupPred pred
; case mb_result of {
Nothing -> return NoInstance ;
Just (tenv, dfun_id) -> do
-----------------
instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
instantiate_dfun tenv dfun_id pred loc
= -- tenv is a substitution that instantiates the dfun_id
-- tenv is a substitution that instantiates the dfun_id
-- to match the requested result type.
--
-- We ASSUME that the dfun is quantified over the very same tyvars
......@@ -717,27 +699,19 @@ instantiate_dfun tenv dfun_id pred loc
-- dfun :: forall a b. C a b, Ord b => D [a]
-- We instantiate b to a flexi type variable -- it'll presumably
-- become fixed later via functional dependencies
traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
-- 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_`
{ use_stage <- getStage
; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage
-- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the open_tvs to instantiate any un-substituted tyvars.
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
open_tvs = filter (`notElemTvSubst` tenv) tyvars
in
mappM tcInstTyVar open_tvs `thenM` \ open_tvs' ->
let
; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
open_tvs = filter (`notElemTvSubst` tenv) tyvars
; open_tvs' <- mappM tcInstTyVar open_tvs
; let
tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
-- 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
......@@ -745,25 +719,57 @@ instantiate_dfun tenv dfun_id pred loc
(theta, _) = tcSplitPhiTy dfun_rho
ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
(map (substTyVar tenv') tyvars)
in
if null theta then
; if null theta then
returnM (SimpleInst ty_app)
else
newDictsAtLoc loc theta `thenM` \ dicts ->
let
rhs = mkHsDictApp ty_app (map instToId dicts)
in
returnM (GenInst dicts rhs)
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)
else do
{ dicts <- newDictsAtLoc loc theta
; let rhs = mkHsDictApp ty_app (map instToId dicts)
; returnM (GenInst dicts rhs)
}}}}
---------------
lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
= do { pkg_ie <- loadImportedInsts clas tys
-- Suck in any instance decls that may be relevant
; tcg_env <- getGblEnv
; dflags <- getDOpts
; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
([(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)
-- Gets both the external-package inst-env
......
......@@ -26,7 +26,7 @@ import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv,
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, substTys )
import DataCon ( classDataCon )
import Class ( classBigSig )
......@@ -338,7 +338,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
------------------
-- Typecheck the methods
let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
......@@ -348,10 +347,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
op_items binds `thenM` \ (meth_ids, meth_binds) ->
-- Figure out bindings for the superclass context
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
`thenM` \ (sc_binds_inner, sc_binds_outer) ->
-- It's possible that the superclass stuff might have done unification
-- Don't include this_dict in the 'givens', else
-- sc_dicts get bound by just selecting from this_dict!!
addErrCtxt superClassCtxt
(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_`
-- Deal with 'SPECIALISE instance' pragmas by making them
......@@ -411,7 +415,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
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
inst_tyvars'
......@@ -421,8 +425,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
in
showLIE (text "instance") `thenM_`
returnM (unitBag main_bind `unionBags`
prag_binds `unionBags`
sc_binds_outer)
prag_binds )
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')
\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
......
......@@ -10,6 +10,7 @@ module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs,
tcSimplifySuperClasses,
tcSimplifyTop, tcSimplifyInteractive,
tcSimplifyBracket,
......@@ -32,19 +33,19 @@ import Inst ( lookupInst, LookupInstResult(..),
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
instBindingRequired, fdPredsOfInst,
newDictsFromOld, tcInstClassOp,
getDictClassTys, isTyVarDict,
instLoc, zonkInst, tidyInsts, tidyMoreInsts,
newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
isInheritableInst, pprDFuns, pprDictsTheta
)
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders )
import InstEnv ( lookupInstEnv, classInstances )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
import TcType ( TcTyVar, TcTyVarSet, ThetaType,
mkClassPred, isOverloadedTy, mkTyConApp,
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType,
mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, tcEqType, pprPred )
tyVarsOfPred, tcEqType, pprPred, mkPredTy )
import Id ( idType, mkUserLocal )
import Var ( TyVar )
import Name ( Name, getOccName, getSrcLoc )
......@@ -665,7 +666,7 @@ inferLoop doc tau_tvs wanteds
try_me inst
| isFreeWhenInferring qtvs inst = Free
| isClassDict inst = DontReduceUnlessConstant -- Dicts
| otherwise = ReduceMe -- Lits and Methods
| otherwise = ReduceMe NoSCs -- Lits and Methods
in
traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds,
ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
......@@ -778,12 +779,13 @@ tcSimplifyCheck
-- global type variables in the environment; so you don't
-- need to worry about setting them before calling tcSimplifyCheck
tcSimplifyCheck doc qtvs givens wanted_lie
= tcSimplCheck doc get_qtvs
givens wanted_lie `thenM` \ (qtvs', binds) ->
returnM binds
= ASSERT( all isSkolemTyVar qtvs )
do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie
; extendLIEs frees
; return binds }
where
-- get_qtvs = zonkTcTyVarsAndFV qtvs
get_qtvs = return (mkVarSet qtvs)
-- get_qtvs = zonkTcTyVarsAndFV qtvs
get_qtvs = return (mkVarSet qtvs) -- All skolems
-- tcSimplifyInferCheck is used when we know the constraints we are to simplify
......@@ -798,7 +800,9 @@ tcSimplifyInferCheck
TcDictBinds) -- Bindings
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
-- Figure out which type variables to quantify over
-- You might think it should just be the signature tyvars,
......@@ -825,17 +829,16 @@ tcSimplifyInferCheck doc tau_tvs givens wanted_lie
Here is the workhorse function for all three wrappers.
\begin{code}
tcSimplCheck doc get_qtvs givens wanted_lie
= check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
tcSimplCheck doc get_qtvs want_scs givens wanted_lie
= do { (qtvs, frees, binds, irreds) <- check_loop givens wanted_lie
-- Complain about any irreducible ones
mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_`
-- Done
extendLIEs frees `thenM_`
returnM (qtvs, binds)
-- Complain about any irreducible ones
; if not (null irreds)
then do { givens' <- mappM zonkInst given_dicts_and_ips
; groupErrs (addNoInstanceErrs (Just doc) givens') irreds }
else return ()
; returnM (qtvs, frees, binds) }
where
given_dicts_and_ips = filter (not . isMethod) givens
-- For error reporting, filter out methods, which are
......@@ -854,7 +857,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie
-- When checking against a given signature we always reduce
-- until we find a match against something given, or can't reduce
try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
| otherwise = ReduceMe
| otherwise = ReduceMe want_scs
in
reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
......@@ -867,6 +870,62 @@ tcSimplCheck doc get_qtvs givens wanted_lie
\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}
......@@ -1028,7 +1087,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
is_nested_group = isNotTopLevel top_lvl
try_me inst | isFreeWrtTyVars qtvs inst,
(is_nested_group || isDict inst) = Free
| otherwise = ReduceMe
| otherwise = ReduceMe AddSCs
in
reduceContextWithoutImprovement
doc try_me wanteds' `thenM` \ (frees, binds, irreds) ->
......@@ -1086,7 +1145,7 @@ want to get
forall dIntegralInt.
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.
fromIntegral Int Int dIntegralInt dNumInt = id Int
......@@ -1108,7 +1167,7 @@ tcSimplifyToDicts wanteds
-- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = KeepDictWithoutSCs -- See notes above re "WithoutSCs"
| otherwise = ReduceMe
| otherwise = ReduceMe NoSCs
\end{code}
......@@ -1164,7 +1223,7 @@ tcSimplifyIPs given_ips wanteds
-- Simplify any methods that mention the implicit parameter
try_me inst | isFreeWrtIPs ip_set inst = Free
| otherwise = ReduceMe
| otherwise = ReduceMe NoSCs
simpl_loop givens wanteds
= mappM zonkInst givens `thenM` \ givens' ->
......@@ -1236,7 +1295,7 @@ bindInstsOfLocalFuns wanteds local_ids
overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
-- so it's worth building a set, so that
-- lookup (in isMethodFor) is faster
try_me inst | isMethod inst = ReduceMe
try_me inst | isMethod inst = ReduceMe NoSCs
| otherwise = Free
\end{code}
......@@ -1251,7 +1310,7 @@ The main control over context reduction is here
\begin{code}
data WhatToDo
= ReduceMe -- Try to reduce this
= ReduceMe WantSCs -- Try to reduce this
-- If there's no instance, behave exactly like
-- DontReduce: add the inst to
-- the irreductible ones, but don't
......@@ -1267,7 +1326,7 @@ data WhatToDo
| Free -- Return as free
reduceMe :: Inst -> WhatToDo
reduceMe inst = ReduceMe
reduceMe inst = ReduceMe AddSCs
data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
-- of a predicate when adding it to the avails
......@@ -1682,12 +1741,12 @@ reduce stack try_me wanted avails
-- First, see if the inst can be reduced to a constant in one step
try_simple addFree
; ReduceMe -> -- It should be reduced
; ReduceMe want_scs -> -- It should be reduced
lookupInst wanted `thenM` \ lookup_result ->
case lookup_result of
GenInst wanteds' rhs -> addIrred NoSCs avails wanted `thenM` \ avails1 ->
reduceList stack try_me wanteds' avails1 `thenM` \ avails2 ->
addWanted avails2 wanted rhs wanteds'
addWanted want_scs avails2 wanted rhs wanteds'
-- Experiment with temporarily doing addIrred *before* the reduceList,
-- which has the effect of adding the thing we are trying
-- to prove to the database before trying to prove the things it
......@@ -1697,17 +1756,17 @@ reduce stack try_me wanted avails
-- the examples in [SUPERCLASS-LOOP]
-- So we do an addIrred before, and then overwrite it afterwards with addWanted
SimpleInst rhs -> addWanted avails wanted rhs []
SimpleInst rhs -> addWanted want_scs avails wanted rhs []
NoInstance -> -- No such instance!
-- Add it and its superclasses
addIrred AddSCs avails wanted
addIrred want_scs avails wanted
}
where
try_simple do_this_otherwise
= lookupInst wanted `thenM` \ lookup_result ->
case lookup_result of
SimpleInst rhs -> addWanted avails wanted rhs []
SimpleInst rhs -> addWanted AddSCs avails wanted rhs []
other -> do_this_otherwise avails wanted
\end{code}
......@@ -1762,32 +1821,35 @@ addFree :: Avails -> Inst -> TcM Avails
--
addFree avails free = returnM (addToFM avails free IsFree)
addWanted :: Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
addWanted avails wanted rhs_expr wanteds
= addAvailAndSCs avails wanted avail
addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
addWanted want_scs avails wanted rhs_expr wanteds
= addAvailAndSCs want_scs avails wanted avail
where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
addGiven :: Avails -> Inst -> TcM Avails
addGiven avails given = addAvailAndSCs avails given (Given (instToId given) False)
addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False)
-- Always add superclasses for 'givens'
--
-- No ASSERT( not (given `elemFM` avails) ) because in an instance
-- decl for Ord t we can add both Ord t and Eq t as 'givens',
-- so the assert isn't true
addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
addIrred NoSCs avails irred = returnM (addToFM avails irred Irred)
addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
addAvailAndSCs avails irred Irred
addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails
addAvailAndSCs avails inst avail
| not (isClassDict inst) = returnM avails1
| otherwise = traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) `thenM_`
addSCs is_loop avails1 inst
addIrred want_scs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
addAvailAndSCs want_scs avails irred Irred
addAvailAndSCs :: WantSCs -> Avails -> Inst -> Avail -> TcM Avails
addAvailAndSCs want_scs avails inst avail
| not (isClassDict inst) = return avails_with_inst
| NoSCs <- want_scs = return avails_with_inst
| otherwise = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps])
; addSCs is_loop avails_with_inst inst }
where
avails1 = addToFM avails inst avail
is_loop inst = any (`tcEqType` idType (instToId inst)) dep_tys
avails_with_inst = addToFM avails inst avail
is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys
-- Note: this compares by *type*, not by Unique
deps = findAllDeps (unitVarSet (instToId inst)) avail
dep_tys = map idType (varSetElems deps)
......@@ -1809,38 +1871,37 @@ addAvailAndSCs avails inst avail
so_far' = extendVarSet so_far kid_id -- Add the new kid to so_far
kid_id = instToId kid
addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails
-- Add all the superclasses of the Inst to Avails
-- The first param says "dont do this because the original thing
-- depends on this one, so you'd build a loop"
-- Invariant: the Inst is already in Avails.
addSCs is_loop avails dict
= newDictsFromOld dict sc_theta' `thenM` \ sc_dicts ->
foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
= do { sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta'
; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
where