commit bd5be74aae4a58176bd6582208e9920ca00bb100
parent 186dfbe1e4158fbb2c9420d243de91cf9f3bd26d
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 9 Nov 2010 16:13:34 -0700
macro-stepper: track phase of binders, definites
original commit: 3936a4071771a8f40f457e760cf529511ab673de
Diffstat:
5 files changed, 79 insertions(+), 72 deletions(-)
diff --git a/collects/macro-debugger/model/reductions-config.rkt b/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-binders (parameter/c (listof identifier?))]
+ [current-definites (parameter/c eomap?)] ;; eomap[identifier => phase-level]
+ [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)
-(define current-binders (make-parameter null))
+;; current-binders : parameter of hash[identifier => phase-level]
+(define current-binders (make-parameter #f))
-;; current-definites : parameter of (list-of identifier)
-(define current-definites (make-parameter null))
+;; current-definites : parameter of eomap[identifier => phase-level]
+(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))
diff --git a/collects/macro-debugger/model/reductions.rkt b/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)
- (current-binders null)
+ (parameterize ((current-definites (empty-eomap))
+ (current-binders #hasheq())
(current-frontier null)
(hides-flags (list (box #f)))
(sequence-number 0))
diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/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?
- (let* ([?x (+ endx dx fw)]
- [?y (- (+ endy dy) fh)])
+ (when label
+ (let* ([lx (+ endx dx fw)]
+ [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)
- (+ fw _d _d) (+ fh _d _d))
- (draw-text "?" ?x ?y))))))))])
+ (draw-rounded-rectangle (- lx ld) (- ly ld)
+ (+ lw ld ld) (+ lh ld ld))
+ (draw-text label lx ly))))))))])
(add-hover-drawing from1 from2 draw tack-box)
(add-hover-drawing to1 to2 draw tack-box))))
diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/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))
- binders))
+ (let ([binder-list (hash-map binders (lambda (k v) k))])
+ (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))
- (for ([definite (in-list definites)])
- (hash-set! definite-table definite #t)
- (when shift-table
- (for ([shifted-definite (in-list (hash-ref shift-table definite null))])
- (hash-set! definite-table shifted-definite #t))))
-
- (define binder-table (make-free-id-table))
- (for ([binder (in-list binders)])
- (free-id-table-set! binder-table binder binder))
-
- (define (get-binders id)
- (let ([binder (free-id-table-ref binder-table id #f)])
- (cond [(not binder) null]
- [shift-table (cons binder (get-shifted binder))]
- [else (list binder)])))
+ (define (definite-phase id)
+ (and definites
+ (or (eomap-ref definites id #f)
+ (for/or ([shifted (in-list (hash-ref shift-table id null))])
+ (eomap-ref definites shifted #f)))))
+
+ (define phase-binder-table (make-hash))
+ (define (get-binder-table phase)
+ (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 phase)
+ (define (for-one-table table id)
+ (let ([binder (free-id-table-ref table id #f)])
+ (cond [(not binder) null]
+ [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?))
- (for ([binder (in-list (get-binders id))])
+ (add-binding-billboard offset range id phase))
+ (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?)
- (if definite?
- (send -text add-arrow
- (+ start (car binder-r))
- (+ start (cdr binder-r))
- (+ start (car id-r))
- (+ start (cdr id-r))
- "blue")
- (send -text add-question-arrow
- (+ start (car binder-r))
- (+ start (cdr binder-r))
- (+ start (car id-r))
- (+ start (cdr id-r))
- "purple")))
+ (define/private (add-binding-arrow start binder-r id-r phase)
+ ;; phase = #f means not definite binding (ie, "?" arrow)
+ (send -text add-arrow
+ (+ start (car binder-r))
+ (+ start (cdr binder-r))
+ (+ start (car id-r))
+ (+ start (cdr id-r))
+ (if phase "blue" "purple")
+ (cond [(equal? phase 0) #f]
+ [phase (format "phase ~s" phase)]
+ [else "?"])
+ (if phase 'end 'start)))
(define/private (add-binding-billboard start range id definite?)
(match (identifier-binding id)
diff --git a/collects/macro-debugger/view/step-display.rkt b/collects/macro-debugger/view/step-display.rkt
@@ -84,8 +84,8 @@
(show-poststep step shift-table)]))
(define/public (add-syntax stx
- #:binders [binders null]
- #:definites [definites null]
+ #:binders [binders #f]
+ #: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)
- #:definites (or (state-uses state) null)
+ #:binders (state-binders state)
+ #: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)
- #:definites (or (state-uses state) null)
+ #:binders (state-binders state)
+ #: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
