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

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)))
 

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)
+            (for ([id (send: range range<%> get-identifier-list)])
-                        (when (send partition same-partition? selected-syntax id)
+              (when (send: partition partition<%>
-                          (draw-secondary-connection id)))
+                           same-partition? selected-syntax id)
-                      (send range get-identifier-list))))))
+                (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 ([r (send: range range<%> get-ranges selected-syntax)])
-        (for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
+        (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 ([r (send range get-ranges stx2)])
-        (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
+        (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))
-

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)
+    (for ([stx stxs])
-                (send w add-syntax stx)
+      (send w add-syntax stx)
-                (send w add-separator))
+      (send w add-separator))))
-              stxs)))
 
 ;; make-syntax-browser : -> syntax-browser<%>
 (define (make-syntax-browser)

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<%>
+(define-interface displays-manager<%>
-  (interface ()
+  (;; add-syntax-display : display<%> -> void
-    ;; add-syntax-display : display<%> -> void
+   add-syntax-display
-    add-syntax-display
 
-    ;; remove-all-syntax-displays : -> void
+   ;; remove-all-syntax-displays : -> void
-    remove-all-syntax-displays))
+   remove-all-syntax-displays))
 
 ;; selection-manager<%>
-(define selection-manager<%>
+(define-interface selection-manager<%>
-  (interface ()
+  (;; selected-syntax : syntax/#f
-    ;; selected-syntax : syntax/#f
+   set-selected-syntax
-    set-selected-syntax
+   get-selected-syntax
-    get-selected-syntax
+   listen-selected-syntax))
-    listen-selected-syntax
-    ))
 
 ;; mark-manager<%>
 ;; Manages marks, mappings from marks to colors
-(define mark-manager<%>
+(define-interface mark-manager<%>
-  (interface ()
+  (;; get-primary-partition : -> partition
-    ;; get-primary-partition : -> partition
+   get-primary-partition))
-    get-primary-partition))
 
 ;; secondary-partition<%>
