From: simonpj <unknown>
Date: Fri, 1 Feb 2002 11:38:33 +0000 (+0000)
Subject: [project @ 2002-02-01 11:38:32 by simonpj]
X-Git-Tag: Approximately_9120_patches~191
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b08335c943c8a31e298e02ff776c1844e0536257;p=ghc-hetmet.git

[project @ 2002-02-01 11:38:32 by simonpj]
More wibbles on deriving with -fallow-undecidable-instances
---

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index de7b2b3..6655ad0 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -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
 
     ------------------------------------------------------------------
 
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 775cf75..13c847f 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -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,