commit 8dbd13069895718e421118fa59e9f20bde5910f0
parent a169d49e04ff5cd826d90aced7f283305ab8d071
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 23 Feb 2007 11:06:38 +0000
Macro Stepper: added "apparent binding" arrows based on macro expansion
svn: r5675
original commit: 9aa54a095c6735f70575e0bd542e4c4b18996180
Diffstat:
3 files changed, 287 insertions(+), 13 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss
@@ -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"))
+
+ )
diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss
@@ -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)
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -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%))))))
)
