From 8dbd13069895718e421118fa59e9f20bde5910f0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 23 Feb 2007 11:06:38 +0000 Subject: [PATCH] Macro Stepper: added "apparent binding" arrows based on macro expansion svn: r5675 original commit: 9aa54a095c6735f70575e0bd542e4c4b18996180 --- .../macro-debugger/syntax-browser/text.ss | 247 ++++++++++++++++++ .../macro-debugger/syntax-browser/util.ss | 4 +- .../macro-debugger/syntax-browser/widget.ss | 49 +++- 3 files changed, 287 insertions(+), 13 deletions(-) create mode 100644 collects/macro-debugger/syntax-browser/text.ss diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss new file mode 100644 index 0000000..c642551 --- /dev/null +++ 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 index 9f679ad..db65375 100644 --- 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 index 78c6320..a364283 100644 --- 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%)))))) )