suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Macro stepper: moved warnings from separate frame to panel/term

Browse Source 
svn: r7483

original commit: 05b37c3ed706fcd1b27e327234a519fbb1a31c7b
This commit is contained in:
Ryan Culpepper 2007-10-11 01:38:28 +00:00
parent 593c71ecd4
commit f07ce280c6
2 changed files with 77 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/macro-debugger/view/frame.ss
View File

@ -57,10 +57,6 @@
(send config set-height h) (send config set-height h)
(send widget update/preserve-view)) (send widget update/preserve-view))
(define/augment (on-close)
(send widget shutdown)
(inner (void) on-close))
(override/return-false file-menu:create-new? (override/return-false file-menu:create-new?
file-menu:create-open? file-menu:create-open?
file-menu:create-open-recent? file-menu:create-open-recent?

144
collects/macro-debugger/view/stepper.ss
View File

@ -33,11 +33,11 @@
;; TermRecords ;; TermRecords
(define-struct trec (deriv synth-deriv estx raw-steps steps definites) #f) (define-struct trec (deriv synth-deriv estx raw-steps steps definites warnings) #f)
(define (new-trec deriv) (define (new-trec deriv)
(make-trec deriv #f #f #f #f #f)) (make-trec deriv #f #f #f #f #f null))
;; trec:invalidate-synth! : TermRecord -> void ;; trec:invalidate-synth! : TermRecord -> void
;; Invalidates cached parts that depend on macro-hiding policy ;; Invalidates cached parts that depend on macro-hiding policy
(define (trec:invalidate-synth! trec) (define (trec:invalidate-synth! trec)
@ -45,6 +45,7 @@
(set-trec-estx! trec #f) (set-trec-estx! trec #f)
(set-trec-raw-steps! trec #f) (set-trec-raw-steps! trec #f)
(set-trec-definites! trec #f) (set-trec-definites! trec #f)
(set-trec-warnings! trec null)
(trec:invalidate-steps! trec)) (trec:invalidate-steps! trec))
;; trec:invalidate-steps! : TermRecord -> void ;; trec:invalidate-steps! : TermRecord -> void
@ -130,7 +131,9 @@
(stretchable-height #f) (stretchable-height #f)
(alignment '(left center)) (alignment '(left center))
(style '(deleted)))) (style '(deleted))))
(define warnings (new stepper-warnings% (parent area)))
(define sbview (new stepper-syntax-widget% (define sbview (new stepper-syntax-widget%
(parent area) (parent area)
(macro-stepper this))) (macro-stepper this)))
@ -143,8 +146,6 @@
(stepper this) (stepper this)
(config config))) (config config)))
(define warnings-frame #f)
(send config listen-show-syntax-properties? (send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?))) (lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel? (send config listen-show-hiding-panel?
@ -314,6 +315,34 @@
(update) (update)
(send text scroll-to-position (unbox start-box) #f (unbox end-box))) (send text scroll-to-position (unbox start-box) #f (unbox end-box)))
;; update/save-position : -> void
(define/private (update/save-position)
(save-position)
(update))
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send sbview add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
position-of-interest
#f
(send text last-position)
'start)
(enable/disable-buttons))
;; update:show-prefix : -> void ;; update:show-prefix : -> void
(define/private (update:show-prefix) (define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs ;; Show the final terms from the cached synth'd derivs
@ -458,34 +487,6 @@
#:alpha-table alpha-table)) #:alpha-table alpha-table))
(cdr suffix0))))) (cdr suffix0)))))
;; update/save-position : -> void
(define/private (update/save-position)
(save-position)
(update))
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send sbview add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
position-of-interest
#f
(send text last-position)
'start)
(enable/disable-buttons))
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
(define/private (insert-syntax/color stx foci definites frontier hi-color) (define/private (insert-syntax/color stx foci definites frontier hi-color)
(send sbview add-syntax stx (send sbview add-syntax stx
@ -515,41 +516,52 @@
(send nav:down enable (cursor:has-next? terms))) (send nav:down enable (cursor:has-next? terms)))
;; -- ;; --
;; refresh/resynth : -> void ;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec ;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth) (define/public (refresh/resynth)
(for-each trec:invalidate-synth! (cursor->list terms)) (for-each trec:invalidate-synth! (cursor->list terms))
(refresh)) (refresh))
;; refresh/re-reduce : -> void ;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec ;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce) (define/private (refresh/re-reduce)
(for-each trec:invalidate-steps! (cursor->list terms)) (for-each trec:invalidate-steps! (cursor->list terms))
(refresh)) (refresh))
;; refresh/move : -> void ;; refresh/move : -> void
;; Moving between terms; clear the saved position ;; Moving between terms; clear the saved position
(define/private (refresh/move) (define/private (refresh/move)
(clear-saved-position) (clear-saved-position)
(refresh)) (refresh))
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(restore-position) (restore-position)
(display-warnings (focused-term))
(update)) (update))
;; display-warnings : TermRecord -> void
(define/private (display-warnings trec)
(send warnings clear)
(when trec
(unless (send config get-suppress-warnings?)
(for-each (lambda (tag+message)
(let ([tag (car tag+message)]
[message (cdr tag+message)])
(send warnings add-warning tag message)))
(trec-warnings trec)))))
;; recache : TermRecord -> void ;; recache : TermRecord -> void
(define/private (recache trec) (define/private (recache trec)
(unless (trec-synth-deriv trec) (unless (trec-synth-deriv trec)
(set-trec-warnings! trec null)
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
(lambda (e) (lambda (e)
(handle-recache-error e 'macro-hiding) (handle-recache-error e 'macro-hiding)
(set-trec-synth-deriv! trec 'error) (set-trec-synth-deriv! trec 'error)
(set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))]) (set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))])
(let-values ([(synth-deriv estx) (synthesize (trec-deriv trec))]) (recache-synth trec)))
(set-trec-synth-deriv! trec synth-deriv)
(set-trec-estx! trec estx))))
(unless (trec-raw-steps trec) (unless (trec-raw-steps trec)
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
(lambda (e) (lambda (e)
@ -656,22 +668,25 @@
seq] seq]
[else #f])) [else #f]))
;; synthesize : Derivation -> Derivation Syntax ;; recache-synth : TermRecord -> void
(define/private (synthesize deriv) (define/private (recache-synth trec)
(let ([show-macro? (get-show-macro?)]) (define deriv (trec-deriv trec))
(if show-macro? (define-values (synth-deriv estx)
(parameterize ((current-hiding-warning-handler (let ([show-macro? (get-show-macro?)])
(lambda (tag message) (if show-macro?
(unless (send config get-suppress-warnings?) (parameterize ((current-hiding-warning-handler
(unless warnings-frame (lambda (tag message)
(set! warnings-frame (new warnings-frame%))) (set-trec-warnings!
(send warnings-frame add-warning tag message) trec
(send warnings-frame show #t)))) (cons (cons tag message)
(force-letrec-transformation (trec-warnings trec)))))
(send config get-force-letrec-transformation?))) (force-letrec-transformation
(hide/policy deriv show-macro?)) (send config get-force-letrec-transformation?)))
(values deriv (lift/deriv-e2 deriv))))) (hide/policy deriv show-macro?))
(values deriv (lift/deriv-e2 deriv)))))
(set-trec-synth-deriv! trec synth-deriv)
(set-trec-estx! trec estx))
(define/private (reduce:one-by-one rs) (define/private (reduce:one-by-one rs)
(let loop ([rs rs]) (let loop ([rs rs])
(match rs (match rs
@ -685,19 +700,14 @@
(loop rs))] (loop rs))]
['() ['()
null]))) null])))
(define/private (foci x) (if (list? x) x (list x))) (define/private (foci x) (if (list? x) x (list x)))
;; Hiding policy ;; Hiding policy
(define/private (get-show-macro?) (define/private (get-show-macro?)
(send macro-hiding-prefs get-policy)) (send macro-hiding-prefs get-policy))
;; --
(define/public (shutdown)
(when warnings-frame (send warnings-frame show #f)))
;; Initialization ;; Initialization
(super-new) (super-new)