Reorganized syntax-browser

svn: r4500

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/browser.ss

@@ -0,0 +1,19 @@
+
+(module browser mzscheme
+  (require (lib "unitsig.ss")
+           "interfaces.ss"
+           "frame.ss"
+           "implementation.ss")
+  (provide-signature-elements browser^)
+  (provide-signature-elements snip^)
+  
+  (define browser@
+    (compound-unit/sig 
+      (import)
+      (link [PREFS : prefs^          (global-prefs@)]
+            [IMPL  : implementation^ (implementation@)]
+            [FRAME : browser^        (frame@ PREFS (IMPL widget))])
+      (export (open FRAME))))
+  
+  (define-values/invoke-unit/sig browser^ browser@)
+  )

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/implementation.ss

@@ -0,0 +1,64 @@
+
+(module implementation mzscheme
+  (require (lib "unitsig.ss")
+           "interfaces.ss"
+           "widget.ss"
+           "syntax-snip.ss"
+           "snipclass.ss"
+           "keymap.ss"
+           "prefs.ss")
+  (provide global-prefs@
+           global-snip@
+           implementation@)
+  (provide-signature-elements snip^)
+  (provide-signature-elements snipclass^)
+
+  ;; prefs@ and snip@ should only be invoked once
+  ;; We create a new unit/sig out of their invocation
+
+  (define snip-implementation@
+    (compound-unit/sig 
+      (import)
+      (link [PREFS      : prefs^ (prefs@)]
+            [KEYMAP     : keymap^ (keymap@)]
+            [MENU       : context-menu^ (context-menu@ SNIP)]
+            [SNIP-CLASS : snipclass^ (snipclass@ SNIP)]
+            [SNIP-MENU  : context-menu^ (snip-context-menu-extension@ MENU)]
+            [SNIP       : snip^ (snip@ PREFS KEYMAP SNIP-MENU SNIP-CLASS)])
+      (export (open PREFS) (open SNIP) (open SNIP-CLASS))))
+  (define-values/invoke-unit/sig ((open snip^) (open prefs^) (open snipclass^))
+    snip-implementation@)
+  
+  (define global-prefs@
+    (unit/sig prefs^
+      (import)
+      (rename (-width pref:width)
+              (-height pref:height)
+              (-props-percentage pref:props-percentage))
+      (define -width pref:width)
+      (define -height pref:height)
+      (define -props-percentage pref:props-percentage)))
+  
+  (define global-snip@
+    (unit/sig snip^
+      (import)
+      (rename (-syntax-snip syntax-snip)
+              (-syntax-snip% syntax-snip%))
+      (define -syntax-snip syntax-snip)
+      (define -syntax-snip% syntax-snip%)))
+
+  ;; Everyone else re-uses the global-snip@ unit
+  
+  ;; implementation@ : prefs^ -> implementation^
+  (define implementation@
+    (compound-unit/sig
+      (import)
+      (link [KEYMAP        : keymap^       (keymap@)]
+            [MENU          : context-menu^ (context-menu@ SNIP)]
+            [SNIP          : snip^         (global-snip@)]
+            [WIDGET-MENU   : context-menu^ (widget-context-menu-extension@ MENU)]
+            [WIDGET        : widget^       (widget@ KEYMAP WIDGET-MENU)])
+      (export (unit SNIP snip)
+              (unit WIDGET widget))))
+
+  )

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/params.ss

