suzanne.soy/racket
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
This commit is contained in:
Ryan Culpepper 2007-10-11 01:38:28 +00:00
parent 29501ba68a
commit 05b37c3ed7
3 changed files with 170 additions and 119 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?

120
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)
(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))))
(force-letrec-transformation
(send config get-force-letrec-transformation?)))
(hide/policy deriv show-macro?))
(values deriv (lift/deriv-e2 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)
(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)

131
collects/macro-debugger/view/warning.ss
View File

@ -3,60 +3,105 @@
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework"))
(provide warnings-frame%)
(provide warnings%
stepper-warnings%)
(define include-message? #f)
;; warnings-frame%
(define warnings-frame%
(class frame%
(super-new (label "Macro stepper warnings") (width 400) (height 300))
;; warnings%
(define warnings%
(class object%
(init parent)
(super-new)
(define super-panel
(new vertical-panel%
(parent parent)
(stretchable-height #f)))
(define main-panel
(new horizontal-panel%
(parent super-panel)
(style '(deleted border))))
(define label (new message% (parent main-panel) (label "Warnings")))
(define text (new text:hide-caret/selection% (auto-wrap #t)))
(define ec (new editor-canvas% (parent this) (editor text)))
(define ec
(new editor-canvas%
(parent main-panel)
(editor text)
(style '(auto-vscroll auto-hscroll))
(line-count 3)))
(define dismiss
(new button%
(parent main-panel)
(label "Hide")
(stretchable-height #t)
(callback (lambda _ (show #f)))))
(send text set-autowrap-bitmap #f)
(send text lock #t)
(define -nonlinearity-text #f)
(define -localactions-text #f)
(define -lifts-text #f)
(define/public (get-text) text)
(define/private (add-nonlinearity-text)
(unless -nonlinearity-text
(set! -nonlinearity-text #t)
(add-text "An opaque macro duplicated one of its subterms. "
"Macro hiding requires opaque macros to use their subterms linearly. "
"The macro stepper is showing the expansion of that macro use.")))
(define/private (add-localactions-text)
(unless -localactions-text
(set! -localactions-text #t)
(add-text "An opaque macro called local-expand, syntax-local-lift-expression, "
"etc. Macro hiding cannot currently handle local actions. "
"The macro stepper is showing the expansion of that macro use.")))
(define/private (add-lifts-text)
(unless -lifts-text
(set! -lifts-text #t)
(add-text "A transparent macro called syntax-local-lift-expression or "
"syntax-local-lift-module-end-declaration. "
"The macro stepper is only hiding macro after the "
"lifts are caught.")))
(define/public (show ?)
(send super-panel change-children
(lambda _
(if ?
(list main-panel)
null))))
(define/public (add-text . strs)
(send text lock #f)
(for-each (lambda (s) (send text insert s)) strs)
(send text insert "\n\n")
(send text lock #t))
;; Warning management
(define keys null)
(define/public (add-warning tag message)
;; clear : -> void
(define/public (clear)
(set! keys null)
(send* text
(lock #f)
(erase)
(lock #t))
(show #f))
;; add : symbol string ... -> void
(define/public (add key . strs)
(unless (memq key keys)
(send text lock #f)
(for-each (lambda (s) (send text insert s)) strs)
(send text insert "\n\n")
(send text scroll-to-position 0)
(send text lock #t)
(show #t)))
))
(define stepper-warnings%
(class warnings%
(super-new)
(inherit add)
(define/private (add-nonlinearity-warning)
(add
'nonlinearity
"An opaque macro duplicated one of its subterms. "
"Macro hiding requires opaque macros to use their subterms linearly. "
"The macro stepper is showing the expansion of that macro use."))
(define/private (add-localactions-warning)
(add
'localactions
"An opaque macro called local-expand, syntax-local-lift-expression, "
"etc. Macro hiding cannot currently handle local actions. "
"The macro stepper is showing the expansion of that macro use."))
(define/private (add-lifts-warning)
(add
'lifts
"A transparent macro called syntax-local-lift-expression or "
"syntax-local-lift-module-end-declaration. "
"The macro stepper is only hiding macro after the "
"lifts are caught."))
(define/public (add-warning tag _message)
(case tag
((nonlinearity)
(add-nonlinearity-text))
(add-nonlinearity-warning))
((localactions)
(add-localactions-text))
(add-localactions-warning))
((lifts)
(add-lifts-text)))
(when include-message?
(add-text message)))
(send this show #t)))
(add-lifts-warning))))))
)