commit 4e683ad1029a5463a66c919f59a823ccd2ef83e1
parent 30f9d07cc2c23921015cf3c19a1c1f31e002b2ca
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 13 Jan 2009 20:36:16 +0000
macro stepper: changed syntax browser classes to use iop
-- This line, and those below, will be ignored--
M macro-debugger/syntax-browser/properties.ss
M macro-debugger/syntax-browser/display.ss
M macro-debugger/syntax-browser/widget.ss
M macro-debugger/syntax-browser/controller.ss
M macro-debugger/syntax-browser/interfaces.ss
M macro-debugger/syntax-browser/frame.ss
M macro-debugger/util/class-iop.ss
svn: r13092
original commit: 3b8c1640745e810b044a62188930834345fdfeca
Diffstat:
6 files changed, 158 insertions(+), 149 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss
@@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
+ macro-debugger/util/class-iop
"interfaces.ss"
"partition.ss"
"../util/notify.ss")
@@ -31,7 +32,7 @@
(super-new)
(listen-selected-syntax
(lambda (new-value)
- (for-each (lambda (display) (send display refresh))
+ (for-each (lambda (display) (send: display display<%> refresh))
displays)))))
;; mark-manager-mixin
@@ -62,7 +63,7 @@
(new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition
(lambda (p)
- (for-each (lambda (d) (send d refresh))
+ (for-each (lambda (d) (send: d display<%> refresh))
displays)))
(super-new)))
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -3,6 +3,7 @@
(require scheme/class
scheme/gui
scheme/match
+ macro-debugger/util/class-iop
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
@@ -17,7 +18,7 @@
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
- (send controller get-primary-partition)
+ (send: controller controller<%> get-primary-partition)
(send config get-colors)
(send config get-suffix-option)
columns))
@@ -42,13 +43,14 @@
;; add-clickbacks : text% range% controller<%> number -> void
(define (add-clickbacks text range controller insertion-point)
- (for ([range (send range all-ranges)])
+ (for ([range (send: range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ insertion-point start) (+ insertion-point end)
(lambda (_1 _2 _3)
- (send controller set-selected-syntax stx))))))
+ (send: controller selection-manager<%>
+ set-selected-syntax stx))))))
;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end)
@@ -81,7 +83,9 @@
(begin-edit-sequence)
(change-style unhighlight-d start-position end-position))
(apply-extra-styles)
- (let ([selected-syntax (send controller get-selected-syntax)])
+ (let ([selected-syntax
+ (send: controller selection-manager<%>
+ get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
@@ -126,9 +130,11 @@
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
- (define color-styles (list->vector (map color-style (send config get-colors))))
+ (define color-styles
+ (list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
- (define color-partition (send controller get-primary-partition))
+ (define color-partition
+ (send: controller mark-manager<%> get-primary-partition))
(define offset start-position)
(for-each
(lambda (range)
@@ -139,12 +145,12 @@
(primary-style stx color-partition color-styles overflow-style)
(+ offset start)
(+ offset end))))
- (send range all-ranges)))
+ (send: range range<%> all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
- (let ([n (send partition get-partition stx)])
+ (let ([n (send: partition partition<%> get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
@@ -157,7 +163,7 @@
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles])
- (for ([r (send range get-ranges stx)])
+ (for ([r (send: range range<%> get-ranges stx)])
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
@@ -166,23 +172,25 @@
;; in the same partition in blue.
(define/private (apply-secondary-partition-styles selected-syntax)
(when (identifier? selected-syntax)
- (let ([partition (send controller get-secondary-partition)])
+ (let ([partition
+ (send: controller secondary-partition<%>
+ get-secondary-partition)])
(when partition
- (for-each (lambda (id)
- (when (send partition same-partition? selected-syntax id)
- (draw-secondary-connection id)))
- (send range get-identifier-list))))))
+ (for ([id (send: range range<%> get-identifier-list)])
+ (when (send: partition partition<%>
+ same-partition? selected-syntax id)
+ (draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
- (let ([rs (send range get-ranges selected-syntax)])
- (for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
+ (for ([r (send: range range<%> get-ranges selected-syntax)])
+ (restyle-range r select-highlight-d)))
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
- (let ([rs (send range get-ranges stx2)])
- (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
+ (for ([r (send range get-ranges stx2)])
+ (restyle-range r select-sub-highlight-d)))
;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style)
@@ -258,4 +266,3 @@
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define unhighlight-d (highlight-style-delta "white" #f))
-
diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss
@@ -1,4 +1,3 @@
-
#lang scheme/base
(require scheme/class
scheme/gui
@@ -20,10 +19,9 @@
;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
- (for-each (lambda (stx)
- (send w add-syntax stx)
- (send w add-separator))
- stxs)))
+ (for ([stx stxs])
+ (send w add-syntax stx)
+ (send w add-separator))))
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)
diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss
@@ -1,165 +1,165 @@
#lang scheme/base
-(require scheme/class)
+(require scheme/class
+ macro-debugger/util/class-iop)
(provide (all-defined-out))
;; displays-manager<%>
-(define displays-manager<%>
- (interface ()
- ;; add-syntax-display : display<%> -> void
- add-syntax-display
+(define-interface displays-manager<%>
+ (;; add-syntax-display : display<%> -> void
+ add-syntax-display
- ;; remove-all-syntax-displays : -> void
- remove-all-syntax-displays))
+ ;; remove-all-syntax-displays : -> void
+ remove-all-syntax-displays))
;; selection-manager<%>
-(define selection-manager<%>
- (interface ()
- ;; selected-syntax : syntax/#f
- set-selected-syntax
- get-selected-syntax
- listen-selected-syntax
- ))
+(define-interface selection-manager<%>
+ (;; selected-syntax : syntax/#f
+ set-selected-syntax
+ get-selected-syntax
+ listen-selected-syntax))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
-(define mark-manager<%>
- (interface ()
- ;; get-primary-partition : -> partition
- get-primary-partition))
+(define-interface mark-manager<%>
+ (;; get-primary-partition : -> partition
+ get-primary-partition))
;; secondary-partition<%>
-(define secondary-partition<%>
- (interface (displays-manager<%>)
- ;; get-secondary-partition : -> partition<%>
- get-secondary-partition
+(define-interface secondary-partition<%>
+ (;; get-secondary-partition : -> partition<%>
+ get-secondary-partition
- ;; set-secondary-partition : partition<%> -> void
- set-secondary-partition
+ ;; set-secondary-partition : partition<%> -> void
+ set-secondary-partition
- ;; listen-secondary-partition : (partition<%> -> void) -> void
- listen-secondary-partition
+ ;; listen-secondary-partition : (partition<%> -> void) -> void
+ listen-secondary-partition
- ;; get-identifier=? : -> (cons string procedure)
- get-identifier=?
+ ;; get-identifier=? : -> (cons string procedure)
+ get-identifier=?
- ;; set-identifier=? : (cons string procedure) -> void
- set-identifier=?
+ ;; set-identifier=? : (cons string procedure) -> void
+ set-identifier=?
- ;; listen-identifier=? : ((cons string procedure) -> void) -> void
- listen-identifier=?))
+ ;; listen-identifier=? : ((cons string procedure) -> void) -> void
+ listen-identifier=?))
;; controller<%>
-(define controller<%>
+(define-interface/dynamic controller<%>
(interface (displays-manager<%>
selection-manager<%>
mark-manager<%>
- secondary-partition<%>)))
+ secondary-partition<%>))
+ (add-syntax-display
+ remove-all-syntax-displays
+ set-selected-syntax
+ get-selected-syntax
+ listen-selected-syntax
+ get-primary-partition
+ get-secondary-partition
+ set-secondary-partition
+ listen-secondary-partition
+ get-identifier=?
+ set-identifier=?
+ listen-identifier=?))
-;; host<%>
-(define host<%>
- (interface ()
- ;; get-controller : -> controller<%>
- get-controller
- ;; add-keymap : text snip
- add-keymap
- ))
+;; host<%>
+(define-interface host<%>
+ (;; get-controller : -> controller<%>
+ get-controller
+ ;; add-keymap : text snip
+ add-keymap))
;; display<%>
-(define display<%>
- (interface ()
- ;; refresh : -> void
- refresh
+(define-interface display<%>
+ (;; refresh : -> void
+ refresh
- ;; highlight-syntaxes : (list-of syntax) color -> void
- highlight-syntaxes
+ ;; highlight-syntaxes : (list-of syntax) color -> void
+ highlight-syntaxes
- ;; get-start-position : -> number
- get-start-position
+ ;; underline-syntaxes : (listof syntax) -> void
+ underline-syntaxes
- ;; get-end-position : -> number
- get-end-position
+ ;; get-start-position : -> number
+ get-start-position
- ;; get-range : -> range<%>
- get-range))
+ ;; get-end-position : -> number
+ get-end-position
+
+ ;; get-range : -> range<%>
+ get-range))
;; range<%>
-(define range<%>
- (interface ()
- ;; get-ranges : datum -> (list-of (cons number number))
- get-ranges
+(define-interface range<%>
+ (;; get-ranges : datum -> (list-of (cons number number))
+ get-ranges
+
+ ;; all-ranges : (list-of Range)
+ ;; Sorted outermost-first
+ all-ranges
- ;; all-ranges : (list-of Range)
- ;; Sorted outermost-first
- all-ranges
+ ;; get-identifier-list : (list-of identifier)
+ get-identifier-list))
- ;; get-identifier-list : (list-of identifier)
- get-identifier-list))
;; A Range is (make-range datum number number)
(define-struct range (obj start end))
;; syntax-prefs<%>
-(define syntax-prefs<%>
- (interface ()
- pref:width
- pref:height
- pref:props-percentage
- pref:props-shown?))
+(define-interface syntax-prefs<%>
+ (pref:width
+ pref:height
+ pref:props-percentage
+ pref:props-shown?))
;; widget-hooks<%>
-(define widget-hooks<%>
- (interface ()
- ;; setup-keymap : -> void
- setup-keymap
+(define-interface widget-hooks<%>
+ (;; setup-keymap : -> void
+ setup-keymap
- ;; shutdown : -> void
- shutdown
- ))
+ ;; shutdown : -> void
+ shutdown))
;; keymap-hooks<%>
-(define keymap-hooks<%>
- (interface ()
- ;; make-context-menu : -> context-menu<%>
- make-context-menu
+(define-interface keymap-hooks<%>
+ (;; make-context-menu : -> context-menu<%>
+ make-context-menu
- ;; get-context-menu% : -> class
- get-context-menu%))
+ ;; get-context-menu% : -> class
+ get-context-menu%))
;; context-menu-hooks<%>
-(define context-menu-hooks<%>
- (interface ()
- add-edit-items
- after-edit-items
- add-selection-items
- after-selection-items
- add-partition-items
- after-partition-items))
+(define-interface context-menu-hooks<%>
+ (add-edit-items
+ after-edit-items
+ add-selection-items
+ after-selection-items
+ add-partition-items
+ after-partition-items))
;;----------
;; Convenience widget, specialized for displaying stx and not much else
-(define syntax-browser<%>
- (interface ()
- add-syntax
- add-text
- add-separator
- erase-all
- select-syntax
- get-text
- ))
-
-(define partition<%>
- (interface ()
- ;; get-partition : any -> number
- get-partition
-
- ;; same-partition? : any any -> number
- same-partition?
-
- ;; count : -> number
- count))
+(define-interface syntax-browser<%>
+ (add-syntax
+ add-text
+ add-separator
+ erase-all
+ select-syntax
+ get-text))
+
+(define-interface partition<%>
+ (;; get-partition : any -> number
+ get-partition
+
+ ;; same-partition? : any any -> number
+ same-partition?
+
+ ;; count : -> number
+ count))
diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss
@@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
+ macro-debugger/util/class-iop
"interfaces.ss"
"util.ss"
"../util/mpi.ss")
@@ -24,10 +25,10 @@
(field (text (new text%)))
(field (pdisplayer (new properties-displayer% (text text))))
- (send controller listen-selected-syntax
- (lambda (stx)
- (set! selected-syntax stx)
- (refresh)))
+ (send: controller selection-manager<%> listen-selected-syntax
+ (lambda (stx)
+ (set! selected-syntax stx)
+ (refresh)))
(super-new)
;; get-mode : -> symbol
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -6,6 +6,7 @@
scheme/list
scheme/match
syntax/boundmap
+ macro-debugger/util/class-iop
"interfaces.ss"
"controller.ss"
"display.ss"
@@ -119,7 +120,8 @@
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(for-each (lambda (hi-stxs hi-color)
- (send display highlight-syntaxes hi-stxs hi-color))
+ (send: display display<%>
+ highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
(for ([definite definites])
@@ -128,20 +130,20 @@
(for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t))))
(when alpha-table
- (let ([range (send display get-range)]
- [start (send display get-start-position)])
+ (let ([range (send: display display<%> get-range)]
+ [start (send: display display<%> get-start-position)])
(let* ([binders0
(module-identifier-mapping-map alpha-table (lambda (k v) k))]
[binders
(apply append (map get-binders binders0))])
- (send display underline-syntaxes binders))
- (for ([id (send range get-identifier-list)])
+ (send: display display<%> underline-syntaxes binders))
+ (for ([id (send: range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED
(add-binding-billboard start range id definite?))
(for ([binder (get-binders id)])
- (for ([binder-r (send range get-ranges binder)])
- (for ([id-r (send range get-ranges id)])
+ (for ([binder-r (send: range range<%> get-ranges binder)])
+ (for ([id-r (send: range range<%> get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))))
(void)))
@@ -169,7 +171,7 @@
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))
- (send range get-ranges id))]
+ (send: range range<%> get-ranges id))]
[_ (void)]))
(define/public (add-separator)
@@ -182,7 +184,7 @@
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
- (send controller remove-all-syntax-displays))
+ (send: controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text)
