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 widget update/preserve-view))
(define/augment (on-close)
(send widget shutdown)
(inner (void) on-close))
(override/return-false file-menu:create-new?
file-menu:create-open?
file-menu:create-open-recent?

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

@ -33,10 +33,10 @@
;; 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)
(make-trec deriv #f #f #f #f #f))
(make-trec deriv #f #f #f #f #f null))
;; trec:invalidate-synth! : TermRecord -> void
;; Invalidates cached parts that depend on macro-hiding policy
@ -45,6 +45,7 @@
(set-trec-estx! trec #f)
(set-trec-raw-steps! trec #f)
(set-trec-definites! trec #f)
(set-trec-warnings! trec null)
(trec:invalidate-steps! trec))
;; trec:invalidate-steps! : TermRecord -> void
@ -131,6 +132,8 @@
(alignment '(left center))
(style '(deleted))))
(define warnings (new stepper-warnings% (parent area)))
(define sbview (new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
@ -143,8 +146,6 @@
(stepper this)
(config config)))
(define warnings-frame #f)
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel?
@ -314,6 +315,34 @@
(update)
(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
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
@ -458,34 +487,6 @@
#:alpha-table alpha-table))
(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
(define/private (insert-syntax/color stx foci definites frontier hi-color)
(send sbview add-syntax stx
@ -537,19 +538,30 @@
;; refresh : -> void
(define/public (refresh)
(restore-position)
(display-warnings (focused-term))
(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
(define/private (recache trec)
(unless (trec-synth-deriv trec)
(set-trec-warnings! trec null)
(with-handlers ([(lambda (e) #t)
(lambda (e)
(handle-recache-error e 'macro-hiding)
(set-trec-synth-deriv! trec 'error)
(set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))])
(let-values ([(synth-deriv estx) (synthesize (trec-deriv trec))])
(set-trec-synth-deriv! trec synth-deriv)
(set-trec-estx! trec estx))))
(recache-synth trec)))
(unless (trec-raw-steps trec)
(with-handlers ([(lambda (e) #t)
(lambda (e)
@ -656,21 +668,24 @@
seq]
[else #f]))
;; synthesize : Derivation -> Derivation Syntax
(define/private (synthesize deriv)
;; recache-synth : TermRecord -> void
(define/private (recache-synth trec)
(define deriv (trec-deriv trec))
(define-values (synth-deriv estx)
(let ([show-macro? (get-show-macro?)])
(if show-macro?
(parameterize ((current-hiding-warning-handler
(lambda (tag message)
(unless (send config get-suppress-warnings?)
(unless warnings-frame
(set! warnings-frame (new warnings-frame%)))
(send warnings-frame add-warning tag message)
(send warnings-frame show #t))))
(set-trec-warnings!
trec
(cons (cons tag message)
(trec-warnings trec)))))
(force-letrec-transformation
(send config get-force-letrec-transformation?)))
(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)
(let loop ([rs rs])
@ -693,11 +708,6 @@
(define/private (get-show-macro?)
(send macro-hiding-prefs get-policy))
;; --
(define/public (shutdown)
(when warnings-frame (send warnings-frame show #f)))
;; Initialization
(super-new)