From 2407332d08c68d053b70ab1447257803e041c21d Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 17 Mar 2004 10:12:33 +0000
Subject: [PATCH] [project @ 2004-03-17 10:12:31 by simonpj] Fix
 debug-printing for Insts

---
 ghc/compiler/typecheck/Inst.lhs       |   17 +++++++++++------
 ghc/compiler/typecheck/TcSimplify.lhs |    9 +++++----
 2 files changed, 16 insertions(+), 10 deletions(-)

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index eaf433e..655684a 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -5,10 +5,11 @@
 
 \begin{code}
 module Inst ( 
-	showLIE,
-
 	Inst, 
-	pprInst, pprInsts, pprDFuns, pprDictsTheta, pprDictsInFull,
+
+	pprDFuns, pprDictsTheta, pprDictsInFull,	-- User error messages
+	showLIE, pprInst, pprInsts, pprInstInFull,	-- Debugging messages
+
 	tidyInsts, tidyMoreInsts,
 
 	newDictsFromOld, newDicts, cloneDict, 
@@ -705,8 +706,9 @@ lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 	; 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" <+> vcat [text "matches" <+> ppr matches,
-					       text "unifs" <+> ppr unifs])
+	{ 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 
@@ -718,7 +720,10 @@ lookupInst (Dict _ _ _) = returnM NoInstance
 
 -----------------
 instantiate_dfun tenv dfun_id pred loc
-  = 	-- Record that this dfun is needed
+  = 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_`
 
  	-- It's possible that not all the tyvars are in
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 3c0ac28..91ca3b8 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -35,7 +35,7 @@ import Inst		( lookupInst, LookupInstResult(..),
 			  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 )
@@ -1509,7 +1509,8 @@ reduceList (n,stack) try_me wanteds state
   =
 #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
@@ -2281,7 +2282,7 @@ badDerivedPred pred
 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}
-- 
1.7.10.4