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

unstable: added skip-list and interval-map

Browse Source 
unstable/contract: added rename-contract
macro-debugger: switched to use interval-map for arrows

svn: r17278

original commit: 961ece3ffe0acfcac6d889b41dee85a32f55976f
This commit is contained in:
Ryan Culpepper 2009-12-13 03:06:58 +00:00
commit 2ef398f6bb
2 changed files with 95 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

186
collects/macro-debugger/syntax-browser/text.ss
View File

@ -5,16 +5,15 @@
scheme/gui
drscheme/arrow
framework/framework
unstable/interval-map
unstable/gui/notify)
(provide text:hover<%>
text:hover-identifier<%>
text:mouse-drawings<%>
text:hover-drawings<%>
text:arrows<%>
text:hover-mixin
text:hover-identifier-mixin
text:mouse-drawings-mixin
text:hover-drawings-mixin
text:tacking-mixin
text:arrows-mixin)
@ -28,8 +27,8 @@
(define white (send the-color-database find-color "white"))
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
(define-struct drawing (start end draw visible? tacked?) #:mutable)
;; A Drawing is (make-drawing number number (??? -> void) (box boolean))
(define-struct drawing (start end draw tacked?))
(define-struct idloc (start end id))
@ -68,20 +67,14 @@
(interface (text:basic<%>)
update-hover-position))
(define text:hover-identifier<%>
(interface ()
get-hovered-identifier
set-hovered-identifier
listen-hovered-identifier))
(define text:mouse-drawings<%>
(define text:hover-drawings<%>
(interface (text:basic<%>)
add-mouse-drawing
for-each-drawing
add-hover-drawing
get-position-drawings
delete-all-drawings))
(define text:arrows<%>
(interface (text:mouse-drawings<%>)
(interface (text:hover-drawings<%>)
add-arrow
add-question-arrow
add-billboard))
@ -106,89 +99,62 @@
(super-new)))
(define text:hover-identifier-mixin
(mixin (text:hover<%>) (text:hover-identifier<%>)
(define-notify hovered-identifier (new notify-box% (value #f)))
(define idlocs null)
(define/public (add-identifier-location start end id)
(set! idlocs (cons (make-idloc start end id) idlocs)))
(define/public (delete-all-identifier-locations)
(set! idlocs null)
(set-hovered-identifier #f))
(define/override (update-hover-position pos)
(super update-hover-position pos)
(let search ([idlocs idlocs])
(cond [(null? idlocs) (set-hovered-identifier #f)]
[(and (<= (idloc-start (car idlocs)) pos)
(< pos (idloc-end (car idlocs))))
(set-hovered-identifier (idloc-id (car idlocs)))]
[else (search (cdr idlocs))])))
(super-new)))
(define text:mouse-drawings-mixin
(mixin (text:hover<%>) (text:mouse-drawings<%>)
(define text:hover-drawings-mixin
(mixin (text:hover<%>) (text:hover-drawings<%>)
(inherit dc-location-to-editor-location
find-position
invalidate-bitmap-cache)
;; list of Drawings
(field [drawings-list null])
;; interval-map of Drawings
(define drawings-list (make-numeric-interval-map))
(define/public add-mouse-drawing
(case-lambda
[(start end draw)
(add-mouse-drawing start end draw (box #f))]
[(start end draw tack-box)
(set! drawings-list
(cons (make-drawing start end draw #f tack-box)
drawings-list))]))
(field [hover-position #f])
(define/override (update-hover-position pos)
(define old-pos hover-position)
(super update-hover-position pos)
(set! hover-position pos)
(unless (same-drawings? old-pos pos)
(invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
(define/public (add-hover-drawing start end draw [tack-box (box #f)])
(interval-map-cons*! drawings-list
start (add1 end)
(make-drawing start end draw tack-box)
null))
(define/public (delete-all-drawings)
(set! drawings-list null))
(define/public-final (for-each-drawing f)
(for-each f drawings-list))
(interval-map-remove! drawings-list -inf.0 +inf.0))
(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?
(for-each-drawing
(lambda (d)
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
((drawing-draw d) this dc left top right bottom dx dy))))))
(for ([d (get-position-drawings hover-position)])
((drawing-draw d) this dc left top right bottom dx dy))))
(define/override (update-hover-position pos)
(super update-hover-position pos)
(let ([changed? (update-visible-drawings pos)])
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
(define/public (get-position-drawings pos)
(if pos (interval-map-ref drawings-list pos null) null))
(define/private (update-visible-drawings pos)
(let ([changed? #f])
(for-each-drawing
(lambda (d)
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
(unless (eqv? vis? (drawing-visible? d))
(set-drawing-visible?! d vis?)
(set! changed? #t)))))
changed?))
(define/private (same-drawings? old-pos pos)
;; relies on order drawings added & list-of-eq?-struct equality
(equal? (get-position-drawings old-pos)
(get-position-drawings pos)))
(super-new)))
(define text:tacking-mixin
(mixin (text:basic<%> text:mouse-drawings<%>) ()
(mixin (text:basic<%> text:hover-drawings<%>) ()
(inherit get-canvas
for-each-drawing)
(inherit-field drawings-list)
get-position-drawings)
(inherit-field hover-position)
(super-new)
(define tacked-table (make-hasheq))
(define/override (on-event ev)
(case (send ev get-event-type)
((right-down)
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
(if (pair? (get-position-drawings hover-position))
(send (get-canvas) popup-menu
(make-tack/untack-menu)
(send ev get-x)
@ -197,6 +163,12 @@
(else
(super on-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?
(for ([draw (in-hash-keys tacked-table)])
(draw this dc left top right bottom dx dy))))
(define/private (make-tack/untack-menu)
(define menu (new popup-menu%))
(new menu-item% (label "Tack")
@ -210,20 +182,18 @@
menu)
(define/private (tack)
(for-each-drawing
(lambda (d)
(when (drawing-visible? d)
(set-box! (drawing-tacked? d) #t)))))
(for ([d (get-position-drawings hover-position)])
(hash-set! tacked-table (drawing-draw d) #t)
(set-box! (drawing-tacked? d) #t)))
(define/private (untack)
(for-each-drawing
(lambda (d)
(when (drawing-visible? d)
(set-box! (drawing-tacked? d) #f)))))))
(for ([d (get-position-drawings hover-position)])
(hash-remove! tacked-table (drawing-draw d))
(set-box! (drawing-tacked? d) #f)))))
(define text:arrows-mixin
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
(mixin (text:hover-drawings<%>) (text:arrows<%>)
(inherit position-location
add-mouse-drawing
add-hover-drawing
find-wordbreak)
(define/public (add-arrow from1 from2 to1 to2 color)
@ -256,7 +226,7 @@
(+ w mini mini)
(+ h mini mini))
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
(add-mouse-drawing pos1 pos2 draw)))
(add-hover-drawing pos1 pos2 draw)))
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
(define color (send the-color-database find-color color-name))
@ -286,8 +256,8 @@
(send dc draw-text "?"
(+ endx dx fw)
(- (+ endy dy) fh)))))))])
(add-mouse-drawing from1 from2 draw tack-box)
(add-mouse-drawing to1 to2 draw tack-box))))
(add-hover-drawing from1 from2 draw tack-box)
(add-hover-drawing to1 to2 draw tack-box))))
(define/private (position->location p)
(define xbox (box 0.0))
@ -312,12 +282,44 @@
(super-new)))
(define text:mouse-drawings%
(text:mouse-drawings-mixin
(define text:hover-drawings%
(text:hover-drawings-mixin
(text:hover-mixin
text:standard-style-list%)))
(define text:arrows%
(text:arrows-mixin
(text:tacking-mixin
text:mouse-drawings%)))
text:hover-drawings%)))
#|
(define text:hover-identifier<%>
(interface ()
get-hovered-identifier
set-hovered-identifier
listen-hovered-identifier))
(define text:hover-identifier-mixin
(mixin (text:hover<%>) (text:hover-identifier<%>)
(define-notify hovered-identifier (new notify-box% (value #f)))
(define idlocs null)
(define/public (add-identifier-location start end id)
(set! idlocs (cons (make-idloc start end id) idlocs)))
(define/public (delete-all-identifier-locations)
(set! idlocs null)
(set-hovered-identifier #f))
(define/override (update-hover-position pos)
(super update-hover-position pos)
(let search ([idlocs idlocs])
(cond [(null? idlocs) (set-hovered-identifier #f)]
[(and (<= (idloc-start (car idlocs)) pos)
(< pos (idloc-end (car idlocs))))
(set-hovered-identifier (idloc-id (car idlocs)))]
[else (search (cdr idlocs))])))
(super-new)))
|#

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

@ -253,7 +253,7 @@
(define browser-text%
(class (text:arrows-mixin
(text:tacking-mixin
(text:mouse-drawings-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:hide-caret/selection-mixin
(editor:standard-style-list-mixin text:basic%))))))