-(define secondary-partition<%>
+(define-interface secondary-partition<%>
-  (interface (displays-manager<%>)
+  (;; get-secondary-partition : -> partition<%>
-    ;; get-secondary-partition : -> partition<%>
+   get-secondary-partition
-    get-secondary-partition
 
-    ;; set-secondary-partition : partition<%> -> void
+   ;; set-secondary-partition : partition<%> -> void
-    set-secondary-partition
+   set-secondary-partition
 
-    ;; listen-secondary-partition : (partition<%> -> void) -> void
+   ;; listen-secondary-partition : (partition<%> -> void) -> void
-    listen-secondary-partition
+   listen-secondary-partition
 
-    ;; get-identifier=? : -> (cons string procedure)
+   ;; get-identifier=? : -> (cons string procedure)
-    get-identifier=?
+   get-identifier=?
 
-    ;; set-identifier=? : (cons string procedure) -> void
+   ;; set-identifier=? : (cons string procedure) -> void
-    set-identifier=?
+   set-identifier=?
 
-    ;; listen-identifier=? : ((cons string procedure) -> void) -> void
+   ;; listen-identifier=? : ((cons string procedure) -> void) -> void
-    listen-identifier=?))
+   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<%>
+(define-interface host<%>
-  (interface ()
+  (;; get-controller : -> controller<%>
-    ;; get-controller : -> controller<%>
+   get-controller
-    get-controller
-
-    ;; add-keymap : text snip
-    add-keymap
-    ))
 
+   ;; add-keymap : text snip
+   add-keymap))
 
 ;; display<%>
-(define display<%>
+(define-interface display<%>
-  (interface ()
+  (;; refresh : -> void
-    ;; refresh : -> void
+   refresh
-    refresh
 
-    ;; highlight-syntaxes : (list-of syntax) color -> void
+   ;; highlight-syntaxes : (list-of syntax) color -> void
-    highlight-syntaxes
+   highlight-syntaxes
 
-    ;; get-start-position : -> number
+   ;; underline-syntaxes : (listof syntax) -> void
-    get-start-position
+   underline-syntaxes
 
-    ;; get-end-position : -> number
+   ;; get-start-position : -> number
-    get-end-position
+   get-start-position
 
-    ;; get-range : -> range<%>
+   ;; get-end-position : -> number
-    get-range))
+   get-end-position
+
+   ;; get-range : -> range<%>
+   get-range))
 
 ;; range<%>
-(define range<%>
+(define-interface range<%>
-  (interface ()
+  (;; get-ranges : datum -> (list-of (cons number number))
-    ;; get-ranges : datum -> (list-of (cons number number))
+   get-ranges
-    get-ranges
 
-    ;; all-ranges : (list-of Range)
+   ;; all-ranges : (list-of Range)
-    ;; Sorted outermost-first
+   ;; Sorted outermost-first
-    all-ranges
+   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<%>
+(define-interface syntax-prefs<%>
-  (interface ()
+  (pref:width
-    pref:width
+   pref:height
-    pref:height
+   pref:props-percentage
-    pref:props-percentage
+   pref:props-shown?))
-    pref:props-shown?))
 
 ;; widget-hooks<%>
-(define widget-hooks<%>
+(define-interface widget-hooks<%>
-  (interface ()
+  (;; setup-keymap : -> void
-    ;; setup-keymap : -> void
+   setup-keymap
-    setup-keymap
 
-    ;; shutdown : -> void
+   ;; shutdown : -> void
-    shutdown
+   shutdown))
-    ))
 
 ;; keymap-hooks<%>
-(define keymap-hooks<%>
+(define-interface keymap-hooks<%>
-  (interface ()
+  (;; make-context-menu : -> context-menu<%>
-    ;; make-context-menu : -> context-menu<%>
+   make-context-menu
-    make-context-menu
 
-    ;; get-context-menu% : -> class
+   ;; get-context-menu% : -> class
-    get-context-menu%))
+   get-context-menu%))
 
 ;; context-menu-hooks<%>
-(define context-menu-hooks<%>
+(define-interface context-menu-hooks<%>
-  (interface ()
+  (add-edit-items
-    add-edit-items
+   after-edit-items
-    after-edit-items
+   add-selection-items
-    add-selection-items
+   after-selection-items
-    after-selection-items
+   add-partition-items
-    add-partition-items
+   after-partition-items))
-    after-partition-items))
 
 
 ;;----------
 
 ;; Convenience widget, specialized for displaying stx and not much else
-(define syntax-browser<%>
+(define-interface syntax-browser<%>
-  (interface ()
+  (add-syntax
-    add-syntax
+   add-text
-    add-text
+   add-separator
-    add-separator
+   erase-all
-    erase-all
+   select-syntax
-    select-syntax
+   get-text))
-    get-text
-    ))
 
-(define partition<%>
+(define-interface partition<%>
-  (interface ()
+  (;; get-partition : any -> number
-    ;; get-partition : any -> number
+   get-partition
-    get-partition
 
-    ;; same-partition? : any any -> number
+   ;; same-partition? : any any -> number
-    same-partition?
+   same-partition?
 
-    ;; count : -> number
+   ;; count : -> number
-    count))
+   count))

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
+    (send: controller selection-manager<%> listen-selected-syntax
-          (lambda (stx)
+           (lambda (stx)
-            (set! selected-syntax stx)
+             (set! selected-syntax stx)
-            (refresh)))
+             (refresh)))
     (super-new)
 
     ;; get-mode : -> symbol

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)]
+          (let ([range (send: display display<%> get-range)]
-                [start (send display get-start-position)])
+                [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))
+              (send: display display<%> underline-syntaxes binders))
-            (for ([id (send range get-identifier-list)])
+            (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 ([binder-r (send: range range<%> get-ranges binder)])
-                  (for ([id-r (send range get-ranges id)])
+                  (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)