Custom printer for the Term datatype that won't output TypeRep values

The term pretty printer used by :print shouldn't output 
the contents of TypeRep values, e.g. inside Dynamic values

2 files changed, 53 insertions, 9 deletions

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 36c784b238..cc0d5baa48 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -23,7 +23,7 @@ import Var hiding ( varName )
 import VarSet
 import Name 
 import UniqSupply
-import TcType
+import Type
 import GHC
 import InteractiveEval
 import Outputable
@@ -138,10 +138,11 @@ bindSuspensions cms@(Session ref) t = do
 
 --  A custom Term printer to enable the use of Show instances
 showTerm :: Session -> Term -> IO SDoc
-showTerm cms@(Session ref) = cPprTerm cPpr
+showTerm cms@(Session ref) term = do
+    cPprExtended <- cPprTermExtended cms
+    cPprTerm (liftM2 (++) cPprShowable cPprExtended) term
  where
-  cPpr = \p-> cPprShowable : cPprTermBase p
-  cPprShowable prec ty _ val tt = 
+  cPprShowable _y = [\prec ty _ val tt ->
     if not (all isFullyEvaluatedTerm tt)
      then return Nothing
      else do
@@ -164,7 +165,7 @@ showTerm cms@(Session ref) = cPprTerm cPpr
              _  -> return Nothing
          `finally` do
            writeIORef ref hsc_env
-           GHC.setSessionDynFlags cms dflags
+           GHC.setSessionDynFlags cms dflags]
   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
                                 -- are redundant in an arbitrary Show output
   needsParens ('(':_) = False
@@ -179,6 +180,27 @@ showTerm cms@(Session ref) = cPprTerm cPpr
         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
     return (hsc_env {hsc_IC = new_ic }, name)
 
+{- | A custom Term printer to handle some types that 
+     we may not want to show, such as Data.Typeable.TypeRep -}
+cPprTermExtended :: Monad m => Session -> IO (CustomTermPrinter m)
+cPprTermExtended session = liftM22 (++) (return cPprTermBase) extended
+  where 
+   extended = do
+     [typerep_name]        <- parseName session "Data.Typeable.TypeRep"
+     Just (ATyCon typerep) <- lookupName session typerep_name 
+
+     return (\_y -> 
+        [ ifType (isTyCon typerep) (\_val _prec -> return (text "<typerep>")) ])
+
+   ifType pred f prec ty _ val _tt
+      | pred ty   = Just `liftM` f prec val
+      | otherwise = return Nothing
+   isTyCon a_tc ty = fromMaybe False $ do 
+             (tc,_) <- splitTyConApp_maybe ty
+             return (a_tc == tc)
+   liftM22 f x y = do x' <- x; y' <- y
+                      return$ do x'' <- x';y'' <- y';return (f x'' y'')
+
 --    Create new uniques and give them sequentially numbered names
 newGrimName :: String -> IO Name
 newGrimName userName  = do
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index a05830eb65..945e752de0 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -17,6 +17,7 @@ module RtClosureInspect(
      pprTerm, 
      cPprTerm, 
      cPprTermBase,
+     CustomTermPrinter,
      termType,
      foldTerm, 
      TermFold(..), 
@@ -297,6 +298,7 @@ termTyVars = foldTerm TermFold {
                           maybe emptyVarEnv tyVarsOfType mb_ty,
             fPrim       = \ _ _ -> emptyVarEnv }
     where concatVarEnv = foldr plusVarEnv emptyVarEnv
+
 ----------------------------------
 -- Pretty printing of terms
 ----------------------------------
@@ -341,12 +343,32 @@ pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty 
 pprTermM1 _ = panic "pprTermM1"
 
-type CustomTermPrinter m = Int -> TermProcessor Term (m (Maybe SDoc))
+-------------------------------------------------------
+-- Custom Term Pretty Printers
+-------------------------------------------------------
+
+-- We can want to customize the representation of a 
+--  term depending on its type. 
+-- However, note that custom printers have to work with
+--  type representations, instead of directly with types.
+-- We cannot use type classes here, unless we employ some 
+--  typerep trickery (e.g. Weirich's RepLib tricks),
+--  which I didn't. Therefore, this code replicates a lot
+--  of what type classes provide for free.
+
+-- Concretely a custom term printer takes an explicit
+--  recursion knot, and produces a list of Term Processors,
+--  which additionally need a precedence value to
+--  either produce a SDoc or fail (and they do this in some monad m).
+
+type Precedence          = Int
+type RecursionKnot m     = Int-> Term -> m SDoc
+type CustomTermPrinter m = RecursionKnot m
+                         -> [Precedence -> TermProcessor Term (m (Maybe SDoc))]
 
 -- Takes a list of custom printers with a explicit recursion knot and a term, 
 -- and returns the output of the first succesful printer, or the default printer
-cPprTerm :: Monad m => 
-           ((Int->Term->m SDoc)->[CustomTermPrinter m]) -> Term -> m SDoc
+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 cPprTerm printers_ = go 0 where
   printers = printers_ go
   go prec t@(Term ty dc val tt) = do
@@ -359,7 +381,7 @@ cPprTerm printers_ = go 0 where
   firstJustM [] = return Nothing
 
 -- Default set of custom printers. Note that the recursion knot is explicit
-cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[CustomTermPrinter m]
+cPprTermBase :: Monad m => CustomTermPrinter m
 cPprTermBase y =
   [ 
     ifTerm isTupleTy             (\ _ _ tt ->