From d0781e4e82e84ea6463953f2bf7f9cee9569e69a Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 13 Apr 2007 16:54:59 +0000
Subject: [PATCH] Macro stepper: abbreviate quote etc when appropriate

svn: r5929

original commit: 80af3f491cf8d2fb619e1482d8f8890b1e0df390
---
 .../syntax-browser/pretty-helper.ss           | 51 +++++++++++++++----
 1 file changed, 42 insertions(+), 9 deletions(-)

diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss
index 38f7070..e819e2f 100644
--- a/collects/macro-debugger/syntax-browser/pretty-helper.ss
+++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss
@@ -1,12 +1,13 @@
 (module pretty-helper mzscheme
   (require (lib "class.ss")
+           (lib "stx.ss" "syntax")
            "partition.ss")
   (provide (all-defined))
-  
+
   ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
   ;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are 
   ;; indistinguishable.
-  
+
   ;; Solution: Rather than map stx to (syntax-e stx), in the cases where
   ;; (syntax-e stx) is confusable, map it to a different, unique, value.
   ;;   - stx is identifier : map it to an uninterned symbol w/ same rep
@@ -16,15 +17,15 @@
   ;; NOTE: Nulls are only wrapped when *not* list-terminators.  
   ;; If they were always wrapped, the pretty-printer would screw up
   ;; list printing (I think).
-  
+
   (define-struct syntax-dummy (val))
-  
+
   ;; A SuffixOption is one of
   ;; - 'never             -- never
   ;; - 'always            -- suffix > 0
   ;; - 'over-limit        -- suffix > limit
   ;; - 'all-if-over-limit -- suffix > 0 if any over limit
-  
+
   ;; syntax->datum/tables : stx [partition% num SuffixOption]
   ;;                        -> (values s-expr hashtable hashtable)
   ;; When partition is not false, tracks the partititions that subterms belong to
@@ -39,7 +40,7 @@
     (case-lambda
       [(stx) (table stx #f #f 'never)]
       [(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
-  
+
   ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
   (define (table stx partition limit suffixopt)
     (define (make-identifier-proxy id)
@@ -53,7 +54,7 @@
            (if (<= n limit)
                (unintern (syntax-e id))
                (suffix (syntax-e id) n))))))
-    
+
     (let/ec escape
       (let ([flat=>stx (make-hash-table)]
             [stx=>flat (make-hash-table)])
@@ -69,8 +70,19 @@
                    (hash-table-put! flat=>stx lp-datum obj)
                    (hash-table-put! stx=>flat obj lp-datum)
                    lp-datum)]
+                [(and (syntax? obj) (check+convert-special-expression obj))
+                 => (lambda (newobj)
+                      (when partition (send partition get-partition obj))
+                      (let* ([inner (cadr newobj)]
+                             [lp-inner-datum (loop inner)]
+                             [lp-datum (list (car newobj) lp-inner-datum)])
+                        (hash-table-put! flat=>stx lp-inner-datum inner)
+                        (hash-table-put! stx=>flat inner lp-inner-datum)
+                        (hash-table-put! flat=>stx lp-datum obj)
+                        (hash-table-put! stx=>flat obj lp-datum)
+                        lp-datum))]
                 [(syntax? obj)
-                 (void (send partition get-partition obj))
+                 (when partition (send partition get-partition obj))
                  (let ([lp-datum (loop (syntax-e obj))])
                    (hash-table-put! flat=>stx lp-datum obj)
                    (hash-table-put! stx=>flat obj lp-datum)
@@ -105,9 +117,30 @@
                 flat=>stx
                 stx=>flat))))
 
+  ;; check+convert-special-expression : syntax -> #f/syntaxish
+  (define (check+convert-special-expression stx)
+    (define stx-list (stx->list stx))
+    (and stx-list (= 2 (length stx-list))
+         (let ([kw (car stx-list)]
+               [expr (cadr stx-list)])
+           (and (identifier? kw)
+                (memq (syntax-e kw)
+                      '(quote quasiquote unquote unquote-splicing
+                              syntax quasisyntax unsyntax unsyntax-splicing))
+                (bound-identifier=? kw (datum->syntax-object stx (syntax-e kw)))
+                (andmap (lambda (f) (equal? (f stx) (f kw)))
+                        (list syntax-source
+                              syntax-line
+                              syntax-column
+                              syntax-position
+                              syntax-original?
+                              syntax-source-module))
+                (cons (syntax-e kw)
+                      (list expr))))))
+
   (define (unintern sym)
     (string->uninterned-symbol (symbol->string sym)))
-  
+
   (define (suffix sym n)
     (string->uninterned-symbol (format "~a:~a" sym n)))