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

Macro Stepper: added "apparent binding" arrows based on macro expansion

Browse Source 
svn: r5675
This commit is contained in:
Ryan Culpepper 2007-02-23 11:06:38 +00:00
parent 3c172ac5cd
commit 9aa54a095c
5 changed files with 305 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/macro-debugger/syntax-browser/color.ss
View File

@ -45,6 +45,9 @@
(set! color-partition (send controller get-primary-partition))
(apply-primary-partition-styles))
(define/public (get-range) range)
(define/public (get-identifier-list) identifier-list)
;; select-syntax : syntax -> void
(define/public (select-syntax stx)
(set! selected-syntax stx)

247
collects/macro-debugger/syntax-browser/text.ss Normal file
View File

@ -0,0 +1,247 @@
(module text mzscheme
(require (lib "list.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "arrow.ss" "drscheme")
(lib "framework.ss" "framework"))
(provide text:drawings<%>
text:mouse-drawings<%>
text:arrows<%>
text:drawings-mixin
text:mouse-drawings-mixin
text:arrows-mixin)
(define (mean x y)
(/ (+ x y) 2))
(define-syntax with-saved-pen&brush
(syntax-rules ()
[(with-saved-pen&brush dc . body)
(save-pen&brush dc (lambda () . body))]))
(define (save-pen&brush dc thunk)
(let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)])
(begin0 (thunk)
(send dc set-pen old-pen)
(send dc set-brush old-brush))))
(define-syntax with-saved-text-config
(syntax-rules ()
[(with-saved-text-config dc . body)
(save-text-config dc (lambda () . body))]))
(define (save-text-config dc thunk)
(let ([old-font (send dc get-font)]
[old-color (send dc get-text-foreground)]
[old-background (send dc get-text-background)]
[old-mode (send dc get-text-mode)])
(begin0 (thunk)
(send dc set-font old-font)
(send dc set-text-foreground old-color)
(send dc set-text-background old-background)
(send dc set-text-mode old-mode))))
(define text:drawings<%>
(interface (text:basic<%>)
add-drawings
delete-drawings))
(define text:mouse-drawings<%>
(interface (text:drawings<%>)
add-mouse-drawing
delete-mouse-drawings))
(define text:arrows<%>
(interface (text:mouse-drawings<%>)
add-arrow))
(define text:drawings-mixin
(mixin (text:basic<%>) (text:drawings<%>)
(define draw-table (make-hash-table))
(define/public (add-drawings key draws)
(hash-table-put! draw-table
key
(append draws (hash-table-get draw-table key (lambda () null)))))
(define/public (delete-drawings key)
(hash-table-remove! draw-table key))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret)
(unless before?
(hash-table-for-each
draw-table
(lambda (k v)
(for-each (lambda (d) (d this dc left top right bottom dx dy))
v)))))
(super-new)))
(define text:mouse-drawings-mixin
(mixin (text:drawings<%>) (text:mouse-drawings<%>)
(inherit dc-location-to-editor-location
find-position
invalidate-bitmap-cache
add-drawings
delete-drawings)
(define inactive-list null)
(define active-list null)
(define/public (add-mouse-drawing start end draw)
(set! inactive-list
(cons (cons (cons start end) draw)
inactive-list)))
(define/public (delete-mouse-drawings)
(set! inactive-list null))
(define/override (on-default-event ev)
(define gx (send ev get-x))
(define gy (send ev get-y))
(define-values (x y) (dc-location-to-editor-location gx gy))
(define pos (find-position x y))
(super on-default-event ev)
(case (send ev get-event-type)
((enter motion)
(let ([new-active-annotations
(filter (lambda (rec) (<= (caar rec) pos (cdar rec)))
inactive-list)])
(unless (equal? active-list new-active-annotations)
(set! active-list new-active-annotations)
(delete-drawings 'mouse-over)
(add-drawings 'mouse-over (map cdr active-list))
(invalidate-bitmap-cache))))
((leave)
(unless (null? active-list)
(set! active-list null)
(delete-drawings 'mouse-over)
(invalidate-bitmap-cache)))))
(super-new)))
(define arrow-brush (send the-brush-list find-or-create-brush "white" 'solid))
(define text:arrows-mixin
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
(inherit position-location
add-mouse-drawing
find-wordbreak)
(define (?-font dc)
(let ([size (send (send dc get-font) get-point-size)])
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
(define/public (add-arrow from1 from2 to1 to2 color)
(unless (and (= from1 to1) (= from2 to2))
(let ([draw
(lambda (text dc left top right bottom dx dy)
(let*-values ([(start1x start1y) (position->location from1)]
[(start2x start2y) (position->location from2)]
[(end1x end1y) (position->location to1)]
[(end2x end2y) (position->location to2)]
[(startx) (mean start1x start2x)]
[(starty) (mean start1y start2y)]
[(endx) (mean end1x end2x)]
[(endy) (mean end1y end2y)]
[(fw fh _d _v) (send dc get-text-extent "")])
(let ([starty (+ starty (/ fh 2))]
[endy (+ endy (/ fh 2))])
(with-saved-pen&brush dc
(with-saved-text-config dc
(send dc set-pen color 1 'solid)
(send dc set-brush arrow-brush)
(draw-arrow dc startx starty endx endy dx dy)
#;(send dc set-text-mode 'solid)
(send dc set-font (?-font dc))
(send dc set-text-foreground
(send the-color-database find-color color))
(send dc draw-text "?"
(+ (+ startx dx) fw)
(- (+ starty dy) fh)))))))])
(add-mouse-drawing from1 from2 draw)
(add-mouse-drawing to1 to2 draw))))
(define/private (position->location p)
(define xbox (box 0.0))
(define ybox (box 0.0))
(position-location p xbox ybox)
(values (unbox xbox) (unbox ybox)))
#;
(define/public (add-dot position)
(define-values (pos1 pos2) (word-at position))
(add-mouse-drawing pos1 pos2
(lambda (text dc left top right bottom dx dy)
(let-values ([(x y) (position->location position)])
(send dc draw-ellipse
(+ x dx)
(+ y dy)
20 20)))))
#;
(define/private (word-at p)
(define sbox (box p))
(define ebox (box p))
(find-wordbreak sbox ebox 'caret)
(values (unbox sbox) (unbox ebox)))
(super-new)))
(define text:mouse-drawings%
(text:mouse-drawings-mixin
(text:drawings-mixin text:standard-style-list%)))
(define text:arrows%
(text:arrows-mixin text:mouse-drawings%))
#;
(define text:crazy%
(class text:arrows%
(inherit add-arrow
find-position
invalidate-bitmap-cache)
(define loc #f)
(define prev-pos #f)
(define/override (on-default-event ev)
(define x (send ev get-x))
(define y (send ev get-y))
(case (send ev get-event-type)
((motion)
(set! loc (cons x y))
(when prev-pos (invalidate-bitmap-cache)))
((left-down)
(let ([pos (find-position x y)])
(if prev-pos
(when (and pos (not (= pos prev-pos)))
(add-arrow prev-pos pos "red")
(set! prev-pos #f))
(set! prev-pos pos)))))
(super on-default-event ev))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret)
(unless before?
(when (and loc prev-pos)
(send dc draw-ellipse (- (car loc) 5) (- (cdr loc) 5) 10 10))))
(super-new)))
#;
(begin
(define f (new frame% (label "testing") (width 100) (height 100)))
(define t (new text:crazy% (auto-wrap #t)))
(define ec (new editor-canvas% (parent f) (editor t)))
(send f show #t)
(send t insert "this is the time to remember, because it will not last forever\n")
(send t insert "these are the days to hold on to, but we won't although we'll want to\n")
(send t add-dot 5)
(send t add-arrow 25 8 "blue"))
)

4
collects/macro-debugger/syntax-browser/util.ss
View File

@ -11,8 +11,8 @@
(let* ([t text]
[locked? (send t is-locked?)])
(send t lock #f)
(let () . body)
(send t lock locked?))]))
(begin0 (let () . body)
(send t lock locked?)))]))
(define (mpi->string mpi)
(if (module-path-index? mpi)

49
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -5,12 +5,15 @@
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
(lib "kw.ss")
(lib "boundmap.ss" "syntax")
"interfaces.ss"
"params.ss"
"controller.ss"
"typesetter.ss"
"hrule-snip.ss"
"properties.ss"
"text.ss"
"util.ss")
(provide widget@
widget-keymap-extension@
@ -93,12 +96,30 @@
(send -text insert text)))
(define/public add-syntax
(case-lambda
[(stx)
(internal-add-syntax stx null #f)]
[(stx hi-stxs hi-color)
(internal-add-syntax stx hi-stxs hi-color)]))
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table)
(when (and hi-stxs (not hi-color))
(error 'syntax-widget%::add-syntax "no highlight color specified"))
(let ([colorer (internal-add-syntax stx hi-stxs hi-color)])
(when alpha-table
(let ([range (send colorer get-range)])
(for-each (lambda (id)
(let ([binder
(module-identifier-mapping-get alpha-table
id
(lambda () #f))])
(when binder
(for-each
(lambda (binder-r)
(for-each (lambda (id-r)
(send -text add-arrow
(car id-r) (cdr id-r)
(car binder-r) (cdr binder-r)
"blue"))
(send range get-ranges id)))
(send range get-ranges binder)))))
(send colorer get-identifier-list))))
colorer)))
(define/public (add-separator)
(with-unlock -text
(send* -text
@ -106,7 +127,9 @@
(insert "\n"))))
(define/public (erase-all)
(with-unlock -text (send -text erase))
(with-unlock -text
(send -text erase)
(send -text delete-mouse-drawings))
(send controller erase))
(define/public (select-syntax stx)
@ -127,8 +150,9 @@
(insert "\n")
(scroll-to-position current-position))
(unless (null? hi-stxs)
(send new-colorer highlight-syntaxes hi-stxs hi-color)))))))
(send new-colorer highlight-syntaxes hi-stxs hi-color))
new-colorer)))))
(define/private (calculate-columns)
(define style (code-style -text))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
@ -176,6 +200,9 @@
(super-new)))))
(define browser-text%
(text:hide-caret/selection-mixin
(editor:standard-style-list-mixin text:basic%)))
(text:arrows-mixin
(text:mouse-drawings-mixin
(text:drawings-mixin
(text:hide-caret/selection-mixin
(editor:standard-style-list-mixin text:basic%))))))
)

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

