[project @ 2004-03-17 10:12:31 by simonpj]

Fix debug-printing for Insts

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index eaf433e..655684a 100644 (file)
--- 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 (file)
--- 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}