diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index 19451d6..3524158 100644 --- 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 index 06e04ff..d0645e4 100644 --- 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 index 87519bc..b5a8489 100644 --- 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 index d01315e..49096d5 100644 --- 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 - )) +(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-interface syntax-browser<%> + (add-syntax + add-text + add-separator + erase-all + select-syntax + get-text)) -(define partition<%> - (interface () - ;; get-partition : any -> number - get-partition +(define-interface partition<%> + (;; get-partition : any -> number + get-partition - ;; same-partition? : any any -> number - same-partition? + ;; same-partition? : any any -> number + same-partition? - ;; count : -> number - count)) + ;; count : -> number + count)) diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index ab1a3c8..2d84de3 100644 --- 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 index 29559e1..d7eba23 100644 --- 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)