Commit b08335c9 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-02-01 11:38:32 by simonpj]

More wibbles on deriving with -fallow-undecidable-instances
parent 70d2ef14
......@@ -148,6 +148,9 @@ type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the RHS
pprDerivEqn (n,c,tc,tvs,rhs)
= parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
type DerivRhs = ThetaType
type DerivSoln = DerivRhs
\end{code}
......@@ -486,7 +489,7 @@ solveDerivEqns :: InstEnv
-- This bunch is Absolutely minimal...
solveDerivEqns inst_env_in orig_eqns
= iterateDeriv initial_solutions
= iterateDeriv 1 initial_solutions
where
-- The initial solutions for the equations claim that each
-- instance has an empty context; this solution is certainly
......@@ -499,8 +502,14 @@ solveDerivEqns inst_env_in orig_eqns
-- compares it with the current one; finishes if they are the
-- same, otherwise recurses with the new solutions.
-- It fails if any iteration fails
iterateDeriv :: [DerivSoln] ->TcM [DFunId]
iterateDeriv current_solns
iterateDeriv :: Int -> [DerivSoln] ->TcM [DFunId]
iterateDeriv n current_solns
| n > 20 -- Looks as if we are in an infinite loop
-- This can happen if we have -fallow-undecidable-instances
-- (See TcSimplify.tcSimplifyDeriv.)
= pprPanic "solveDerivEqns: probable loop"
(vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
| otherwise
= getDOptsTc `thenNF_Tc` \ dflags ->
let
dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
......@@ -515,7 +524,7 @@ solveDerivEqns inst_env_in orig_eqns
if (current_solns == new_solns) then
returnTc dfuns
else
iterateDeriv new_solns
iterateDeriv (n+1) new_solns
------------------------------------------------------------------
......
......@@ -1738,30 +1738,38 @@ tcSimplifyDeriv tyvars theta
simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
doptsTc Opt_AllowUndecidableInstances `thenNF_Tc` \ undecidable_ok ->
let
tv_set = mkVarSet tvs
simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
check_pred pred
| isEmptyVarSet pred_tyvars -- Things like (Eq T) should be rejected
= addErrTc (noInstErr pred)
| not undecidable_ok && not (isTyVarClassPred pred)
-- Check that the returned dictionaries are all of form (C a b)
-- (where a, b are type variables).
-- At one time we allowed this if we had -fallow-undecidable-instances,
-- but that risks non-termination in the 'deriving' context-inference
-- fixpoint loop. If you want fancy stuff you just have to write the
-- instance decl yourself.
| not (isTyVarClassPred pred)
-- We allow this if we had -fallow-undecidable-instances,
-- but note that risks non-termination in the 'deriving' context-inference
-- fixpoint loop. It is useful for situations like
-- data Min h a = E | M a (h a)
-- which gives the instance decl
-- instance (Eq a, Eq (h a)) => Eq (Min h a)
= addErrTc (noInstErr pred)
| not (pred_tyvars `subVarSet` tv_set)
-- Check for a bizarre corner case, when the derived instance decl should
-- have form instance C a b => D (T a) where ...
-- Note that 'b' isn't a parameter of T. This gives rise to all sorts
-- of problems; in particular, it's hard to compare solutions for
-- equality when finding the fixpoint. So I just rule it out for now.
| not (tyVarsOfPred pred `subVarSet` tv_set)
= addErrTc (badDerivedPred pred)
| otherwise
= returnNF_Tc ()
where
pred_tyvars = tyVarsOfPred pred
rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
......
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