diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index e61b9ef..79ade18 100644 --- 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 index b1ae668..3b0a36b 100644 --- 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 index bf82d49..7c80955 100644 --- 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 index 20c155a..a963906 100644 --- 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)]))