@ -448,6 +448,7 @@
(send sbview add-text text)
(send sbview add-text "\n\n"))
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
@ -462,7 +463,7 @@
(for-each (lambda (d+sd)
(let ([e2 (lift/deriv-e2 (cdr d+sd))])
(if e2
(send sbview add-syntax e2)
(send sbview add-syntax e2 #:alpha-table alpha-table)
(send sbview add-text "Error\n"))))
(reverse derivs-prefix)))
@ -501,13 +502,6 @@
(insert-syntax/redex (step-term1 step) (step-foci1 step))
(update:separator step)
(insert-syntax/contractum (step-term2 step) (step-foci2 step))
;; FIXME:
#;(begin (send sbview add-text "environment:\n")
(module-identifier-mapping-for-each
alpha-table
(lambda (k v) (send sbview add-syntax k)))
#;(for-each (lambda (id) (send sbview add-syntax id))
(context-env (protostep-ctx step))))
(update:show-lctx step))
(define/private (update:show-prestep step)
@ -529,7 +523,7 @@
(send sbview add-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e))
(for-each (lambda (e) (send sbview add-syntax e #:alpha-table alpha-table))
(exn:fail:syntax-exprs (misstep-exn step))))
(update:show-lctx step))
@ -537,7 +531,7 @@
(let ([result (lift/deriv-e2 synth-deriv)])
(when result
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax result))
(send sbview add-syntax result #:alpha-table))
(unless result
(send sbview add-text "Error\n"))))
@ -545,7 +539,8 @@
(when (pair? derivs)
(for-each (lambda (suffix-deriv)
(send sbview add-syntax
(lift/deriv-e1 suffix-deriv)))
(lift/deriv-e1 suffix-deriv)
#:alpha-table alpha-table))
(cdr derivs))))
;; update/save-position : -> void
@ -577,19 +572,23 @@
;; insert-syntax : syntax -> void
(define/private (insert-syntax stx)
(send sbview add-syntax stx))
(send sbview add-syntax stx #:alpha-table alpha-table))
;; insert-syntax/redex : syntax syntaxes -> void
(define/private (insert-syntax/redex stx foci)
(if (send config get-highlight-foci?)
(send sbview add-syntax stx foci "MistyRose")
(send sbview add-syntax stx)))
(send sbview add-syntax stx
#:hi-stxs foci #:hi-color "MistyRose"
#:alpha-table alpha-table)
(send sbview add-syntax stx #:alpha-table alpha-table)))
;; insert-syntax/contractum : syntax syntaxes -> void
(define/private (insert-syntax/contractum stx foci)
(if (send config get-highlight-foci?)
(send sbview add-syntax stx foci "LightCyan")
(send sbview add-syntax stx)))
(send sbview add-syntax stx
#:hi-stxs foci #:hi-color "LightCyan"
#:alpha-table alpha-table)
(send sbview add-syntax stx #:alpha-table alpha-table)))
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)