commit d0781e4e82e84ea6463953f2bf7f9cee9569e69a
parent ce40ab867297c9c736796028576a51332bf71eb0
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 13 Apr 2007 16:54:59 +0000
Macro stepper: abbreviate quote etc when appropriate
svn: r5929
original commit: 80af3f491cf8d2fb619e1482d8f8890b1e0df390
Diffstat:
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
@@ -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)))
