import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
- tyVarsOfInst, fdPredsOfInsts, fdPredsOfInst, newDicts,
+ tyVarsOfInst, fdPredsOfInsts, newDicts,
isDict, isClassDict, isLinearInst, linearInstType,
isStdClassTyVarDict, isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
newDictsFromOld, tcInstClassOp,
getDictClassTys, isTyVarDict,
instLoc, zonkInst, tidyInsts, tidyMoreInsts,
- Inst, pprInsts, pprDictsInFull, tcGetInstEnvs,
+ Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
isIPDict, isInheritableInst, pprDFuns, pprDictsTheta
)
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals )
-import InstEnv ( lookupInstEnv, classInstEnv )
+import InstEnv ( lookupInstEnv, classInstances )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
mkClassPred, isOverloadedTy, mkTyConApp,
In the Step 1 this constraint might have been simplified, perhaps to
(Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'.
This won't happen in Step 2... but that in turn might prevent some other
- constraint mentioning 'b' from being simplified... and that in turn
- breaks the invariant that no constraints are quantified over.
+ constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..})
+ and that in turn breaks the invariant that no constraints are quantified over.
Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates
the problem.
Return the bindings from Step 1.
+A note about Plan C (arising from "bug" reported by George Russel March 2004)
+Consider this:
+
+ instance (HasBinary ty IO) => HasCodedValue ty
+
+ foo :: HasCodedValue a => String -> IO a
+
+ doDecodeIO :: HasCodedValue a => () -> () -> IO a
+ doDecodeIO codedValue view
+ = let { act = foo "foo" } in act
+
+You might think this should work becuase the call to foo gives rise to a constraint
+(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO. But the
+restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the
+constraint using the (rather bogus) instance declaration, and now we are stuffed.
+
+I claim this is not really a bug -- but it bit Sergey as well as George. So here's
+plan D
+
+
+Plan D (a variant of plan B)
+ Step 1: Simplify the constraints as much as possible (to deal
+ with Plan A's problem), BUT DO NO IMPROVEMENT. Then set
+ qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
+
+ Step 2: Now simplify again, treating the constraint as 'free' if
+ it does not mention qtvs, and trying to reduce it otherwise.
+
+ The point here is that it's generally OK to have too few qtvs; that is,
+ to make the thing more monomorphic than it could be. We don't want to
+ do that in the common cases, but in wierd cases it's ok: the programmer
+ can always add a signature.
+
+ Too few qtvs => too many wanteds, which is what happens if you do less
+ improvement.
+
\begin{code}
tcSimplifyRestricted -- Used for restricted binding groups
-- They are all thrown back in the LIE
tcSimplifyRestricted doc tau_tvs wanteds
- -- 'reduceMe': Reduce as far as we can. Don't stop at
+ -- Zonk everything in sight
+ = mappM zonkInst wanteds `thenM` \ wanteds' ->
+ zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
+
+ -- 'reduceMe': Reduce as far as we can. Don't stop at
-- dicts; the idea is to get rid of as many type
-- variables as possible, and we don't want to stop
-- at (say) Monad (ST s), because that reduces
-- immediately, with no constraint on s.
- = simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
- ASSERT( null frees )
+ --
+ -- BUT do no improvement! See Plan D above
+ reduceContextWithoutImprovement
+ doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
- zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
- tcGetGlobalTyVars `thenM` \ gbl_tvs ->
let
- constrained_tvs = tyVarsOfInsts irreds
- qtvs = (tau_tvs' `minusVarSet` constrained_tvs)
- `minusVarSet` oclose (fdPredsOfInsts irreds) gbl_tvs
- -- The second minusVarSet arranges not to quantify over
- -- any tyvars that are functionally determined by ones in
- -- the environment
+ 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 irreds,
- pprLHsBinds binds,
+ pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts,
+ ppr _binds,
ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_`
- extendLIEs irreds `thenM_`
+ -- The first step may have squashed more methods than
+ -- necessary, so try again, this time more gently, knowing the exact
+ -- set of type variables to quantify over.
+ --
+ -- We quantify only over constraints that are captured by qtvs;
+ -- these will just be a subset of non-dicts. This in contrast
+ -- to normal inference (using isFreeWhenInferring) in which we quantify over
+ -- all *non-inheritable* constraints too. This implements choice
+ -- (B) under "implicit parameter and monomorphism" above.
+ --
+ -- 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
+ reduceContextWithoutImprovement
+ doc try_me wanteds' `thenM` \ (frees, binds, irreds) ->
+ ASSERT( null irreds )
+ extendLIEs frees `thenM_`
returnM (varSetElems qtvs, binds)
\end{code}
forall dIntegralInt, dNumInt.
fromIntegral Int Int dIntegralInt dNumInt = id Int
-Hence "DontReduce NoSCs"
+Hence "WithoutSCs"
\begin{code}
tcSimplifyToDicts :: [Inst] -> TcM (TcDictBinds)
doc = text "tcSimplifyToDicts"
-- Reduce methods and lits only; stop as soon as we get a dictionary
- try_me inst | isDict inst = DontReduce NoSCs -- See notes above for why NoSCs
+ try_me inst | isDict inst = KeepDictWithoutSCs -- See notes above re "WithoutSCs"
| otherwise = ReduceMe
\end{code}
-- produce an error message of any kind.
-- It might be quite legitimate such as (Eq a)!
- | DontReduce WantSCs -- Return as irreducible
+ | KeepDictWithoutSCs -- Return as irreducible; don't add its superclasses
+ -- Rather specialised: see notes with tcSimplifyToDicts
| DontReduceUnlessConstant -- Return as irreducible unless it can
-- be reduced to a constant in one step
\begin{code}
type Avails = FiniteMap Inst Avail
+emptyAvails = emptyFM
data Avail
= IsFree -- Used for free Insts
])) `thenM_`
-- Build the Avail mapping from "givens"
- foldlM addGiven emptyFM givens `thenM` \ init_state ->
+ foldlM addGiven emptyAvails givens `thenM` \ init_state ->
-- Do the real work
reduceList (0,[]) try_me wanteds init_state `thenM` \ avails ->
returnM (no_improvement, frees, binds, irreds)
+-- reduceContextWithoutImprovement differs from reduceContext
+-- (a) no improvement
+-- (b) 'givens' is assumed empty
+reduceContextWithoutImprovement doc try_me wanteds
+ =
+ traceTc (text "reduceContextWithoutImprovement" <+> (vcat [
+ text "----------------------",
+ doc,
+ text "wanted" <+> ppr wanteds,
+ text "----------------------"
+ ])) `thenM_`
+
+ -- Do the real work
+ reduceList (0,[]) try_me wanteds emptyAvails `thenM` \ avails ->
+ extractResults avails wanteds `thenM` \ (binds, irreds, frees) ->
+
+ traceTc (text "reduceContextWithoutImprovement end" <+> (vcat [
+ text "----------------------",
+ doc,
+ text "wanted" <+> ppr wanteds,
+ text "----",
+ text "avails" <+> pprAvails avails,
+ text "frees" <+> ppr frees,
+ text "----------------------"
+ ])) `thenM_`
+
+ returnM (frees, binds, irreds)
+
tcImprove :: Avails -> TcM Bool -- False <=> no change
-- Perform improvement using all the predicates in Avails
tcImprove avails
- = tcGetInstEnvs `thenM` \ (home_ie, pkg_ie) ->
+ = tcGetInstEnvs `thenM` \ inst_envs ->
let
- preds = [ (pred, pp_loc)
+ preds = [ (dictPred inst, pp_loc)
| inst <- keysFM avails,
- let pp_loc = pprInstLoc (instLoc inst),
- pred <- fdPredsOfInst inst
+ isDict inst,
+ let pp_loc = pprInstLoc (instLoc inst)
]
-- Avails has all the superclasses etc (good)
-- It also has all the intermediates of the deduction (good)
-- It does not have duplicates (good)
-- NB that (?x::t1) and (?x::t2) will be held separately in avails
-- so that improve will see them separate
+ --
+ -- Notice that we only look at dicts; LitInsts and Methods will have
+ -- been squished, so their dicts will be in Avails too
eqns = improve get_insts preds
- get_insts clas = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas
+ get_insts clas = classInstances inst_envs clas
in
if null eqns then
returnM True
mappM_ unify eqns `thenM_`
returnM False
where
- unify ((qtvs, t1, t2), doc)
+ unify ((qtvs, pairs), doc)
= addErrCtxt doc $
tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
- unifyTauTy (substTy tenv t1) (substTy tenv t2)
+ mapM_ (unif_pr tenv) pairs
+ unif_pr tenv (ty1,ty2) = unifyTauTy (substTy tenv ty1) (substTy tenv ty2)
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
=
#ifdef DEBUG
(if n > 8 then
- pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
+ pprTrace "Interesting! Context reduction stack deeper than 8:"
+ (nest 2 (pprStack stack))
else (\x->x))
#endif
go wanteds state
| otherwise
= case try_me wanted of {
- DontReduce want_scs -> addIrred want_scs avails wanted
+ KeepDictWithoutSCs -> addIrred NoSCs avails wanted
; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
-- First, see if the inst can be reduced to a constant in one step
| not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts)
| otherwise
= case lookupInstEnv dflags inst_envs clas tys of
- res@(ms, _)
- | length ms > 1 -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts)
- | otherwise -> (overlap_doc, dict : no_inst_dicts) -- No match
- -- NB: there can be exactly one match, in the case where we have
- -- instance C a where ...
- -- (In this case, lookupInst doesn't bother to look up,
- -- unless -fallow-undecidable-instances is set.)
- -- So we report this as "no instance" rather than "overlap"; the fix is
- -- to specify -fallow-undecidable-instances, but we leave that to the programmer!
+ -- The case of exactly one match and no unifiers means
+ -- a successful lookup. That can't happen here.
+#ifdef DEBUG
+ ([m],[]) -> pprPanic "addNoInstanceErrs" (ppr dict)
+#endif
+ ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No match
+ res -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts)
where
(clas,tys) = getDictClassTys dict
in
+
+ -- Now generate a good message for the no-instance bunch
mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) ->
let
no_inst_doc | null no_inst_dicts = empty
| otherwise = sep [ptext SLIT("Could not deduce") <+> pprDictsTheta no_inst_dicts,
nest 2 $ ptext SLIT("from the context") <+> pprDictsTheta tidy_givens]
in
+ -- And emit both the non-instance and overlap messages
addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc)
-
where
mk_overlap_msg dict (matches, unifiers)
= vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for")
<+> pprPred (dictPred dict))),
sep [ptext SLIT("Matching instances") <> colon,
nest 2 (pprDFuns (dfuns ++ unifiers))],
- if null unifiers
- then empty
- else parens (ptext SLIT("The choice depends on the instantiation of") <+>
- quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))))]
+ ASSERT( not (null matches) )
+ if not (isSingleton matches)
+ then -- Two or more matches
+ empty
+ else -- One match, plus some unifiers
+ ASSERT( not (null unifiers) )
+ parens (vcat [ptext SLIT("The choice depends on the instantiation of") <+>
+ quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
+ ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])]
where
dfuns = [df | (_, (_,_,df)) <- matches]
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
- nest 4 (pprDictsInFull stack)]
+ nest 4 (pprStack stack)]
-reduceDepthMsg n stack = nest 4 (pprDictsInFull stack)
+pprStack stack = vcat (map pprInstInFull stack)
\end{code}
projects / ghc-hetmet.git / blobdiff