diff --git a/collects/macro-debugger/model/reductions-config.rkt b/collects/macro-debugger/model/reductions-config.rkt index f1c7848..661e95c 100644 --- 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 index f53cbc4..925d3f2 100644 --- 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 index 95c657f..7d00531 100644 --- 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 index 87f0aac..93783f3 100644 --- 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 (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 binder-table (make-free-id-table)) - (for ([binder (in-list binders)]) - (free-id-table-set! binder-table binder binder)) + (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) - (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 (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 index 28544f0..51259a6 100644 --- 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