www

commit 32a5cfb1ac5049132e837f84c2789fa1e9524fce
parent dc2563194401122cbb7c177b631863971046a7ef
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Tue, 29 Nov 2011 11:53:37 -0700

macro-stepper: display binding info for phases -5 to 5, clean up

original commit: 7fbd232c772787f0a82f35fa03fc6b3fd896e132

Diffstat:
M
collects/macro-debugger/syntax-browser/properties.rkt
 | 
60
++++++++++++++++++++++++++++++++++--------------------------

1 file changed, 34 insertions(+), 26 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/class
+         racket/match
          racket/gui/base
          framework
          unstable/class-iop
@@ -174,28 +175,44 @@
 
     ;; display-bindings : syntax -> void
     (define/private (display-bindings stx)
+      (define phases-to-search '(0 1 -1 #f 2 3 4 5 -2 -3 -4 -5))
       (unless (identifier? stx)
         (display "Not applicable\n\n" n/a-sd))
       (when (identifier? stx)
-        (if (eq? (identifier-binding stx) 'lexical)
-            (display "lexical (all phases)\n" #f)
-            (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx)))
-                      binding-properties))
+        (cond [(eq? (identifier-binding stx) 'lexical)
+               (display "lexical (all phases)\n" #f)]
+              [else
+               (let ([bindings (for/hash ([phase (in-list phases-to-search)])
+                                 (values phase (identifier-binding stx phase)))])
+                 (cond [(for/or ([(p b) (in-hash bindings)]) b)
+                        (for ([phase (in-list phases-to-search)])
+                          (display-binding-kvs phase (hash-ref bindings phase #f) stx))]
+                       [else (display "none\n" #f)]))])
         (display "\n" #f)))
 
-    ;; display-binding-kvs : string bindinginfo -> void
-    (define/private (display-binding-kvs k v)
-      (display k sub-key-sd)
-      (display "\n" #f)
-      (cond [(eq? v #f)
-             (display "  top-level or unbound\n" #f)]
-            [(list? v)
-             (display-subkv "  defined in" (mpi->string (list-ref v 0)))
-             (display-subkv "  as" (list-ref v 1))
-             (display-subkv "  imported from" (mpi->string (list-ref v 2)))
-             (display-subkv "  as" (list-ref v 3))
-             (when (list-ref v 4)
-               (display "  via define-for-syntax\n" sub-key-sd))]))
+    ;; display-binding-kvs : phase bindinginfo identifier -> void
+    (define/private (display-binding-kvs phase v stx)
+      (when v
+        (display (format "in phase ~a~a:"
+                         phase
+                         (case phase
+                           ((1) " (transformer phase)")
+                           ((-1) " (template phase)")
+                           ((#f) " (label phase)")
+                           (else "")))
+                 sub-key-sd)
+        (display "\n" #f)
+        (match v
+          [(list* def-mpi def-sym imp-mpi imp-sym defined-at-phase _)
+           (display-subkv "  defined in" (mpi->string def-mpi))
+           (unless (eq? def-sym (syntax-e stx))
+             (display-subkv "    as" def-sym))
+           (display-subkv "  imported from" (mpi->string imp-mpi))
+           (unless (eq? imp-sym (syntax-e stx))
+             (display-subkv "    provided as" (list-ref v 3)))
+           (unless (zero? defined-at-phase)
+             (display-subkv "  defined at phase" defined-at-phase))]
+          [_ (void)])))
 
     ;; display-stxobj-info : syntax -> void
     (define/public (display-stxobj-info stx)
@@ -304,15 +321,6 @@
 (define (lift/id f)
   (lambda (stx) (when (identifier? stx) (f stx))))
 
-;; binding-properties : (listof (cons string (syntax -> any)))
-(define binding-properties
-  (list (cons "in the standard phase"
-              (lift/id identifier-binding))
-        (cons "in the transformer phase (\"for-syntax\")"
-              (lift/id identifier-transformer-binding))
-        (cons "in the template phase (\"for-template\")"
-              (lift/id identifier-template-binding))))
-
 (define (uninterned? s)
   (not (eq? s (string->symbol (symbol->string s)))))