From 593b7f500268c3eb28146b3e6b46fedd8dba2a2a Mon Sep 17 00:00:00 2001
From: Pepe Iborra <mnislaih@gmail.com>
Date: Tue, 11 Sep 2007 18:04:11 +0000
Subject: [PATCH] Refactoring & documenting the Term pprinter used by :print

---
 compiler/ghci/Debugger.hs         |    7 +++----
 compiler/ghci/RtClosureInspect.hs |   30 ++++++++++++++++++++++++++----
 2 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 36c784b..179f684 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -138,10 +138,9 @@ 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) = cPprTerm (liftM2 (++) cPprShowable cPprTermBase)
  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 +163,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
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index a05830e..945e752 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 -> 
-- 
1.7.10.4