Reorganized syntax-browser

svn: r4500

original commit: 2954ed58441dd1cdf4492a9bc2362c41fc6288d2

collects/macro-debugger/syntax-browser.ss

@@ -1,8 +1,8 @@
 
 (module syntax-browser mzscheme
-  (require "syntax-browser/syntax-browser.ss"
+  (require "syntax-browser/browser.ss")
-           "syntax-browser/syntax-snip.ss")
-  
   (provide browse-syntax
            browse-syntaxes
-           syntax-snip))
+           make-syntax-browser
+           syntax-snip)
+  )

collects/macro-debugger/syntax-browser/controller.ss

@@ -2,8 +2,7 @@
 (module controller mzscheme
   (require (lib "class.ss")
            "interfaces.ss"
-           "partition.ss"
+           "partition.ss")
-           "properties.ss")
   
   (provide syntax-controller%)
   
@@ -17,8 +16,7 @@
       (define selection-listeners null)
       (define selected-syntax #f)
       (define identifier=?-listeners null)
-      (init-field (properties-controller
+      (init-field (properties-controller #f))
-                   (new independent-properties-controller% (controller this))))
 
       ;; syntax-controller<%> Methods
 
@@ -31,6 +29,8 @@
       (define/public (get-selected-syntax) selected-syntax)
 
       (define/public (get-properties-controller) properties-controller)
+      (define/public (set-properties-controller pc)
+        (set! properties-controller pc))
 
       (define/public (add-view-colorer c)
         (set! colorers (cons c colorers))

collects/macro-debugger/syntax-browser/embed.ss

@@ -0,0 +1,11 @@
+
+(module embed mzscheme
+  (require "interfaces.ss"
+           "implementation.ss"
+           "params.ss"
+           "partition.ss")
+  
+  (provide (all-from "interfaces.ss")
+           (all-from "implementation.ss")
+           (all-from "params.ss")
+           identifier=-choices))

collects/macro-debugger/syntax-browser/frame.ss

@@ -0,0 +1,51 @@
+
+(module frame mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           "interfaces.ss")
+  (provide frame@)
+  
+  (define frame@
+    (unit/sig browser^
+      (import prefs^
+              widget^)
+      
+      ;; browse-syntax : syntax -> void
+      (define (browse-syntax stx)
+        (browse-syntaxes (list stx)))
+      
+      ;; 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)))
+      
+      ;; make-syntax-browser : -> syntax-browser<%>
+      (define (make-syntax-browser)
+        (let* ([view (new syntax-browser-frame%)])
+          (send view show #t)
+          (send view get-widget)))
+      
+      ;; syntax-browser-frame%
+      (define syntax-browser-frame%
+        (class* frame% ()
+          (super-new (label "Syntax Browser")
+                     (width (pref:width))
+                     (height (pref:height)))
+          (define widget
+            (new syntax-widget/controls%
+                 (parent this)
+                 (pref:props-percentage pref:props-percentage)))
+          (define/public (get-widget) widget)
+          (define/augment (on-close)
+            (pref:width (send this get-width))
+            (pref:height (send this get-height))
+            (send widget save-prefs)
+            (preferences:save)
+            (inner (void) on-close))
+          ))))
+  )

collects/macro-debugger/syntax-browser/interfaces.ss

@@ -1,8 +1,66 @@
 
 (module interfaces mzscheme
-  (require (lib "class.ss"))
+  (require (lib "class.ss")
+           (lib "unitsig.ss"))
   (provide (all-defined))
 
+  ;; Signatures
+  
+  (define-signature browser^
+    (;; browse-syntax : syntax -> void
+     browse-syntax
+     
+     ;; browse-syntaxes : (list-of syntax) -> void
+     browse-syntaxes
+     
+     ;; make-syntax-browser : -> syntax-browser<%>
+     make-syntax-browser
+     
+     ;; syntax-browser-frame%
+     syntax-browser-frame%))
+
+  (define-signature prefs^
+    (;; pref:width : pref of number
+     pref:width
+     
+     ;; pref:height : pref of number
+     pref:height
+     
+     ;; pref:props-percentage : pref of number in (0,1)
+     pref:props-percentage))
+
+  (define-signature keymap^
+    (;; syntax-keymap% implements syntax-keymap<%>
+     syntax-keymap%))
+  
+  (define-signature context-menu^
+    (;; context-menu%
+     context-menu%))
+
+  (define-signature snip^
+    (;; syntax-snip : syntax -> snip
+     syntax-snip
+     
+     ;; syntax-snip%
+     syntax-snip%))
+
+  (define-signature snipclass^
+    (;; snip-class
+     snip-class))
+  
+  (define-signature widget^
+    (;; syntax-widget%
+     syntax-widget%
+     
+     ;; syntax-widget/controls%
+     syntax-widget/controls%))
+
+  (define-signature implementation^
+    ([unit widget : widget^]
+     [unit snip : snip^]))
+  
+  ;; Class Interfaces
+
   ;; syntax-controller<%>
   ;; A syntax-controller coordinates state shared by many different syntax views.
   ;; Syntax views can share:

collects/macro-debugger/syntax-browser/keymap.ss

@@ -0,0 +1,123 @@
+
+(module keymap mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           "interfaces.ss"
+           "partition.ss")
+  (provide keymap@
+           context-menu@)
+  
+  (define keymap@
+    (unit/sig keymap^
+      (import)
+      
+      (define syntax-keymap%
+        (class keymap%
+          (init editor)
+          (init-field context-menu)
+          
+          (inherit add-function
+                   map-function
+                   chain-to-keymap)
+          (super-new)
+          
+          ;; Initialization
+          (map-function "rightbutton" "popup-context-window")
+          (add-function "popup-context-window"
+                        (lambda (editor event)
+                          (do-popup-context-window editor event)))
+          
+          ;; Attach to editor
+          (chain-to-keymap (send editor get-keymap) #t)
+          (send editor set-keymap this)
+          
+          (define/private (do-popup-context-window editor event)
+            (define-values (x y)
+              (send editor dc-location-to-editor-location
+                    (send event get-x)
+                    (send event get-y)))
+            (define admin (send editor get-admin))
+            (send admin popup-menu context-menu x y))))))
+  
+  (define context-menu@
+    (unit/sig context-menu^
+      (import snip^)
+
+      (define context-menu%
+        (class popup-menu%
+          (init-field controller)
+          (super-new)
+
+          (define/public (add-edit-items)
+            (new menu-item% (label "Copy") (parent this)
+                 (callback (lambda (i e)
+                             (define stx (send controller get-selected-syntax))
+                             (send the-clipboard set-clipboard-string
+                                   (if stx 
+                                       (format "~s" (syntax-object->datum stx))
+                                       "")
+                                   (send e get-time-stamp)))))
+            (new menu-item% (label "Copy syntax") (parent this)
+                 (callback (lambda (i e)
+                             (define stx (send controller get-selected-syntax))
+                             (define t (new text%))
+                             (send t insert
+                                   (new syntax-snip%
+                                        (syntax stx)
+                                        #;(controller controller)))
+                             (send t select-all)
+                             (send t copy))))
+            (void))
+
+          (define/public (after-edit-items)
+            (void))
+
+          (define/public (add-selection-items)
+            (new menu-item%
+                 (label "Clear selection")
+                 (parent this)
+                 (callback (lambda _ (send controller select-syntax #f))))
+            (void))
+          
+          (define/public (after-selection-items)
+            (void))
+
+          (define/public (add-partition-items)
+            (let ([secondary (new menu% (label "identifier=?") (parent this))])
+              (for-each
+               (lambda (name func)
+                 (let ([this-choice
+                        (new checkable-menu-item%
+                             (label name)
+                             (parent secondary)
+                             (callback 
+                              (lambda (i e)
+                                (send controller on-update-identifier=? name func))))])
+                   (send controller add-identifier=?-listener
+                         (lambda (new-name new-id=?) 
+                           (send this-choice check (eq? name new-name))))))
+               (map car (identifier=-choices))
+               (map cdr (identifier=-choices))))
+            (void))
+          
+          (define/public (after-partition-items)
+            (void))
+
+          (define/public (add-separator)
+            (new separator-menu-item% (parent this)))
+          
+          ;; Initialization
+          (add-edit-items)
+          (after-edit-items)
+
+          (add-separator)
+          (add-selection-items)
+          (after-selection-items)
+
+          (add-separator)
+          (add-partition-items)
+          (after-partition-items)
+
+          ))))
+  )

collects/macro-debugger/syntax-browser/prefs.ss

@@ -1,11 +1,10 @@
 
 (module prefs mzscheme
-  (require (lib "framework.ss" "framework"))
+  (require (lib "unitsig.ss")
-  (provide (all-defined))
+           (lib "framework.ss" "framework")
-
+           "interfaces.ss")
-  (define current-syntax-font-size (make-parameter #f #;16))
+  (provide prefs@)
-  (define current-default-columns (make-parameter 60))
+  
-
   (define-syntax pref:get/set
     (syntax-rules ()
       [(_ get/set prop)
@@ -14,14 +13,18 @@
            [() (preferences:get 'prop)]
            [(newval) (preferences:set 'prop newval)]))]))
 
-  (preferences:set-default 'SyntaxBrowser:Width 700 number?)
+  (define prefs@
-  (preferences:set-default 'SyntaxBrowser:Height 600 number?)
+    (unit/sig prefs^
-  (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
+      (import)
-  (preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
+      
-
+      (preferences:set-default 'SyntaxBrowser:Width 700 number?)
-  (pref:get/set pref:width SyntaxBrowser:Width)
+      (preferences:set-default 'SyntaxBrowser:Height 600 number?)
-  (pref:get/set pref:height SyntaxBrowser:Height)
+      (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
-  (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
+      (preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
-  (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
+      
+      (pref:get/set pref:width SyntaxBrowser:Width)
+      (pref:get/set pref:height SyntaxBrowser:Height)
+      (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
+      (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)))
   
   )

collects/macro-debugger/syntax-browser/pretty-printer.ss

@@ -9,7 +9,7 @@
            "pretty-range.ss"
            "pretty-helper.ss"
            "interfaces.ss"
-           "prefs.ss")
+           "params.ss")
   (provide syntax-pp%
            (struct range (obj start end)))
 

collects/macro-debugger/syntax-browser/properties.ss

@@ -1,36 +1,10 @@
 
 (module properties mzscheme
-  (require "prefs.ss"
+  (require "interfaces.ss"
-           "interfaces.ss"
-           "partition.ss"
            "util.ss"
            (lib "class.ss")
            (lib "mred.ss" "mred"))
-  (provide properties-view%
+  (provide properties-view%)
-           independent-properties-controller%)
-
-  ;; independent-properties-controller%
-  (define independent-properties-controller%
-    (class* object% (syntax-properties-controller<%>)
-      (init-field controller)
-
-      ;; Properties display
-      (define parent
-        (new frame% (label "Properties") (height (pref:height))
-             (width (floor (* (pref:props-percentage) (pref:width))))))
-      (define pv (new properties-view% (parent parent)))
-
-      (define/private (show-properties)
-        (unless (send parent is-shown?)
-          (send parent show #t)))
-
-      (define/public (set-syntax stx)
-        (send pv set-syntax stx))
-      (define/public (show ?)
-        (send parent show ?))
-      (define/public (is-shown?)
-        (send parent is-shown?))
-      (super-new)))
 
   ;; properties-view%
   (define properties-view%

collects/macro-debugger/syntax-browser/syntax-snip.ss

@@ -1,237 +1,222 @@
 
 (module syntax-snip mzscheme
   (require (lib "class.ss")
-           (lib "match.ss")
+           (lib "unitsig.ss")
-           (lib "list.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
-           (lib "string.ss")
            "interfaces.ss"
-           "partition.ss"
+           "controller.ss"
-           "typesetter.ss"
+           "properties.ss"
-           "widget.ss"
+           "typesetter.ss")
-           "syntax-browser.ss")
+  (provide snip@
-  (provide syntax-snip
+           snip-context-menu-extension@)
-           snip-class
+  
-           syntax-value-snip%
+  (define snip@
-           syntax-snip%)
+    (unit/sig snip^
-
+      (import prefs^
-  ;; syntax-snip : syntax -> snip
+              keymap^
-  (define (syntax-snip stx)
+              context-menu^
-    (new syntax-snip% (syntax stx)))
+              snipclass^)
-
-  (define current-syntax-controller (make-parameter #f))
-
-  (define (the-syntax-controller)
-    (let ([controller (current-syntax-controller)])
-      (or controller
-          (let ([controller (new syntax-controller%)])
-            (current-syntax-controller controller)
-            controller))))
-
-  ;; syntax-value-snip%
-  (define syntax-value-snip%
-    (class* editor-snip% (readable-snip<%>)
-      (init-field ((stx syntax)))
-      (init-field controller)
-      (inherit set-margin
-               set-inset)
-
-      (define -outer (new text:standard-style-list%))
-      (super-new (editor -outer) (with-border? #f))
-      (set-margin 0 0 0 0)
-      (set-inset 2 2 2 2)
-      (refresh)
-
-      (define/private (refresh)
-        (send -outer begin-edit-sequence)
-        (send -outer erase)
-        (new typesetter-for-text%
-             (syntax stx)
-             (controller controller)
-             (text -outer))
-        (send -outer lock #t)
-        (send -outer end-edit-sequence)
-        (send -outer hide-caret #t))
-
-      (define/private (show-props)
-        (send (send controller get-properties-controller)
-              show #t))
       
-      (define/private outer:insert
+      ;; syntax-snip : syntax -> snip
-        (case-lambda
+      (define (syntax-snip stx)
-          [(obj)
+        (new syntax-snip% (syntax stx)))
-           (outer:insert obj style:normal)]
-          [(text style)
-           (outer:insert text style #f)]
-          [(text style clickback)
-           (let ([start (send -outer last-position)])
-             (send -outer insert text)
-             (let ([end (send -outer last-position)])
-               (send -outer change-style style start end #f)
-               (when clickback
-                 (send -outer set-clickback start end clickback))))]))
       
-      ;; BEGIN COPIED from widget.ss
+      (define *syntax-controller* #f)
-      ;; WITH MODIFICATIONS
-      ;; Set up keymap
-      (let ([keymap (send -outer get-keymap)])
-        (send keymap map-function "rightbutton" "popup-context-window")
-        (send keymap add-function "popup-context-window"
-              (lambda (editor event)
-                (do-popup-context-window editor event))))
-      (define/private (do-popup-context-window editor event)
-        (define-values (x y)
-          (send editor dc-location-to-editor-location
-                (send event get-x)
-                (send event get-y)))
-        (define admin (send editor get-admin))
-        (send admin popup-menu context-menu x y))
-      (define context-menu
-        (let ([context-menu (new popup-menu%)])
-          (new menu-item% (label "Copy") (parent context-menu)
-               (callback (lambda (i e)
-                           (define stx (send controller get-selected-syntax))
-                           (send the-clipboard set-clipboard-string
-                                 (if stx 
-                                     (format "~s" (syntax-object->datum stx))
-                                     "")
-                                 (send e get-time-stamp)))))
-          ;; ADDED
-          (new menu-item% (label "Copy syntax") (parent context-menu)
-               (callback (lambda (i e)
-                           (define stx (send controller get-selected-syntax))
-                           (define t (new text%))
-                           (send t insert
-                                 (new syntax-snip%
-                                      (syntax stx)
-                                      (controller controller)))
-                           (send t select-all)
-                           (send t copy))))
-          ;; FIXME: Add option for "formatted" copy/paste?
-          (new menu-item%
-               (label "Clear selection")
-               (parent context-menu)
-               (callback (lambda _ (send controller select-syntax #f))))
-          (new separator-menu-item% (parent context-menu))
-          ;; properties (MODIFIED)
-          (new menu-item% 
-               (label "Show syntax properties")
-               (parent context-menu)
-               (callback (lambda _ (show-props))))
-          ;; syntax browser (ADDED)
-          (new menu-item%
-               (label "Show in browser frame")
-               (parent context-menu)
-               (callback (lambda _ (browse-syntax stx))))
-          ;; primary selection
-          (let ([secondary (new menu% (label "identifier=?") (parent context-menu))])
-            (for-each
-             (lambda (name func)
-               (let ([this-choice
-                      (new checkable-menu-item%
-                           (label name)
-                           (parent secondary)
-                           (callback 
-                            (lambda (i e)
-                              (send controller on-update-identifier=? name func))))])
-                 (send controller add-identifier=?-listener
-                       (lambda (new-name new-id=?) 
-                         (send this-choice check (eq? name new-name))))))
-             (map car (identifier=-choices))
-             (map cdr (identifier=-choices))))
-          context-menu))
-      ;; END COPIED
       
-      ;; snip% Methods
+      (define (the-syntax-controller)
-      (define/override (copy)
+        (let ([controller *syntax-controller*])
-        (new syntax-value-snip% (controller controller) (syntax stx)))
+          (or controller
+              (let* ([controller (new syntax-controller%)]
+                     [props (new independent-properties-controller% (controller controller))])
+                (send controller set-properties-controller props)
+                (set! *syntax-controller* controller)
+                controller))))
       
-      (define/public (read-special src line col pos)
+      ;; syntax-value-snip%
-        (datum->syntax-object #f
+      (define syntax-value-snip%
-                              `(,#'quote-syntax ,stx)
+        (class* editor-snip% (readable-snip<%>)
-                              (list src line col pos 1)))
+          (init-field ((stx syntax)))
+          (init-field controller)
+          (inherit set-margin
+                   set-inset)
+          
+          (define -outer (new text:standard-style-list%))
+          (super-new (editor -outer) (with-border? #f))
+          (set-margin 0 0 0 0)
+          (set-inset 2 2 2 2)
+          (send -outer change-style (make-object style-delta% 'change-alignment 'top))
+          (new syntax-keymap%
+               (editor -outer)
+               (context-menu (new context-menu% (snip this))))
+          (refresh)
+          
+          (define/public (get-controller) controller)
 
+          (define/private (refresh)
+            (send -outer begin-edit-sequence)
+            (send -outer erase)
+            (new typesetter-for-text%
+                 (syntax stx)
+                 (controller controller)
+                 (text -outer))
+            (send -outer lock #t)
+            (send -outer end-edit-sequence)
+            (send -outer hide-caret #t))
+          
+          (define/public (show-props)
+            (send (send controller get-properties-controller)
+                  show #t))
+          
+          (define/private outer:insert
+            (case-lambda
+              [(obj)
+               (outer:insert obj style:normal)]
+              [(text style)
+               (outer:insert text style #f)]
+              [(text style clickback)
+               (let ([start (send -outer last-position)])
+                 (send -outer insert text)
+                 (let ([end (send -outer last-position)])
+                   (send -outer change-style style start end #f)
+                   (when clickback
+                     (send -outer set-clickback start end clickback))))]))
+          
+          ;; snip% Methods
+          (define/override (copy)
+            (new syntax-value-snip% (controller controller) (syntax stx)))
+          
+          (define/public (read-special src line col pos)
+            #;(datum->syntax-object #f
+                                    `(,#'quote-syntax ,stx)
+                                    (list src line col pos 1))
+            #`(force '#,(delay stx)))
+          ))
+      
+      (define syntax-snip%
+        (class* editor-snip% (readable-snip<%>)
+          (init-field ((stx syntax)))
+          (init-field (controller (the-syntax-controller)))
+          (inherit set-margin
+                   set-inset
+                   set-snipclass
+                   set-tight-text-fit
+                   show-border)
+          
+          (define -outer (new text%))
+          (super-new (editor -outer) (with-border? #f))
+          (set-margin 2 0 0 0)
+          (set-inset 3 0 0 0)
+          (set-snipclass snip-class)
+          (send -outer select-all)
+          (send -outer change-style (make-object style-delta% 'change-alignment 'top)
+                0
+                (send -outer last-position))
+          
+          (define the-syntax-snip
+            (new syntax-value-snip% (syntax stx) (controller controller)))
+          (define the-summary
+            (let ([line (syntax-line stx)]
+                  [col (syntax-column stx)])
+              (if (and line col)
+                  (format "#<syntax:~s:~s>" line col)
+                  "#<syntax>")))
+          
+          (define/private (hide-me)
+            (send* -outer
+              (begin-edit-sequence)
+              (lock #f)
+              (erase))
+            (set-tight-text-fit #t)
+            (show-border #f)
+            (outer:insert (show-icon) style:hyper (lambda _ (show-me)))
+            (outer:insert the-summary)
+            (send* -outer 
+              (lock #t)
+              (end-edit-sequence)))
+          
+          (define/private (show-me)
+            (send* -outer
+              (begin-edit-sequence)
+              (lock #f)
+              (erase))
+            (set-tight-text-fit #f)
+            (show-border #t)
+            (outer:insert (hide-icon) style:hyper (lambda _ (hide-me)))
+            (outer:insert " ")
+            (outer:insert the-syntax-snip)
+            (send* -outer
+              (lock #t)
+              (end-edit-sequence)))
+          
+          (define/private outer:insert
+            (case-lambda
+              [(obj)
+               (outer:insert obj style:normal)]
+              [(text style)
+               (outer:insert text style #f)]
+              [(text style clickback)
+               (let ([start (send -outer last-position)])
+                 (send -outer insert text)
+                 (let ([end (send -outer last-position)])
+                   (send -outer change-style style start end #f)
+                   (when clickback
+                     (send -outer set-clickback start end clickback))))]))
+          
+          ;; Snip methods
+          (define/override (copy)
+            (new syntax-snip% (controller controller) (syntax stx)))
+          (define/override (write stream)
+            (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax stx)))))
+          (define/public (read-special src line col pos)
+            (send the-syntax-snip read-special src line col pos))
+          
+          (hide-me)
+          (send -outer hide-caret #t)
+          (send -outer lock #t)
+          ))
+      
+      ;; independent-properties-controller%
+      (define independent-properties-controller%
+        (class* object% (syntax-properties-controller<%>)
+          (init-field controller)
+          
+          ;; Properties display
+          (define parent
+            (new frame% (label "Properties") (height (pref:height))
+                 (width (floor (* (pref:props-percentage) (pref:width))))))
+          (define pv (new properties-view% (parent parent)))
+          
+          (define/private (show-properties)
+            (unless (send parent is-shown?)
+              (send parent show #t)))
+          
+          (define/public (set-syntax stx)
+            (send pv set-syntax stx))
+          (define/public (show ?)
+            (send parent show ?))
+          (define/public (is-shown?)
+            (send parent is-shown?))
+          (super-new)))
       ))
 
-  (define syntax-snip%
+  (define snip-context-menu-extension@
-    (class* editor-snip% (readable-snip<%>)
+    (unit/sig context-menu^
-      (init-field ((stx syntax)))
+      (import (pre : context-menu^))
-      (init-field (controller (the-syntax-controller)))
-      (inherit set-margin
-               set-inset
-               set-snipclass
-               set-tight-text-fit
-               show-border)
-
-      (define -outer (new text%))
-      (super-new (editor -outer) (with-border? #f))
-      (set-margin 2 0 0 0)
-      (set-inset 3 0 0 0)
-      (set-snipclass snip-class)
-
-      (define the-syntax-snip
-        (new syntax-value-snip% (syntax stx) (controller controller)))
-      (define the-summary
-        (let ([line (syntax-line stx)]
-              [col (syntax-column stx)])
-          (if (and line col)
-              (format "#<syntax:~s:~s>" line col)
-              "#<syntax>")))
       
-      (define/private (hide-me)
+      (define context-menu%
-        (send* -outer
+        (class pre:context-menu%
-          (begin-edit-sequence)
+          (init-field snip)
-          (lock #f)
+          
-          (erase))
+          (define/override (after-selection-items)
-        (set-tight-text-fit #t)
+            (super after-selection-items)
-        (show-border #f)
+            (new menu-item% (label "Show syntax properties")
-        (outer:insert (show-icon) style:hyper (lambda _ (show-me)))
+                 (parent this)
-        (outer:insert the-summary)
+                 (callback (lambda _ (send snip show-props))))
-        (send* -outer 
+            (void))
-          (lock #t)
+          
-          (end-edit-sequence)))
+          (super-new (controller (send snip get-controller)))))))
-
+  
-      (define/private (show-me)
-        (send* -outer
-          (begin-edit-sequence)
-          (lock #f)
-          (erase))
-        (set-tight-text-fit #f)
-        (show-border #t)
-        (outer:insert (hide-icon) style:hyper (lambda _ (hide-me)))
-        (outer:insert " ")
-        (outer:insert the-syntax-snip)
-        (send* -outer
-          (lock #t)
-          (end-edit-sequence)))
-      
-      (define/private outer:insert
-        (case-lambda
-          [(obj)
-           (outer:insert obj style:normal)]
-          [(text style)
-           (outer:insert text style #f)]
-          [(text style clickback)
-           (let ([start (send -outer last-position)])
-             (send -outer insert text)
-             (let ([end (send -outer last-position)])
-               (send -outer change-style style start end #f)
-               (when clickback
-                 (send -outer set-clickback start end clickback))))]))
-      
-      ;; Snip methods
-      (define/override (copy)
-        (new syntax-snip% (controller controller) (syntax stx)))
-      (define/override (write stream)
-        (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax stx)))))
-      (define/public (read-special src line col pos)
-        (send the-syntax-snip read-special src line col pos))
-
-      (hide-me)
-      (send -outer hide-caret #t)
-      (send -outer lock #t)
-      ))
   
   (define style:normal (make-object style-delta% 'change-normal))
   (define style:hyper
@@ -243,7 +228,7 @@
     (let ([s (make-object style-delta% 'change-normal)])
       (send s set-delta 'change-bold)
       s))
-
+  
   (define (show-icon)
     (make-object image-snip%
       (build-path (collection-path "icons") "turn-up.png")))
@@ -251,22 +236,6 @@
     (make-object image-snip%
       (build-path (collection-path "icons") "turn-down.png")))
   
-  ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
-  
-  (define syntax-snipclass%
-    (class snip-class%
-      (define/override (read stream)
-        (let ([str (send stream get-bytes)])
-          (make-object syntax-snip% 
-            (unmarshall-syntax (read-from-string (bytes->string/utf-8 str))))))
-      (super-instantiate ())))
-  
-  (define snip-class (make-object syntax-snipclass%))
-  (send snip-class set-version 2)
-  (send snip-class set-classname
-        (format "~s" '(lib "syntax-snip.ss" "macro-debugger" "syntax-browser")))
-  (send (get-the-snip-class-list) add snip-class)
-  
   ;; marshall-syntax : syntax -> printable
   (define (marshall-syntax stx)
     (unless (syntax? stx)
@@ -284,7 +253,7 @@
               (syntax-property-symbol-keys stx)))
       (contents
        ,(marshall-object (syntax-e stx)))))
-
+  
   ;; marshall-object : any -> printable
   ;; really only intended for use with marshall-syntax
   (define (marshall-object obj)
@@ -294,64 +263,11 @@
        `(pair ,(cons (marshall-object (car obj))
                      (marshall-object (cdr obj))))]
       [(or (symbol? obj)
-	   (char? obj)
+           (char? obj)
-	   (number? obj)
+           (number? obj)
            (string? obj)
-	   (boolean? obj)
+           (boolean? obj)
            (null? obj))
        `(other ,obj)]
       [else (string->symbol (format "unknown-object: ~s" obj))]))
-  
+  )
-  (define (unmarshall-syntax stx)
-    (match stx
-      [`(syntax
-         (source ,src)
-         (source-module ,source-module) ;; marshalling
-         (position ,pos)
-         (line ,line)
-         (column ,col)
-         (span ,span)
-         (original? ,original?)
-         (properties ,@(properties ...))
-         (contents ,contents))
-       (foldl
-        add-properties
-        (datum->syntax-object
-         #'here ;; ack
-         (unmarshall-object contents)
-         (list (unmarshall-object src)
-               line
-               col
-               pos
-               span))
-        properties)]
-      [else #'unknown-syntax-object]))
-
-  ;; add-properties : syntax any -> syntax
-  (define (add-properties prop-spec stx)
-    (match prop-spec
-      [`(,(and sym (? symbol?))
-         ,prop)
-       (syntax-property stx sym (unmarshall-object prop))]
-      [else stx]))
-  
-  (define (unmarshall-object obj)
-    (let ([unknown (λ () (string->symbol (format "unknown: ~s" obj)))])
-      (if (and (pair? obj)
-               (symbol? (car obj)))
-          (case (car obj)
-            [(pair) 
-             (if (pair? (cdr obj))
-                 (let ([raw-obj (cadr obj)])
-                   (if (pair? raw-obj)
-                       (cons (unmarshall-object (car raw-obj))
-                             (unmarshall-object (cdr raw-obj)))
-                       (unknown)))
-                 (unknown))]
-            [(other) 
-             (if (pair? (cdr obj))
-                 (cadr obj)
-                 (unknown))]
-            [(syntax) (unmarshall-syntax obj)]
-            [else (unknown)])
-          (unknown)))))

collects/macro-debugger/syntax-browser/widget.ss

@@ -1,263 +1,216 @@
 
 (module widget mzscheme
-  (require "interfaces.ss"
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "list.ss")
+           "interfaces.ss"
+           "params.ss"
            "controller.ss"
            "typesetter.ss"
            "hrule-snip.ss"
            "properties.ss"
            "partition.ss"
-           "prefs.ss"
+           "util.ss")
-           "util.ss"
+  (provide widget@
-           (lib "list.ss")
+           widget-context-menu-extension@)
-           (lib "class.ss")
-           (lib "framework.ss" "framework")
-           (lib "mred.ss" "mred"))
-  (provide syntax-controller%
-           syntax-widget%
-           syntax-browser-frame%)
 
-  (define browser-text% (editor:standard-style-list-mixin text:basic%))
+  (define widget@
-
+    (unit/sig widget^
-  ;; syntax-widget%
+      (import keymap^
-  ;; A syntax-widget creates its own syntax-controller.
+              context-menu^)
-  (define syntax-widget%
-    (class* object% (syntax-browser<%> syntax-properties-controller<%>)
-      (init parent)
-
-      (define -main-panel (new vertical-panel% (parent parent)))
-      (define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
-      (define -text (new browser-text%))
-      (define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text)))
-      (define -props-panel (new horizontal-panel% (parent -split-panel)))
-      (define props (new properties-view% (parent -props-panel)))
-      (define -saved-panel-percentages #f)
-
-      (define controller
-        (new syntax-controller%
-             (properties-controller this)))
-
-      ;; Set up keymap
-      (let ([keymap (send -text get-keymap)])
-        (send keymap map-function "rightbutton" "popup-context-window")
-        (send keymap add-function "popup-context-window"
-              (lambda (editor event)
-                (do-popup-context-window editor event)))
-        )
-
-      ;; FIXME: Why doesn't this work?
-      #;
-      (when (current-syntax-font-size)
-        (let* ([style-list (send -text get-style-list)]
-               [standard (send style-list find-named-style "Standard")])
-          (send style-list replace-named-style "Standard"
-                (send style-list find-or-create-style
-                      standard
-                      (make-object style-delta% 'change-size
-                                   (current-syntax-font-size))))))
-
-      (send -text lock #t)
-      (send -split-panel set-percentages 
-            (let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
-      (toggle-props)
-
-      (define/private (do-popup-context-window editor event)
-        (define-values (x y)
-          (send editor dc-location-to-editor-location
-                (send event get-x)
-                (send event get-y)))
-        (define admin (send editor get-admin))
-        (send admin popup-menu context-menu x y))
       
-      (define context-menu
+      ;; syntax-widget%
-        (let ([context-menu (new popup-menu%)])
+      ;; A syntax-widget creates its own syntax-controller.
-          (new menu-item% (label "Copy") (parent context-menu)
+      (define syntax-widget%
-               (callback (lambda (i e)
+        (class* object% (syntax-browser<%> syntax-properties-controller<%>)
-                           (define stx (send controller get-selected-syntax))
+          (init parent)
-                           (send the-clipboard set-clipboard-string
+          (init-field pref:props-percentage)
-                                 (if stx 
-                                     (format "~s" (syntax-object->datum stx))
-                                     "")
-                                 (send e get-time-stamp)))))
-          ;; FIXME: Add option for "formatted" copy/paste?
           
-          (new menu-item%
+          (define -main-panel (new vertical-panel% (parent parent)))
-               (label "Clear selection")
+          (define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
-               (parent context-menu)
+          (define -text (new browser-text%))
-               (callback (lambda _ (send controller select-syntax #f))))
+          (define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text)))
-
+          (define -props-panel (new horizontal-panel% (parent -split-panel)))
-          (new separator-menu-item% (parent context-menu))
+          (define props (new properties-view% (parent -props-panel)))
+          (define props-percentage (pref:props-percentage))
           
-          ;; properties
+          (define controller
-          (new menu-item% 
+            (new syntax-controller%
-               (label "Show/hide syntax properties")
+                 (properties-controller this)))
-               (parent context-menu)
+          
+          (new syntax-keymap% 
+               (editor -text)
+               (context-menu (new context-menu% (widget this))))
+          
+          ;; FIXME: Why doesn't this work?
+          #;
+          (when (current-syntax-font-size)
+            (let* ([style-list (send -text get-style-list)]
+                   [standard (send style-list find-named-style "Standard")])
+              (send style-list replace-named-style "Standard"
+                    (send style-list find-or-create-style
+                          standard
+                          (make-object style-delta% 'change-size
+                            (current-syntax-font-size))))))
+          
+          (send -text lock #t)
+          (send -split-panel set-percentages 
+                (list (- 1 props-percentage) props-percentage))
+          (toggle-props)
+          
+          ;; syntax-properties-controller<%> methods
+          
+          (define/public (set-syntax stx)
+            (send props set-syntax stx))
+          
+          (define/public (show ?)
+            (if ? (show-props) (hide-props)))
+          
+          (define/public (is-shown?)
+            (send -props-panel is-shown?))
+          
+          (define/public (toggle-props)
+            (if (send -props-panel is-shown?)
+                (hide-props)
+                (show-props)))
+          
+          (define/public (hide-props)
+            (when (send -props-panel is-shown?)
+              (set! props-percentage (cadr (send -split-panel get-percentages)))
+              (send -split-panel delete-child -props-panel)
+              (send -props-panel show #f)))
+          
+          (define/public (show-props)
+            (unless (send -props-panel is-shown?)
+              (send -split-panel add-child -props-panel)
+              (send -split-panel set-percentages
+                    (list (- 1 props-percentage) props-percentage))
+              (send -props-panel show #t)))
+          
+          ;;
+          
+          (define/public (get-controller) controller)
+          
+          ;;
+          
+          (define/public (get-main-panel) -main-panel)
+          
+          (define/public (save-prefs)
+            (unless (= props-percentage (pref:props-percentage))
+              (pref:props-percentage props-percentage)))
+          
+          ;; syntax-browser<%> Methods
+          
+          (define/public (add-text text)
+            (with-unlock -text
+              (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)]))
+          
+          (define/public (add-separator)
+            (with-unlock -text
+              (send* -text
+                (insert (new hrule-snip%))
+                (insert "\n"))))
+          
+          (define/public (erase-all)
+            (with-unlock -text (send -text erase))
+            (send controller erase))
+          
+          (define/public (select-syntax stx)
+            (send controller select-syntax stx))
+          
+          (define/public (get-text) -text)
+          
+          (define/private (internal-add-syntax stx hi-stxs hi-color)
+            (with-unlock -text
+              (parameterize ((current-default-columns (calculate-columns)))
+                (let ([current-position (send -text last-position)])
+                  (let* ([new-ts (new typesetter-for-text%
+                                      (controller controller)
+                                      (syntax stx)
+                                      (text -text))]
+                         [new-colorer (send new-ts get-colorer)])
+                    (send* -text
+                      (insert "\n")
+                      (scroll-to-position current-position))
+                    (unless (null? hi-stxs)
+                      (send new-colorer highlight-syntaxes hi-stxs hi-color)))))))
+          
+          (define/private (calculate-columns)
+            (define style (code-style -text))
+            (define char-width (send style get-text-width (send -ecanvas get-dc)))
+            (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
+            (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
+          
+          (super-new)))
+      
+      ;; syntax-widget/controls%
+      (define syntax-widget/controls%
+        (class* syntax-widget% ()
+          (inherit get-main-panel
+                   get-controller
+                   toggle-props)
+          (super-new)
+          
+          (define -control-panel 
+            (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
+          
+          ;; Put the control panel up front
+          (send (get-main-panel) change-children
+                (lambda (children)
+                  (cons -control-panel (remq -control-panel children))))
+          
+          (define -identifier=-choices (identifier=-choices))
+          (define -choice
+            (new choice% (label "identifer=?") (parent -control-panel)
+                 (choices (map car -identifier=-choices))
+                 (callback (lambda _ (on-update-identifier=?-choice)))))
+          (new button% 
+               (label "Clear")
+               (parent -control-panel)
+               (callback (lambda _ (send (get-controller) select-syntax #f))))
+          (new button%
+               (label "Properties")
+               (parent -control-panel)
                (callback (lambda _ (toggle-props))))
           
-          ;; primary selection
+          (define/private (on-update-identifier=?-choice)
-          (let ([secondary (new menu% (label "identifier=?") (parent context-menu))])
+            (cond [(assoc (send -choice get-string-selection)
-            (for-each
+                          -identifier=-choices)
-             (lambda (name func)
+                   => (lambda (p)
-               (let ([this-choice
+                        (send (get-controller)
-                      (new checkable-menu-item%
+                              on-update-identifier=? (car p) (cdr p)))]
-                           (label name)
+                  [else #f]))
-                           (parent secondary)
+          (send (get-controller) add-identifier=?-listener
-                           (callback 
+                (lambda (name func)
-                            (lambda (i e)
+                  (send -choice set-selection
-                              (send controller on-update-identifier=? name func))))])
+                        (or (send -choice find-string name) 0))))))
-                 (send controller add-identifier=?-listener
-                       (lambda (new-name new-id=?) 
-                         (send this-choice check (eq? name new-name))))))
-             (map car (identifier=-choices))
-             (map cdr (identifier=-choices))))
-          context-menu))
-      
-      ;; syntax-properties-controller<%> methods
-
-      (define/public (set-syntax stx)
-        (send props set-syntax stx))
-
-      (define/public (show ?)
-        (if ? (show-props) (hide-props)))
-
-      (define/public (is-shown?)
-        (send -props-panel is-shown?))
-
-      (define/public (toggle-props)
-        (if (send -props-panel is-shown?)
-            (hide-props)
-            (show-props)))
-
-      (define/public (hide-props)
-        (when (send -props-panel is-shown?)
-          (set! -saved-panel-percentages (send -split-panel get-percentages))
-          (send -split-panel delete-child -props-panel)
-          (send -props-panel show #f)))
-
-      (define/public (show-props)
-        (unless (send -props-panel is-shown?)
-          (send -split-panel add-child -props-panel)
-          (send -split-panel set-percentages -saved-panel-percentages)
-          (send -props-panel show #t)))
-
-      ;;
-
-      (define/public (get-controller) controller)
-
-      ;;
-
-      (define/public (get-main-panel) -main-panel)
-
-      (define/public (on-close)
-        (unless (= (cadr -saved-panel-percentages) (pref:props-percentage))
-          (pref:props-percentage (cadr -saved-panel-percentages))))
-
-      ;; syntax-browser<%> Methods
-
-      (define/public (add-text text)
-        (with-unlock -text
-          (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)]))
-
-      (define/public (add-separator)
-        (with-unlock -text
-          (send* -text
-            (insert (new hrule-snip%))
-            (insert "\n"))))
-
-      (define/public (erase-all)
-        (with-unlock -text (send -text erase))
-        (send controller erase))
-
-      (define/public (select-syntax stx)
-        (send controller select-syntax stx))
-
-      (define/public (get-text) -text)
-
-      (define/private (internal-add-syntax stx hi-stxs hi-color)
-        (with-unlock -text
-          (parameterize ((current-default-columns (calculate-columns)))
-            (let ([current-position (send -text last-position)])
-              (let* ([new-ts (new typesetter-for-text%
-                                  (controller controller)
-                                  (syntax stx)
-                                  (text -text))]
-                     [new-colorer (send new-ts get-colorer)])
-                (send* -text
-                  (insert "\n")
-                  (scroll-to-position current-position))
-                (unless (null? hi-stxs)
-                  (send new-colorer highlight-syntaxes hi-stxs hi-color)))))))
-
-      (define/private (calculate-columns)
-        (define style (code-style -text))
-        (define char-width (send style get-text-width (send -ecanvas get-dc)))
-        (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
-        (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
-
-      (super-new)))
-
-  ;; syntax-widget/controls%
-  (define syntax-widget/controls%
-    (class* syntax-widget% ()
-      (inherit get-main-panel
-               get-controller
-               toggle-props)
-
-      (super-new)
-
-      (define -control-panel 
-        (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
-
-      ;; Put the control panel up front
-      (send (get-main-panel) change-children
-            (lambda (children)
-              (cons -control-panel (remq -control-panel children))))
-
-      (define -identifier=-choices (identifier=-choices))
-      (define -choice
-        (new choice% (label "identifer=?") (parent -control-panel)
-             (choices (map car -identifier=-choices))
-             (callback (lambda _ (on-update-identifier=?-choice)))))
-      (new button% 
-           (label "Clear")
-           (parent -control-panel)
-           (callback (lambda _ (send (get-controller) select-syntax #f))))
-      (new button%
-           (label "Properties")
-           (parent -control-panel)
-           (callback (lambda _ (toggle-props))))
-
-      (define/private (on-update-identifier=?-choice)
-        (cond [(assoc (send -choice get-string-selection)
-                      -identifier=-choices)
-               => (lambda (p)
-                    (send (get-controller)
-                          on-update-identifier=? (car p) (cdr p)))]
-              [else #f]))
-      (send (get-controller) add-identifier=?-listener
-            (lambda (name func)
-              (send -choice set-selection
-                    (or (send -choice find-string name) 0))))))
-
-  ;; syntax-browser-frame%
-  (define syntax-browser-frame%
-    (class* frame% ()
-      (super-new (label "Syntax Browser")
-                 (width (pref:width))
-                 (height (pref:height)))
-      (define widget (new syntax-widget/controls% (parent this)))
-      (define/public (get-widget) widget)
-      (define/augment (on-close)
-        (pref:width (send this get-width))
-        (pref:height (send this get-height))
-        (send widget on-close)
-        (preferences:save)
-        (inner (void) on-close))
       ))
+
+  (define widget-context-menu-extension@
+    (unit/sig context-menu^
+      (import (pre : context-menu^))
+      
+      (define context-menu%
+        (class pre:context-menu%
+          (init-field widget)
+          
+          (define/override (after-selection-items)
+            (super after-selection-items)
+            (new menu-item% (label "Show/hide syntax properties")
+                 (parent this)
+                 (callback (lambda _ (send widget toggle-props))))
+            (void))
+          
+          (super-new (controller (send widget get-controller)))))))
+
+  (define browser-text% (editor:standard-style-list-mixin text:basic%))
   )

collects/macro-debugger/view/prefs.ss

@@ -0,0 +1,5 @@
+
+(module prefs mzscheme
+  (require (lib "framework.ss" "framework"))
+  
+  '...)

collects/macro-debugger/view/view.ss

@@ -1,13 +1,16 @@
 
 (module view mzscheme
-  (require (lib "unitsig.ss"))
+  (require (lib "unitsig.ss")
-  (require "gui.ss")
+           (prefix sb: "../syntax-browser/embed.ss")
+           "gui.ss")
   (provide (all-defined))
 
   (define-values/invoke-unit/sig view^
     (compound-unit/sig
       (import)
-      (link (BASE : view-base^ (view-base@))
+      (link (PREFS : sb:prefs^ (sb:global-prefs@))
-            (VIEW : view^ (view@ BASE)))
+            (SB   : sb:implementation^ (sb:implementation@))
+            (BASE : view-base^ (view-base@))
+            (VIEW : view^ (view@ BASE PREFS SB)))
       (export (open VIEW))))
-  )
+  )