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

Macro stepper preserves position when hiding policy changed, etc

Browse Source 
svn: r5338
This commit is contained in:
Ryan Culpepper 2007-01-12 22:56:21 +00:00
parent 8acfe2bdfa
commit 0b35093018
7 changed files with 118 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/model/deriv-c.ss
View File

@ -17,7 +17,7 @@
;; - resolves is the list of identifiers resolved by the macro keyword
;; - me1 is the marked version of the input syntax
;; - me2 is the marked version of the output syntax
(define-struct transformation (e1 e2 resolves me1 me2 locals) #f)
(define-struct transformation (e1 e2 resolves me1 me2 locals seq) #f)
;; A LocalAction is one of
;; - (make-local-expansion Syntax Syntax Syntax Syntax Derivation)

16
collects/macro-debugger/model/deriv-parser.ss
View File

@ -13,8 +13,18 @@
(error 'derivation-parser "bad token #~a" start)))
;; PARSER
(define (parse-derivation x)
(parameterize ((current-sequence-number 0))
(parse-derivation* x)))
(define current-sequence-number (make-parameter #f))
(define (new-sequence-number)
(let ([seq (current-sequence-number)])
(current-sequence-number (add1 seq))
seq))
(define parse-derivation
(define parse-derivation*
(parser
(options (start Expansion)
(src-pos)
@ -132,7 +142,7 @@
(! 'bad-transformer)
macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform
exit-macro)
(make-transformation $2 $8 $1 $4 $7 $5)])
(make-transformation $2 $8 $1 $4 $7 $5 (new-sequence-number))])
;; Local actions taken by macro
;; LocalAction Answer = (list-of LocalAction)
@ -373,7 +383,7 @@
;; let*-values with bindings is "macro-like"
[(prim-let*-values ! (? EE))
(let ([next-e1 (lift/deriv-e1 $3)])
(make-mrule e1 e2 (make-transformation e1 next-e1 rs e1 next-e1 null) $3))]
(make-mrule e1 e2 (make-transformation e1 next-e1 rs e1 next-e1 null (new-sequence-number)) $3))]
;; No bindings... model as "let"
[(prim-let*-values NoError renames-let (? NextEEs 'rhss) next-group (? EB 'body))
(make-p:let-values e1 e2 rs $3 $4 $6)])

2
collects/macro-debugger/model/deriv-util.ss
View File

@ -156,7 +156,7 @@
(join (loop tx) (loop next))]
[(AnyQ lift-deriv (_ _ first lift second))
(join (loop first) (loop lift) (loop second))]
[(AnyQ transformation (_ _ _ _ _ locals))
[(AnyQ transformation (_ _ _ _ _ locals _))
(loops locals)]
[(struct local-expansion (_ _ _ _ deriv))
(loop deriv)]

6
collects/macro-debugger/model/hide.ss
View File

@ -393,7 +393,7 @@
#;
(define (for-transformation tx)
(match tx
[(IntQ transformation (e1 e2 rs me1 me2 locals))
[(IntQ transformation (e1 e2 rs me1 me2 locals _seq))
(error 'unimplemented "hide: for-transformation")]))
;; for-rename : Rename -> (values Rename syntax)
@ -663,7 +663,7 @@
;; for-transformation : Transformation -> (values (list-of Subterm) Table)
(define (for-transformation tx)
(match tx
[(struct transformation (e1 e2 rs me1 me2 locals))
[(struct transformation (e1 e2 rs me1 me2 locals _seq))
;; FIXME: We'll need to use e1/e2/me1/me2 to synth locals, perhaps
;; FIXME: and we'll also need to account for *that* marking, too...
(unless (null? locals)
@ -852,7 +852,7 @@
;; show-mrule? : MRule -> boolean
(define (show-transformation? tx)
(match tx
[(AnyQ transformation (e1 e2 rs me1 me2 locals))
[(AnyQ transformation (e1 e2 rs me1 me2 locals _seq))
(ormap show-macro? rs)]))
(define (map/2values f items)

8
collects/macro-debugger/model/reductions.ss
View File

@ -284,14 +284,14 @@
;; reductions-transformation : Transformation -> ReductionSequence
(define (reductions-transformation tx)
(match tx
[(struct transformation (e1 e2 rs me1 me2 locals))
[(struct transformation (e1 e2 rs me1 me2 locals seq))
(append (reductions-locals e1 locals)
(list (walk e1 e2 'macro-step)))]
[(IntW transformation (e1 e2 rs me1 me2 locals) 'locals)
[(IntW transformation (e1 e2 rs me1 me2 locals seq) 'locals)
(reductions-locals e1 locals)]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'bad-transformer exn)
[(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'bad-transformer exn)
(list (stumble e1 exn))]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'transform exn)
[(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'transform exn)
(append (reductions-locals e1 locals)
(list (stumble e1 exn)))]))

116
collects/macro-debugger/view/gui.ss
View File

@ -12,6 +12,7 @@
"warning.ss"
"hiding-panel.ss"
(prefix sb: "../syntax-browser/embed.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
@ -210,6 +211,9 @@
;; steps : cursor
(define steps #f)
;; saved-position : number/#f
(define saved-position #f)
(define warnings-frame #f)
(define/public (add-deriv d)
@ -226,7 +230,7 @@
nav:down))))
(if (null? (cdr derivs))
;; There is nothing currently displayed
(refresh)
(refresh/move/cached-prefix)
(update)))
(define/public (get-controller) sbc)
@ -304,29 +308,29 @@
(define/private (navigate-to-start)
(cursor:move-to-start steps)
(update))
(update/save-position))
(define/private (navigate-to-end)
(cursor:move-to-end steps)
(update))
(update/save-position))
(define/private (navigate-previous)
(cursor:move-previous steps)
(update))
(update/save-position))
(define/private (navigate-next)
(cursor:move-next steps)
(update))
(update/save-position))
(define/private (navigate-up)
(let ([d+sd (car derivs-prefix)])
(set! derivs (cons (car d+sd) derivs))
(set! synth-deriv (cdr d+sd))
(set! derivs-prefix (cdr derivs-prefix)))
(refresh))
(refresh/move/cached-prefix))
(define/private (navigate-down)
(let ([d0 (car derivs)])
(set! derivs-prefix (cons (cons d0 synth-deriv) derivs-prefix))
(set! derivs (cdr derivs))
(set! synth-deriv #f))
(refresh))
(refresh/move/cached-prefix))
(define/private (insert-step-separator text)
(send sbview add-text "\n ")
@ -437,6 +441,11 @@
(send sbview add-syntax (lift/deriv-e1 suffix-deriv)))
(cdr derivs))))
;; 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)
@ -487,9 +496,21 @@
;; --
;; refresh/resynth : -> void
;; refresh/move/cached-prefix : -> void
;; Resynth current derivation,
;; Create reductions for current derivation,
;; Show first step
(define/private (refresh/move/cached-prefix)
(clear-saved-position)
(if (pair? derivs)
(refresh)
(begin (set! synth-deriv #f)
(set! steps #f)
(update))))
;; refresh/resynth-prefix : -> void
;; Resynth all of the derivations in prefix and refresh
(define/public (refresh/resynth)
(define/public (refresh/resynth-prefix)
(with-handlers ([(lambda (e) (catch-errors?))
(lambda (e)
(message-box "Error"
@ -501,25 +522,76 @@
(refresh))
;; refresh : -> void
;; Resynth current derivation,
;; Create reductions for current derivation,
;; Show first step
(define/private (refresh)
(if (pair? derivs)
(refresh/nontrivial)
(begin (set! synth-deriv #f)
(set! steps #f)
(update))))
;; refresh/nontrivial : -> void
(define/private (refresh/nontrivial)
(define/public (refresh)
(let ([deriv (car derivs)])
(let ([d (synthesize deriv)])
(let ([s (cursor:new (reduce d))])
(set! synth-deriv d)
(set! steps s))))
(restore-position)
(update))
;; update-saved-position : num -> void
(define/private (update-saved-position pos)
(when pos (set! saved-position pos)))
;; clear-saved-position : -> void
(define/private (clear-saved-position)
(set! saved-position #f))
;; save-position : -> void
(define/private (save-position)
(when steps
(let ([step (cursor:current steps)])
(cond [(not step)
;; At end; go to the end when restored
(update-saved-position +inf.0)]
[(protostep? step)
(update-saved-position (extract-protostep-seq step))]))))
; ;; save-position : -> void
; (define (save-position)
; (define (steps-loop)
; (let ([step (cursor:current steps)])
; (cond [(not step)
; ;; At end; go to the end when restored
; +inf.0]
; [(protostep? step)
; (or (extract-protostep-seq step)
; ;; Go one previous, if possible, and try again
; (if (cursor:can-move-previous? steps)
; (begin (cursor:move-previous steps)
; (steps-loop))
; #f))]
; [else #f])))
; (update-saved-position (and steps (steps-loop))))
;; restore-position : number -> void
(define (restore-position)
(define (advance)
(let ([step (cursor:current steps)])
(cond [(not step)
;; At end; stop
(void)]
[(protostep? step)
(let ([step-pos (extract-protostep-seq step)])
(cond [(not step-pos)
(cursor:move-next steps)
(advance)]
[(< step-pos saved-position)
(cursor:move-next steps)
(advance)]
[else (void)]))])))
(when saved-position
(when steps
(advance))))
(define/private (extract-protostep-seq step)
(match (protostep-deriv step)
[(AnyQ mrule (_ _ (AnyQ transformation (_ _ _ _ _ _ seq)) _))
seq]
[else #f]))
;; synthesize : Derivation -> Derivation
(define/private (synthesize deriv)
(let ([show-macro? (get-show-macro?)])
@ -595,7 +667,7 @@
;; Initialization
(super-new)
(refresh)))
(refresh/move/cached-prefix)))
;; Main entry points

4
collects/macro-debugger/view/hiding-panel.ss
View File

@ -101,11 +101,11 @@
;; refresh
(define/public (refresh)
(when (send config get-macro-hiding?)
(send stepper refresh/resynth)))
(send stepper refresh)))
;; force-refresh
(define/private (force-refresh)
(send stepper refresh/resynth))
(send stepper refresh/resynth-prefix))
;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx)