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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index cc0d5ba..36c784b 100644 (file)
--- 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 Type
+import TcType
 import GHC
 import InteractiveEval
 import Outputable
@@ -138,11 +138,10 @@ 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) term = do
-    cPprExtended <- cPprTermExtended cms
-    cPprTerm (liftM2 (++) cPprShowable cPprExtended) term
+showTerm cms@(Session ref) = cPprTerm cPpr
  where
-  cPprShowable _y = [\prec ty _ val tt ->
+  cPpr = \p-> cPprShowable : cPprTermBase p
+  cPprShowable prec ty _ val tt = 
     if not (all isFullyEvaluatedTerm tt)
      then return Nothing
      else do
@@ -165,7 +164,7 @@ showTerm cms@(Session ref) term = do
              _  -> 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
@@ -180,27 +179,6 @@ showTerm cms@(Session ref) term = do
         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 945e752..a05830e 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -17,7 +17,6 @@ module RtClosureInspect(
      pprTerm, 
      cPprTerm, 
      cPprTermBase,
-     CustomTermPrinter,
      termType,
      foldTerm, 
      TermFold(..), 
@@ -298,7 +297,6 @@ termTyVars = foldTerm TermFold {
                           maybe emptyVarEnv tyVarsOfType mb_ty,
             fPrim       = \ _ _ -> emptyVarEnv }
     where concatVarEnv = foldr plusVarEnv emptyVarEnv
-
 ----------------------------------
 -- Pretty printing of terms
 ----------------------------------
@@ -343,32 +341,12 @@ pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty 
 pprTermM1 _ = panic "pprTermM1"
 
--------------------------------------------------------
--- 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))]
+type CustomTermPrinter m = Int -> 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 => CustomTermPrinter m -> Term -> m SDoc
+cPprTerm :: Monad m => 
+           ((Int->Term->m SDoc)->[CustomTermPrinter m]) -> Term -> m SDoc
 cPprTerm printers_ = go 0 where
   printers = printers_ go
   go prec t@(Term ty dc val tt) = do
@@ -381,7 +359,7 @@ cPprTerm printers_ = go 0 where
   firstJustM [] = return Nothing
 
 -- Default set of custom printers. Note that the recursion knot is explicit
-cPprTermBase :: Monad m => CustomTermPrinter m
+cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[CustomTermPrinter m]
 cPprTermBase y =
   [ 
     ifTerm isTupleTy             (\ _ _ tt ->