macro-stepper: track phase of binders, definites

original commit: 3936a4071771a8f40f457e760cf529511ab673de

collects/macro-debugger/model/reductions-config.rkt

@@ -2,6 +2,7 @@
 (require (for-syntax racket/base)
          racket/contract
          racket/match
+         "../util/eomap.rkt"
          "deriv-util.rkt"
          "stx-util.rkt"
          "context.rkt"
@@ -33,8 +34,8 @@
  [big-context (parameter/c big-context/c)]
  [marking-table (parameter/c (or/c hash? false/c))]
  [current-binders (parameter/c (listof identifier?))]
- [current-definites (parameter/c (listof identifier?))]
+ [current-definites (parameter/c eomap?)] ;; eomap[identifier => phase-level]
- [current-binders (parameter/c (listof identifier?))]
+ [current-binders (parameter/c hash?)] ;; hash[identifier => phase-level]
  [current-frontier (parameter/c (listof syntax?))]
  [sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))]
  [phase (parameter/c exact-nonnegative-integer?)]
@@ -80,11 +81,11 @@
 ;; marking-table
 (define marking-table (make-parameter #f))
 
-;; current-binders : parameterof (listof identifier)
+;; current-binders : parameter of hash[identifier => phase-level]
-(define current-binders (make-parameter null))
+(define current-binders (make-parameter #f))
 
-;; current-definites : parameter of (list-of identifier)
+;; current-definites : parameter of eomap[identifier => phase-level]
-(define current-definites (make-parameter null))
+(define current-definites (make-parameter #f))
 
 ;; current-frontier : parameter of (list-of syntax)
 (define current-frontier (make-parameter null))
@@ -149,11 +150,12 @@
 
 (define (learn-definites ids)
   (current-definites
-   (append ids (current-definites))))
+   (eomap-set* (current-definites) ids (phase))))
 
 (define (learn-binders ids)
   (current-binders
-   (append ids (current-binders))))
+   (for/fold ([binders (current-binders)]) ([id (in-list ids)])
+     (hash-set binders id (phase)))))
 
 (define (get-frontier) (or (current-frontier) null))
 

collects/macro-debugger/model/reductions.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/match
+         "../util/eomap.rkt"
          "stx-util.rkt"
          "deriv-util.rkt"
          "deriv.rkt"
@@ -15,10 +16,13 @@
   (let-values ([(steps binders definites estx exn) (reductions+ d)])
     steps))
 
-;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
+;; Binders = hasheq[identifier => phase-level]
+;; Definites = eomap[identifier => phase-level]
+
+;; reductions+ : WDeriv -> (list-of step) Binders Definites ?stx ?exn
 (define (reductions+ d)
-  (parameterize ((current-definites null)
+  (parameterize ((current-definites (empty-eomap))
-                 (current-binders null)
+                 (current-binders #hasheq())
                  (current-frontier null)
                  (hides-flags (list (box #f)))
                  (sequence-number 0))

collects/macro-debugger/syntax-browser/text.rkt

@@ -85,7 +85,6 @@
 (define text:arrows<%>
   (interface (text:hover-drawings<%>)
     add-arrow
-    add-question-arrow
     add-billboard))
 
 ;; Mixins
@@ -234,12 +233,6 @@
              add-hover-drawing
              find-wordbreak)
 
-    (define/public (add-arrow from1 from2 to1 to2 color)
-      (internal-add-arrow from1 from2 to1 to2 color #f))
-
-    (define/public (add-question-arrow from1 from2 to1 to2 color)
-      (internal-add-arrow from1 from2 to1 to2 color #t))
-
     (define/public (add-billboard pos1 pos2 str color-name)
       (define color (send the-color-database find-color color-name))
       (let ([draw 
@@ -266,7 +259,7 @@
                          (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
         (add-hover-drawing pos1 pos2 draw)))
 
-    (define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
+    (define/public (add-arrow from1 from2 to1 to2 color-name label where)
       (define color (send the-color-database find-color color-name))
       (define tack-box (box #f))
       (unless (and (= from1 to1) (= from2 to2))
@@ -274,7 +267,8 @@
                (lambda (text dc left top right bottom dx dy)
                  (let-values ([(startx starty) (range->mean-loc from1 from2)]
                               [(endx endy) (range->mean-loc to1 to2)]
-                              [(fw fh _d _v) (send dc get-text-extent "x")])
+                              [(fw fh _d _v) (send dc get-text-extent "x")]
+                              [(lw lh ld _V) (send dc get-text-extent (or label "x"))])
                    (with-saved-pen&brush dc
                      (with-saved-text-config dc
                        (send dc set-pen color 1 'solid)
@@ -287,16 +281,16 @@
                                    endx
                                    (+ endy (/ fh 2))
                                    dx dy)
-                       (when question?
+                       (when label
-                         (let* ([?x (+ endx dx fw)]
+                         (let* ([lx (+ endx dx fw)]
-                                [?y (- (+ endy dy) fh)])
+                                [ly (- (+ endy dy) fh)])
                            (send* dc
                              (set-brush billboard-brush)
-                             (set-font (?-font dc))
+                             (set-font (billboard-font dc))
                              (set-text-foreground color)
-                             (draw-rounded-rectangle (- ?x _d) (- ?y _d)
+                             (draw-rounded-rectangle (- lx ld) (- ly ld)
-                                                     (+ fw _d _d) (+ fh _d _d))
+                                                     (+ lw ld ld) (+ lh ld ld))
-                             (draw-text "?" ?x ?y))))))))])
+                             (draw-text label lx ly))))))))])
           (add-hover-drawing from1 from2 draw tack-box)
           (add-hover-drawing to1 to2 draw tack-box))))
 

collects/macro-debugger/syntax-browser/widget.rkt

@@ -14,6 +14,7 @@
          "properties.rkt"
          "text.rkt"
          "util.rkt"
+         "../util/eomap.rkt"
          "../util/mpi.rkt")
 (provide widget%)
 
@@ -106,9 +107,9 @@
             (send -text change-style clickback-style a b)))))
 
     (define/public (add-syntax stx
-                               #:binders [binders null]
+                               #:binders [binders #f]
                                #:shift-table [shift-table #f]
-                               #:definites [definites null]
+                               #:definites [definites #f]
                                #:hi-colors [hi-colors null]
                                #:hi-stxss [hi-stxss null]
                                #:substitutions [substitutions null])
@@ -138,53 +139,59 @@
           (send/i display display<%> highlight-syntaxes hi-stxs hi-color))
         ;; Underline binders (and shifted binders)
         (send/i display display<%> underline-syntaxes
-                (append (apply append (map get-shifted binders))
+                (let ([binder-list (hash-map binders (lambda (k v) k))])
-                        binders))
+                  (append (apply append (map get-shifted binder-list))
+                          binder-list)))
         (send display refresh)
 
         ;; Make arrows (& billboards, when enabled)
         (when (send config get-draw-arrows?)
-          (define definite-table (make-hasheq))
+          (define (definite-phase id)
-          (for ([definite (in-list definites)])
+            (and definites
-            (hash-set! definite-table definite #t)
+                 (or (eomap-ref definites id #f)
-            (when shift-table
+                     (for/or ([shifted (in-list (hash-ref shift-table id null))])
-              (for ([shifted-definite (in-list (hash-ref shift-table definite null))])
+                       (eomap-ref definites shifted #f)))))
-                (hash-set! definite-table shifted-definite #t))))
 
-          (define binder-table (make-free-id-table))
+          (define phase-binder-table (make-hash))
-          (for ([binder (in-list binders)])
+          (define (get-binder-table phase)
-            (free-id-table-set! binder-table binder binder))
+            (hash-ref! phase-binder-table phase (lambda () (make-free-id-table #:phase phase))))
+          (for ([(binder phase) (in-hash binders)])
+            (free-id-table-set! (get-binder-table phase) binder binder))
 
-          (define (get-binders id)
+          (define (get-binders id phase)
-            (let ([binder (free-id-table-ref binder-table id #f)])
+            (define (for-one-table table id)
-              (cond [(not binder) null]
+              (let ([binder (free-id-table-ref table id #f)])
-                    [shift-table (cons binder (get-shifted binder))]
+                (cond [(not binder) null]
-                    [else (list binder)])))
+                      [shift-table (cons binder (get-shifted binder))]
+                      [else (list binder)])))
+            (cond [phase (for-one-table (get-binder-table phase) id)]
+                  [else
+                   (apply append
+                          (for/list ([table (in-hash-values phase-binder-table)])
+                            (for-one-table table id)))]))
 
           (for ([id (in-list (send/i range range<%> get-identifier-list))])
-            (define definite? (hash-ref definite-table id #f))
+            (define phase (definite-phase id))
             (when #f ;; DISABLED
-              (add-binding-billboard offset range id definite?))
+              (add-binding-billboard offset range id phase))
-            (for ([binder (in-list (get-binders id))])
+            (for ([binder (in-list (get-binders id phase))])
               (for ([binder-r (in-list (send/i range range<%> get-ranges binder))])
                 (for ([id-r (in-list (send/i range range<%> get-ranges id))])
-                  (add-binding-arrow offset binder-r id-r definite?))))))
+                  (add-binding-arrow offset binder-r id-r phase))))))
         (void)))
 
-    (define/private (add-binding-arrow start binder-r id-r definite?)
+    (define/private (add-binding-arrow start binder-r id-r phase)
-      (if definite?
+      ;; phase = #f means not definite binding (ie, "?" arrow)
-          (send -text add-arrow
+      (send -text add-arrow
-                (+ start (car binder-r))
+            (+ start (car binder-r))
-                (+ start (cdr binder-r))
+            (+ start (cdr binder-r))
-                (+ start (car id-r))
+            (+ start (car id-r))
-                (+ start (cdr id-r))
+            (+ start (cdr id-r))
-                "blue")
+            (if phase "blue" "purple")
-          (send -text add-question-arrow
+            (cond [(equal? phase 0) #f]
-                (+ start (car binder-r))
+                  [phase (format "phase ~s" phase)]
-                (+ start (cdr binder-r))
+                  [else "?"])
-                (+ start (car id-r))
+            (if phase 'end 'start)))
-                (+ start (cdr id-r))
-                "purple")))
 
     (define/private (add-binding-billboard start range id definite?)
       (match (identifier-binding id)

collects/macro-debugger/view/step-display.rkt

@@ -84,8 +84,8 @@
              (show-poststep step shift-table)]))
 
     (define/public (add-syntax stx
-                               #:binders [binders null]
+                               #:binders [binders #f]
-                               #:definites [definites null]
+                               #:definites [definites #f]
                                #:shift-table [shift-table #f])
       (send/i sbview sb:syntax-browser<%> add-syntax stx
               #:binders binders
@@ -215,8 +215,8 @@
       (when (exn:fail:syntax? (misstep-exn step))
         (for ([e (exn:fail:syntax-exprs (misstep-exn step))])
           (send/i sbview sb:syntax-browser<%> add-syntax e
-                  #:binders (or (state-binders state) null)
+                  #:binders (state-binders state)
-                  #:definites (or (state-uses state) null)
+                  #:definites (state-uses state)
                   #:shift-table shift-table)))
       (show-lctx step shift-table))
 
@@ -230,8 +230,8 @@
               [(syntax? content)
                (send*/i sbview sb:syntax-browser<%>
                  (add-syntax content
-                             #:binders (or (state-binders state) null)
+                             #:binders (state-binders state)
-                             #:definites (or (state-uses state) null)
+                             #:definites (state-uses state)
                              #:shift-table shift-table)
                  (add-text "\n"))]))
       (show-lctx step shift-table))
@@ -242,7 +242,7 @@
       (define highlight-foci? (send/i config config<%> get-highlight-foci?))
       (define highlight-frontier? (send/i config config<%> get-highlight-frontier?))
       (send/i sbview sb:syntax-browser<%> add-syntax stx
-              #:definites (or definites null)
+              #:definites definites
               #:binders binders
               #:shift-table shift-table
               #:hi-colors (list hi-color