From 6f6a582d5c7ca02a660215ea81ede914d340895a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 27 Jun 2008 22:07:28 +0000
Subject: [PATCH] fix pretty-print so that special handling of 'lambda',
 'quote', etc. doesn't hide sharing that shoul dbe displayed

svn: r10482

original commit: 69b4ffc7c0f86562d72da0c1ab8f7fa37c236d72
---
 collects/mzlib/pretty.ss | 63 +++++++++++++++++++++++++++-------------
 1 file changed, 43 insertions(+), 20 deletions(-)

diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss
index ecafde5..b48d95c 100644
--- a/collects/mzlib/pretty.ss
+++ b/collects/mzlib/pretty.ss
@@ -859,7 +859,8 @@
 	       (wr* pport obj depth display?))))
 
        (define (pp-expr expr extra depth)
-	 (if (read-macro? expr pair? car cdr)
+	 (if (and (read-macro? expr pair? car cdr)
+                  (not (and found (hash-table-get found (cdr expr) #f))))
 	     (begin
 	       (out (read-macro-prefix expr car))
 	       (pr (read-macro-body expr car cdr)
@@ -870,16 +871,18 @@
 	       (if (or (and (symbol? head)
                             (not (size-hook head display?)))
                        ((pretty-print-remap-stylable) head))
-		   (let ((proc (style head)))
+		   (let ((proc (style head expr)))
 		     (if proc
 			 (proc expr extra depth)
-			 (if (> (string-length 
-                                 (symbol->string
-                                  (if (symbol? head)
-                                      head
-                                      ((pretty-print-remap-stylable) head))))
-				max-call-head-width)
-			     (pp-general expr extra #f #f #f pp-expr depth)
+			 (if (and #f
+                                  ;; Why this special case? Currently disabled.
+                                  (> (string-length 
+                                      (symbol->string
+                                       (if (symbol? head)
+                                           head
+                                           ((pretty-print-remap-stylable) head))))
+                                     max-call-head-width))
+                             (pp-general expr extra #f #f #f pp-expr depth)
 			     (pp-list expr extra pp-expr #t depth))))
 		   (pp-list expr extra pp-expr #t depth)))))
 
@@ -1035,38 +1038,58 @@
 
        (define max-call-head-width 5)
 
-       (define (style head)
+       (define (no-sharing? expr count)
+         (if (and found (hash-table-get found (cdr expr) #f))
+             #f
+             (or (zero? count)
+                 (no-sharing? (cdr expr) (sub1 count)))))
+
+       (define (style head expr)
          (case (look-in-style-table head)
 	   ((lambda λ define define-macro define-syntax
 		    syntax-rules
 		    shared
 		    unless when)
-	    pp-lambda)
+            (and (no-sharing? expr 1)
+                 pp-lambda))
 	   ((if set! set!-values)
-	    pp-if)
+            (and (no-sharing? expr 1)
+                 pp-if))
 	   ((cond case-lambda)
-	    pp-cond)
+            (and (no-sharing? expr 0)
+                 pp-cond))
 	   ((case) 
-	    pp-case)
+            (and (no-sharing? expr 1)
+                 pp-case))
 	   ((and or import export 
 		 require require-for-syntax require-for-template 
 		 provide link
 		 public private override rename inherit field init)
-	    pp-and)
+            (and (no-sharing? expr 0)
+                 pp-and))
 	   ((let letrec let*
 	      let-values letrec-values let*-values
 	      let-syntax letrec-syntax
 	      let-syntaxes letrec-syntaxes)
-	    pp-let)
+            (and (no-sharing? expr
+                              (if (and (pair? (cdr expr))
+                                       (symbol? (cadr expr)))
+                                  2
+                                  1))
+                 pp-let))
 	   ((begin begin0)
-	    pp-begin)
+            (and (no-sharing? expr 0)
+                 pp-begin))
 	   ((do letrec-syntaxes+values)
-	    pp-do)
+            (and (no-sharing? expr 2)
+                 pp-do))
 
 	   ((send class syntax-case instantiate module)
-	    pp-class)
+            (and (no-sharing? expr 2)
+                 pp-class))
 	   ((make-object)
-	    pp-make-object)
+            (and (no-sharing? expr 1)
+                 pp-make-object))
 
 	   (else #f)))