commit 4707441bc0cf34aa739b71ea45e7cfc2c759c8d2
parent c715df4d97c510ae273cb1a0f21ef81556de4c9a
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 14 Dec 2008 07:56:37 +0000
macro debugger:
underline definite binders
add rename/shift mapping so module final term retains binding info
svn: r12843
original commit: 6fdba44edc54a7eb6d375a3c084262400eac0e96
Diffstat:
4 files changed, 138 insertions(+), 89 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -75,22 +75,32 @@
;; get-range : -> range<%>
(define/public (get-range) range)
-
+
;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color)
(let ([style-delta (highlight-style-delta hi-color #f)])
- (for-each (lambda (stx) (hash-set! extra-styles stx style-delta))
- stxs))
+ (for ([stx stxs])
+ (add-extra-styles stx (list style-delta))))
+ (refresh))
+
+ ;; underline-syntaxes : (listof syntax) -> void
+ (define/public (underline-syntaxes stxs)
+ (for ([stx stxs])
+ (add-extra-styles stx (list underline-style-delta)))
(refresh))
+ (define/public (add-extra-styles stx styles)
+ (hash-set! extra-styles stx
+ (append (hash-ref extra-styles stx null)
+ styles)))
+
;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
- (hash-for-each
- extra-styles
- (lambda (hi-stx style-delta)
- (let ([rs (send range get-ranges hi-stx)])
- (for-each (lambda (r) (restyle-range r style-delta)) rs)))))
+ (for ([(stx style-deltas) extra-styles])
+ (for ([r (send range get-ranges stx)])
+ (for ([style-delta style-deltas])
+ (restyle-range r style-delta)))))
;; apply-secondary-partition-styles : selected-syntax -> void
;; If the selected syntax is an identifier, then styles all identifiers
@@ -243,6 +253,11 @@
(send sd set-weight-off 'bold))
sd))
+(define underline-style-delta
+ (let ([sd (new style-delta%)])
+ (send sd set-underlined-on #t)
+ sd))
+
(define selection-color "yellow")
(define subselection-color "yellow")
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -105,62 +105,73 @@
(send -text change-style clickback-style a b)))))
(define/public (add-syntax stx
- #:alpha-table alpha-table
+ #:binder-table [alpha-table #f]
+ #:shift-table [shift-table #f]
#:definites [definites null]
#:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null])
- (define (get-binder id)
- (module-identifier-mapping-get alpha-table id (lambda () #f)))
+ (define (get-binders id)
+ (define binder
+ (module-identifier-mapping-get alpha-table id (lambda () #f)))
+ (if shift-table
+ (cons binder (hash-ref shift-table binder null))
+ (list binder)))
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(for-each (lambda (hi-stxs hi-color)
(send display highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
- (for-each (lambda (x) (hash-set! definite-table x #t)) definites)
+ (for ([definite definites])
+ (hash-set! definite-table definite #t)
+ (when shift-table
+ (for ([shifted-definite (hash-ref shift-table definite null)])
+ (hash-set! definite-table shifted-definite #t))))
(when alpha-table
(let ([range (send display get-range)]
[start (send display get-start-position)])
- (define (adjust n) (+ start n))
- (for-each
- (lambda (id)
- (when #f ;; DISABLED
- (match (identifier-binding id)
- [(list src-mod src-name nom-mod nom-name _)
- (for-each (lambda (id-r)
- (send -text add-billboard
- (adjust (car id-r))
- (adjust (cdr id-r))
- (string-append "from "
- (mpi->string src-mod))
- (if (hash-ref definite-table id #f)
- "blue"
- "purple")))
- (send range get-ranges id))]
- [_ (void)]))
- (let ([binder (get-binder id)])
- (when binder
- (for-each
- (lambda (binder-r)
- (for-each (lambda (id-r)
- (if (hash-ref definite-table id #f)
- (send -text add-arrow
- (adjust (car binder-r))
- (adjust (cdr binder-r))
- (adjust (car id-r))
- (adjust (cdr id-r))
- "blue")
- (send -text add-question-arrow
- (adjust (car binder-r))
- (adjust (cdr binder-r))
- (adjust (car id-r))
- (adjust (cdr id-r))
- "purple")))
- (send range get-ranges id)))
- (send range get-ranges binder)))))
- (send range get-identifier-list))))
+ (let* ([binders0
+ (module-identifier-mapping-map alpha-table (lambda (k v) k))]
+ [binders
+ (apply append (map get-binders binders0))])
+ (send display underline-syntaxes binders))
+ (for ([id (send range get-identifier-list)])
+ (define definite? (hash-ref definite-table id #f))
+ (when #f ;; DISABLED
+ (add-binding-billboard start range id definite?))
+ (for ([binder (get-binders id)])
+ (for ([binder-r (send range get-ranges binder)])
+ (for ([id-r (send range get-ranges id)])
+ (add-binding-arrow start binder-r id-r definite?)))))))
display))
+ (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-billboard start range id definite?)
+ (match (identifier-binding id)
+ [(list-rest src-mod src-name nom-mod nom-name _)
+ (for-each (lambda (id-r)
+ (send -text add-billboard
+ (+ start (car id-r))
+ (+ start (cdr id-r))
+ (string-append "from " (mpi->string src-mod))
+ (if definite? "blue" "purple")))
+ (send range get-ranges id))]
+ [_ (void)]))
+
(define/public (add-separator)
(with-unlock -text
(send* -text
diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss
@@ -95,36 +95,41 @@
(send sbview add-text "\n"))
(define/public (add-step step
- #:binders binders)
+ #:binders binders
+ #:shift-table [shift-table #f])
(cond [(step? step)
- (show-step step binders)]
+ (show-step step binders shift-table)]
[(misstep? step)
- (show-misstep step binders)]
+ (show-misstep step binders shift-table)]
[(prestep? step)
- (show-prestep step binders)]
+ (show-prestep step binders shift-table)]
[(poststep? step)
- (show-poststep step binders)]))
+ (show-poststep step binders shift-table)]))
(define/public (add-syntax stx
#:binders binders
+ #:shift-table [shift-table #f]
#:definites definites)
(send sbview add-syntax stx
- #:alpha-table binders
+ #:binder-table binders
+ #:shift-table shift-table
#:definites (or definites null)))
(define/public (add-final stx error
#:binders binders
+ #:shift-table [shift-table #f]
#:definites definites)
(when stx
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx
- #:alpha-table binders
+ #:binder-table binders
+ #:shift-table shift-table
#:definites (or definites null)))
(when error
(add-error error)))
;; show-lctx : Step -> void
- (define/private (show-lctx step binders)
+ (define/private (show-lctx step binders shift-table)
(define state (protostep-s1 step))
(define lctx (state-lctx state))
(when (pair? lctx)
@@ -135,6 +140,7 @@
(insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf)
binders
+ shift-table
(state-uses state)
(state-frontier state)))
(reverse lctx))))
@@ -149,72 +155,81 @@
(step-type->string (protostep-type step))))
;; show-step : Step -> void
- (define/private (show-step step binders)
- (show-state/redex (protostep-s1 step) binders)
+ (define/private (show-step step binders shift-table)
+ (show-state/redex (protostep-s1 step) binders shift-table)
(separator step)
- (show-state/contractum (step-s2 step) binders)
- (show-lctx step binders))
+ (show-state/contractum (step-s2 step) binders shift-table)
+ (show-lctx step binders shift-table))
- (define/private (show-state/redex state binders)
+ (define/private (show-state/redex state binders shift-table)
(insert-syntax/redex (state-term state)
(state-foci state)
binders
+ shift-table
(state-uses state)
(state-frontier state)))
- (define/private (show-state/contractum state binders)
+ (define/private (show-state/contractum state binders shift-table)
(insert-syntax/contractum (state-term state)
(state-foci state)
binders
+ shift-table
(state-uses state)
(state-frontier state)))
;; show-prestep : Step -> void
- (define/private (show-prestep step binders)
+ (define/private (show-prestep step binders shift-table)
(separator/small step)
- (show-state/redex (protostep-s1 step) binders)
- (show-lctx step binders))
+ (show-state/redex (protostep-s1 step) binders shift-table)
+ (show-lctx step binders shift-table))
;; show-poststep : Step -> void
- (define/private (show-poststep step binders)
+ (define/private (show-poststep step binders shift-table)
(separator/small step)
- (show-state/contractum (protostep-s1 step) binders)
- (show-lctx step binders))
+ (show-state/contractum (protostep-s1 step) binders shift-table)
+ (show-lctx step binders shift-table))
;; show-misstep : Step -> void
- (define/private (show-misstep step binders)
+ (define/private (show-misstep step binders shift-table)
(define state (protostep-s1 step))
- (show-state/redex state binders)
+ (show-state/redex state binders shift-table)
(separator step)
(send sbview add-error-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e)
(send sbview add-syntax e
- #:alpha-table binders
+ #:binder-table binders
+ #:shift-table shift-table
#:definites (or (state-uses state) null)))
(exn:fail:syntax-exprs (misstep-exn step))))
- (show-lctx step binders))
+ (show-lctx step binders shift-table))
- ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
- (define/private (insert-syntax/color stx foci binders definites frontier hi-color)
+ ;; insert-syntax/color
+ (define/private (insert-syntax/color stx foci binders shift-table
+ definites frontier hi-color)
(define highlight-foci? (send config get-highlight-foci?))
(define highlight-frontier? (send config get-highlight-frontier?))
(send sbview add-syntax stx
#:definites (or definites null)
- #:alpha-table binders
+ #:binder-table binders
+ #:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
- ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
- (define/private (insert-syntax/redex stx foci binders definites frontier)
- (insert-syntax/color stx foci binders definites frontier "MistyRose"))
+ ;; insert-syntax/redex
+ (define/private (insert-syntax/redex stx foci binders shift-table
+ definites frontier)
+ (insert-syntax/color stx foci binders shift-table
+ definites frontier "MistyRose"))
- ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
- (define/private (insert-syntax/contractum stx foci binders definites frontier)
- (insert-syntax/color stx foci binders definites frontier "LightCyan"))
+ ;; insert-syntax/contractum
+ (define/private (insert-syntax/contractum stx foci binders shift-table
+ definites frontier)
+ (insert-syntax/color stx foci binders shift-table
+ definites frontier "LightCyan"))
;; insert-step-separator : string -> void
(define/private (insert-step-separator text)
diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss
@@ -46,6 +46,7 @@
(define deriv #f)
(define deriv-hidden? #f)
(define binders #f)
+ (define shift-table #f)
(define raw-steps #f)
(define raw-steps-estx #f) ;; #f if raw-steps-exn is exn
@@ -72,7 +73,8 @@
(define-guarded-getters (recache-deriv!)
[get-deriv deriv]
[get-deriv-hidden? deriv-hidden?]
- [get-binders binders])
+ [get-binders binders]
+ [get-shift-table shift-table])
(define-guarded-getters (recache-raw-steps!)
[get-raw-steps-definites raw-steps-definites]
[get-raw-steps-exn raw-steps-exn]
@@ -104,7 +106,8 @@
(invalidate-synth!)
(set! deriv #f)
(set! deriv-hidden? #f)
- (set! binders #f))
+ (set! binders #f)
+ (set! shift-table #f))
;; recache! : -> void
(define/public (recache!)
@@ -130,12 +133,14 @@
(when (not d)
(set! deriv-hidden? #t))
(when d
- (let ([alpha-table (make-module-identifier-mapping)])
+ (let ([alpha-table (make-module-identifier-mapping)]
+ [binder-ids (extract-all-fresh-names d)])
(for-each (lambda (id)
(module-identifier-mapping-put! alpha-table id id))
- (extract-all-fresh-names d))
+ binder-ids)
(set! deriv d)
- (set! binders alpha-table))))))))
+ (set! binders alpha-table)
+ (set! shift-table (compute-shift-table d)))))))))
;; recache-synth! : -> void
(define/private (recache-synth!)
@@ -277,6 +282,7 @@
(cond [(syntax? raw-steps-estx)
(send displayer add-syntax raw-steps-estx
#:binders binders
+ #:shift-table shift-table
#:definites raw-steps-definites)]
[(exn? raw-steps-exn)
(send displayer add-error raw-steps-exn)]
@@ -289,9 +295,11 @@
(let ([step (cursor:next steps)])
(if step
(send displayer add-step step
- #:binders binders)
+ #:binders binders
+ #:shift-table shift-table)
(send displayer add-final raw-steps-estx raw-steps-exn
#:binders binders
+ #:shift-table shift-table
#:definites raw-steps-definites)))]
[else (display-oops #t)]))
