macro debugger:
underline definite binders add rename/shift mapping so module final term retains binding info svn: r12843 original commit: 6fdba44edc54a7eb6d375a3c084262400eac0e96
This commit is contained in:
Ryan Culpepper
parent
c715df4d97
commit
4707441bc0
|
|
@ -79,18 +79,28 @@
|
|||
;; 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")
|
||||
|
||||
|
|
|
|||
|
|
@ -105,61 +105,72 @@
|
|||
(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)
|
||||
(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)
|
||||
(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
|
||||
(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)
|
||||
(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
|
||||
(adjust (car binder-r))
|
||||
(adjust (cdr binder-r))
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
(+ start (car binder-r))
|
||||
(+ start (cdr binder-r))
|
||||
(+ start (car id-r))
|
||||
(+ start (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))
|
||||
(+ start (car binder-r))
|
||||
(+ start (cdr binder-r))
|
||||
(+ start (car id-r))
|
||||
(+ start (cdr id-r))
|
||||
"purple")))
|
||||
(send range get-ranges id)))
|
||||
(send range get-ranges binder)))))
|
||||
(send range get-identifier-list))))
|
||||
display))
|
||||
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user