-- 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}
-- 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
-- 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
if (current_solns == new_solns) then
returnTc dfuns
else
- iterateDeriv new_solns
+ iterateDeriv (n+1) new_solns
------------------------------------------------------------------
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,