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

macro-stepper: added step count

Browse Source 
also removed some dead code (warnings)
This commit is contained in:
Ryan Culpepper 2010-06-30 15:38:23 -06:00
parent a543c2137e
commit 5673d7b877
5 changed files with 25 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/macro-debugger/view/cursor.rkt
View File

@ -24,7 +24,8 @@
cursor->list
cursor:prefix->list
cursor:suffix->list)
cursor:suffix->list
cursor-count)
(define-struct cursor (vector count position)
#:mutable)

1
collects/macro-debugger/view/interfaces.rkt
View File

@ -62,6 +62,7 @@
(get-raw-deriv
get-deriv-hidden?
get-step-index
get-step-count
invalidate-synth!
invalidate-steps!

21
collects/macro-debugger/view/stepper.rkt
View File

@ -14,7 +14,6 @@
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
"step-display.ss"
@ -103,7 +102,6 @@
(define/public (get-controller) sbc)
(define/public (get-view) sbview)
(define/public (get-step-displayer) step-displayer)
(define/public (get-warnings-area) warnings-area)
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define/public (reset-primary-partition)
@ -130,8 +128,6 @@
(alignment '(left center))
(style '(deleted))))
(define warnings-area (new stepper-warnings% (parent area)))
(define: sbview sb:syntax-browser<%>
(new stepper-syntax-widget%
(parent area)
@ -206,7 +202,16 @@
(navigate-to (sub1 step))]
[(equal? value "end")
(navigate-to-end)])))))))
(define nav:step-count
(new message%
(label "")
(parent extra-navigator)
(auto-resize #t)
(stretchable-width #f)
(stretchable-height #f)))
(send nav:text set-value "")
(listen-current-step-index
(lambda (n)
(send nav:text set-value
@ -388,9 +393,15 @@
;; refresh : -> void
(define/public (refresh)
(send warnings-area clear)
(when (focused-term)
(send: (focused-term) term-record<%> on-get-focus))
(send nav:step-count set-label "")
(let ([term (focused-term)])
(when term
(let ([step-count (send: term term-record<%> get-step-count)])
(when step-count
;; +1 for end of expansion "step"
(send nav:step-count set-label (format "of ~s" (add1 step-count)))))))
(update))
(define/private (foci x) (if (list? x) x (list x)))

6
collects/macro-debugger/view/term-record.rkt
View File

@ -207,7 +207,11 @@
(and (get-steps) (not (cursor:at-end? (get-steps)))))
(define/public-final (get-step-index)
(and (get-steps) (cursor-position (get-steps))))
(let ([steps (get-steps)])
(and steps (cursor-position steps))))
(define/public-final (get-step-count)
(let ([steps (get-steps)])
(and steps (cursor-count steps))))
(define/public-final (navigate-to-start)
(cursor:move-to-start (get-steps))

130
collects/macro-debugger/view/warning.rkt
View File

@ -1,130 +0,0 @@
#lang scheme/base
(require scheme/class
mred
framework)
(provide warnings%
stepper-warnings%)
;; 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 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/public (get-text) text)
(define/public (show ?)
(send super-panel change-children
(lambda _
(if ?
(list main-panel)
null))))
;; Warning management
(define keys null)
;; 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/private (add-lift/let-warning)
(add
'lift/let
"Lifts occurred during the expansion of phase 1 or higher code. "
"The macro stepper is showing some expansions that should be hidden."))
(define/private (add-hidden-lift-site-warning)
(add
'hidden-lift-site
"An opaque macro contained the target of a lifted declaration."
"The macro stepper is showing the expansion of that macro use."))
(define/private (add-hidden-lift-site/continuing-warning)
(add
'hidden-lift-site/continuing
"The target of a lifted declaration was a hidden #%module-begin context. "
"The macro stepper is omitting the lifted declaration."))
(define/public (add-warning tag args)
(case tag
((nonlinearity)
(add-nonlinearity-warning))
((localactions)
(add-localactions-warning))
((lifts)
(add-lifts-warning))
((lift/let)
(add-lift/let-warning))
((hidden-lift-site)
(add-hidden-lift-site-warning))
((hidden-lift-site/continuing)
(add-hidden-lift-site/continuing-warning))))
))