@@ -0,0 +1,13 @@
+
+(module params mzscheme
+  (provide current-syntax-font-size
+           current-default-columns)
+
+  ;; current-syntax-font-size : parameter of number/#f
+  ;; When non-false, overrides the default font size
+  (define current-syntax-font-size (make-parameter #f))
+  
+  ;; current-default-columns : parameter of number
+  (define current-default-columns (make-parameter 60))
+
+  )

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

@@ -1,10 +1,9 @@
 
 (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 ()
@@ -14,6 +13,10 @@
            [() (preferences:get 'prop)]
            [(newval) (preferences:set 'prop newval)]))]))
 
+  (define prefs@
+    (unit/sig prefs^
+      (import)
+      
       (preferences:set-default 'SyntaxBrowser:Width 700 number?)
       (preferences:set-default 'SyntaxBrowser:Height 600 number?)
       (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
@@ -22,6 +25,6 @@
       (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)
+      (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/snipclass.ss

@@ -0,0 +1,84 @@
+
+(module snipclass mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "match.ss")
+           (lib "string.ss")
+           (lib "list.ss")
+           "interfaces.ss")
+  (provide snipclass@)
+  
+  (define snipclass@
+    (unit/sig snipclass^
+      (import snip^)
+      ;; 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 "implementation.ss" "macro-debugger" "syntax-browser")))
+      (send (get-the-snip-class-list) add snip-class)
+      ))
+  
+  (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/syntax-browser.ss

@@ -1,29 +1,3 @@
 
 (module syntax-browser mzscheme
-  (require (lib "class.ss")
-           "interfaces.ss"
-           "widget.ss")
-  (provide browse-syntax
-           browse-syntaxes
-           syntax-browser<%>
-           make-syntax-browser)
-  
-  ;; 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)))
-  
   )

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

@@ -1,32 +1,36 @@
 
 (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^
+              keymap^
+              context-menu^
+              snipclass^)
       
       ;; syntax-snip : syntax -> snip
       (define (syntax-snip stx)
         (new syntax-snip% (syntax stx)))
       
-  (define current-syntax-controller (make-parameter #f))
+      (define *syntax-controller* #f)
       
       (define (the-syntax-controller)
-    (let ([controller (current-syntax-controller)])
+        (let ([controller *syntax-controller*])
           (or controller
-          (let ([controller (new syntax-controller%)])
+              (let* ([controller (new syntax-controller%)]
-            (current-syntax-controller controller)
+                     [props (new independent-properties-controller% (controller controller))])
+                (send controller set-properties-controller props)
+                (set! *syntax-controller* controller)
                 controller))))
       
       ;; syntax-value-snip%
@@ -41,8 +45,14 @@
           (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)
@@ -54,7 +64,7 @@
             (send -outer end-edit-sequence)
             (send -outer hide-caret #t))
           
-      (define/private (show-props)
+          (define/public (show-props)
             (send (send controller get-properties-controller)
                   show #t))
           
@@ -72,86 +82,15 @@
                    (when clickback
                      (send -outer set-clickback start end clickback))))]))
           
-      ;; BEGIN COPIED from widget.ss
-      ;; 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/override (copy)
             (new syntax-value-snip% (controller controller) (syntax stx)))
           
           (define/public (read-special src line col pos)
-        (datum->syntax-object #f
+            #;(datum->syntax-object #f
                                     `(,#'quote-syntax ,stx)
-                              (list src line col pos 1)))
+                                    (list src line col pos 1))
-
+            #`(force '#,(delay stx)))
           ))
       
       (define syntax-snip%
@@ -169,6 +108,10 @@
           (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)))
@@ -233,6 +176,48 @@
           (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 snip-context-menu-extension@
+    (unit/sig context-menu^
+      (import (pre : context-menu^))
+      
+      (define context-menu%
+        (class pre:context-menu%
+          (init-field snip)
+          
+          (define/override (after-selection-items)
+            (super after-selection-items)
+            (new menu-item% (label "Show syntax properties")
+                 (parent this)
+                 (callback (lambda _ (send snip show-props))))
+            (void))
+          
+          (super-new (controller (send snip get-controller)))))))
+  
+  
   (define style:normal (make-object style-delta% 'change-normal))
   (define style:hyper
     (let ([s (make-object style-delta% 'change-normal)])
@@ -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)
@@ -301,57 +270,4 @@
            (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/typesetter.ss

@@ -2,7 +2,7 @@
 (module typesetter mzscheme
   (require (lib "class.ss")
            (lib "mred.ss" "mred")
-           "prefs.ss"
+           "params.ss"
            "pretty-range.ss"
            "pretty-printer.ss"
            "color.ss"

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

@@ -1,28 +1,32 @@
 
 (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^
+      (import keymap^
+              context-menu^)
       
       ;; syntax-widget%
       ;; A syntax-widget creates its own syntax-controller.
       (define syntax-widget%
         (class* object% (syntax-browser<%> syntax-properties-controller<%>)
           (init parent)
+          (init-field pref:props-percentage)
           
           (define -main-panel (new vertical-panel% (parent parent)))
           (define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
@@ -30,19 +34,15 @@
           (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 props-percentage (pref:props-percentage))
           
           (define controller
             (new syntax-controller%
                  (properties-controller this)))
           
-      ;; Set up keymap
+          (new syntax-keymap% 
-      (let ([keymap (send -text get-keymap)])
+               (editor -text)
-        (send keymap map-function "rightbutton" "popup-context-window")
+               (context-menu (new context-menu% (widget this))))
-        (send keymap add-function "popup-context-window"
-              (lambda (editor event)
-                (do-popup-context-window editor event)))
-        )
           
           ;; FIXME: Why doesn't this work?
           #;
@@ -57,60 +57,9 @@
           
           (send -text lock #t)
           (send -split-panel set-percentages 
-            (let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
+                (list (- 1 props-percentage) props-percentage))
           (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
-        (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)))))
-          ;; 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
-          (new menu-item% 
-               (label "Show/hide syntax properties")
-               (parent context-menu)
-               (callback (lambda _ (toggle-props))))
-          
-          ;; 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))
-      
           ;; syntax-properties-controller<%> methods
           
           (define/public (set-syntax stx)
@@ -129,14 +78,15 @@
           
           (define/public (hide-props)
             (when (send -props-panel is-shown?)
-          (set! -saved-panel-percentages (send -split-panel get-percentages))
+              (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 -saved-panel-percentages)
+              (send -split-panel set-percentages
+                    (list (- 1 props-percentage) props-percentage))
               (send -props-panel show #t)))
           
           ;;
@@ -147,9 +97,9 @@
           
           (define/public (get-main-panel) -main-panel)
           
-      (define/public (on-close)
+          (define/public (save-prefs)
-        (unless (= (cadr -saved-panel-percentages) (pref:props-percentage))
+            (unless (= props-percentage (pref:props-percentage))
-          (pref:props-percentage (cadr -saved-panel-percentages))))
+              (pref:props-percentage props-percentage)))
           
           ;; syntax-browser<%> Methods
           
@@ -208,7 +158,6 @@
           (inherit get-main-panel
                    get-controller
                    toggle-props)
-
           (super-new)
           
           (define -control-panel 
@@ -244,20 +193,24 @@
                 (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/tool.ss

@@ -1,9 +1,5 @@
 
 (module tool mzscheme
-  (require "model/trace.ss"
-           "model/hiding-policies.ss"
-           (prefix view: "view/gui.ss")
-           (prefix prefs: "syntax-browser/prefs.ss"))
   (require (lib "class.ss")
            (lib "list.ss")
            (lib "unitsig.ss")
@@ -11,7 +7,11 @@
            (lib "framework.ss" "framework")
            (lib "tool.ss" "drscheme")
            (lib "bitmap-label.ss" "mrlib")
-           (lib "string-constant.ss" "string-constants"))
+           (lib "string-constant.ss" "string-constants")
+           "model/trace.ss"
+           "model/hiding-policies.ss"
+           (prefix view: "view/gui.ss")
+           (prefix sb: "syntax-browser/embed.ss"))
 
   (define view-base/tool@
     (unit/sig view:view-base^
@@ -22,8 +22,10 @@
   (define-values/invoke-unit/sig view:view^
     (compound-unit/sig
       (import)
-      (link (BASE : view:view-base^ (view-base/tool@))
+      (link (PREFS : sb:prefs^ (sb:global-prefs@))
-            (VIEW : view:view^ (view:view@ BASE)))
+            (SB   : sb:implementation^ (sb:implementation@))
+            (BASE : view:view-base^ (view-base/tool@))
+            (VIEW : view:view^ (view:view@ BASE PREFS SB)))
       (export (open VIEW))))
 
   (provide tool@)

collects/macro-debugger/view/gui.ss

@@ -6,10 +6,7 @@
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
            (lib "boundmap.ss" "syntax")
-           (prefix sb: "../syntax-browser/syntax-browser.ss")
+           (prefix sb: "../syntax-browser/embed.ss")
-           (prefix sb: "../syntax-browser/widget.ss")
-           (prefix sb: "../syntax-browser/prefs.ss")
-           (prefix sb: "../syntax-browser/partition.ss")
            "../syntax-browser/util.ss"
            "../model/deriv.ss"
            "../model/deriv-util.ss"
@@ -38,7 +35,6 @@
   (define-signature view-base^
     (base-frame%))
 
-
   ;; Configuration
 
   (define catch-errors? (make-parameter #f))
@@ -55,7 +51,9 @@
 
   (define view@
     (unit/sig view^
-        (import view-base^)
+      (import view-base^
+              (sb : sb:prefs^)
+              (sb : sb:implementation^))
       
       (define macro-stepper-frame%
         (class base-frame%
@@ -63,8 +61,8 @@
                 macro-hiding?)
           (init (show-hiding-panel? #t)
                 (identifier=? "<nothing>")
-                (width (sb:pref:width))
+                (width 700 #;(sb:pref:width))
-                (height (sb:pref:height)))
+                (height 500 #;(sb:pref:height)))
           (inherit get-menu%
                    get-menu-item%
                    get-menu-bar
@@ -215,7 +213,9 @@
                  (stretchable-height #f)
                  (alignment '(center center))))
 
-          (define sbview (new sb:syntax-widget% (parent area)))
+          (define sbview (new sb:widget:syntax-widget% 
+                              (parent area)
+                              (pref:props-percentage sb:pref:props-percentage)))
           (define sbc (send sbview get-controller))
           (define control-pane
             (new vertical-panel% (parent area) (stretchable-height #f)))

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