Fixed location bug with popup menu

Improved syntax snips

svn: r4492

collects/macro-debugger/syntax-browser.ss

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

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

@@ -4,7 +4,7 @@
   (provide (all-defined))
 
   (define current-syntax-font-size (make-parameter #f #;16))
-  (define current-default-columns (make-parameter 40))
+  (define current-default-columns (make-parameter 60))
 
   (define-syntax pref:get/set
     (syntax-rules ()

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

@@ -16,28 +16,14 @@
 
       ;; Properties display
       (define parent
-        (new frame% (label "Properties and Configuration") (height (pref:height))
+        (new frame% (label "Properties") (height (pref:height))
              (width (floor (* (pref:props-percentage) (pref:width))))))
-      (define choice (new choice% (label "identifer=?") (parent parent)
-                          (choices (map car (identifier=-choices)))
-                          (callback (lambda _ (on-update-identifier=?-choice)))))
-      (new message% (label " ") (parent parent))
       (define pv (new properties-view% (parent parent)))
 
       (define/private (show-properties)
         (unless (send parent is-shown?)
           (send parent show #t)))
 
-      (define/private (on-update-identifier=?-choice)
-        (let ([id=? (get-identifier=?)])
-          (send controller on-update-identifier=? id=?)))
-      
-      (define/private (get-identifier=?)
-        (cond [(assoc (send choice get-string-selection) 
-                      (identifier=-choices))
-               => cdr]
-              [else #f]))
-
       (define/public (set-syntax stx)
         (send pv set-syntax stx))
       (define/public (show ?)

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

@@ -1,17 +1,12 @@
 
 (module syntax-browser mzscheme
   (require (lib "class.ss")
-           (lib "mred.ss" "mred")
-           (lib "framework.ss" "framework")
            "interfaces.ss"
-           "prefs.ss"
-           "syntax-snip.ss"
            "widget.ss")
   (provide browse-syntax
            browse-syntaxes
            syntax-browser<%>
-           make-syntax-browser
+           make-syntax-browser)
-           syntax-snip)
   
   ;; browse-syntax : syntax -> void
   (define (browse-syntax stx)
@@ -31,22 +26,4 @@
       (send view show #t)
       (send view get-widget)))
   
-  ;; syntax-snip : syntax -> snip
-  (define (syntax-snip stx)
-    (new super-syntax-snip% (syntax stx)))
-  
-;  ;; syntaxes-snip : syntaxes -> snip
-;  (define (syntaxes-snip stxs)
-;    (let* ([controller (new syntax-controller%)]
-;           [view (new syntax-snip% (controller controller))])
-;      (let loop ([stxs stxs])
-;        (cond [(null? stxs) (void)]
-;              [(null? (cdr stxs))
-;               (send controller add-syntax (car stxs))]
-;              [else
-;               (send controller add-syntax (car stxs))
-;               #;(send controller add-separator)
-;               (loop (cdr stxs))]))
-;      view))
-  
   )

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

@@ -1,15 +1,24 @@
 
 (module syntax-snip mzscheme
   (require (lib "class.ss")
+           (lib "match.ss")
+           (lib "list.ss")
            (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "string.ss")
            "interfaces.ss"
-           "prefs.ss"
+           "partition.ss"
-           "properties.ss"
            "typesetter.ss"
            "widget.ss"
-           "partition.ss")
+           "syntax-browser.ss")
-  (provide syntax-snip%
+  (provide syntax-snip
-           super-syntax-snip%)
+           snip-class
+           syntax-value-snip%
+           syntax-snip%)
+
+  ;; syntax-snip : syntax -> snip
+  (define (syntax-snip stx)
+    (new syntax-snip% (syntax stx)))
 
   (define current-syntax-controller (make-parameter #f))
 
@@ -20,39 +29,34 @@
             (current-syntax-controller controller)
             controller))))
 
-
+  ;; syntax-value-snip%
-  ;; syntax-snip%
+  (define syntax-value-snip%
-  (define syntax-snip%
+    (class* editor-snip% (readable-snip<%>)
-    (class* editor-snip% ()
       (init-field ((stx syntax)))
       (init-field controller)
+      (inherit set-margin
+               set-inset)
 
-      (define -outer (new text%))
+      (define -outer (new text:standard-style-list%))
-      (super-new (editor -outer))
+      (super-new (editor -outer) (with-border? #f))
+      (set-margin 0 0 0 0)
+      (set-inset 2 2 2 2)
+      (refresh)
 
-      ;; Initialization
+      (define/private (refresh)
-      (send -outer begin-edit-sequence)
+        (send -outer begin-edit-sequence)
-      (initialize -outer)
+        (send -outer erase)
-      (outer:insert "Syntax browser" style:bold)
+        (new typesetter-for-text%
-      (outer:insert "  ")
+             (syntax stx)
-      (outer:insert "Clear" style:hyper
+             (controller controller)
-                    (lambda (x y z) (send controller select-syntax #f)))
+             (text -outer))
-      (outer:insert "  ")
+        (send -outer lock #t)
-      (outer:insert "Properties" style:hyper
+        (send -outer end-edit-sequence)
-                    (lambda (x y z)
+        (send -outer hide-caret #t))
-                      (send (send controller get-properties-controller)
-                            show #t)))
-      (outer:insert "\n")
-      (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 (initialize outer)
+      (define/private (show-props)
-        (void))
+        (send (send controller get-properties-controller)
+              show #t))
       
       (define/private outer:insert
         (case-lambda
@@ -68,19 +72,166 @@
                (when clickback
                  (send -outer set-clickback start end clickback))))]))
       
-      ;; snip% Methods
+      ;; 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-snip% (controller controller) (syntax stx)))
+        (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)))
 
       ))
 
-  (define subservient-syntax-snip%
+  (define syntax-snip%
-    (class syntax-snip%
+    (class* editor-snip% (readable-snip<%>)
-      (init-field f)
+      (init-field ((stx syntax)))
-      (define/override (initialize outer)
+      (init-field (controller (the-syntax-controller)))
-        (f outer))
+      (inherit set-margin
-      (super-new)))
+               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)
+        (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)
+      ))
   
   (define style:normal (make-object style-delta% 'change-normal))
   (define style:hyper
@@ -93,62 +244,114 @@
       (send s set-delta 'change-bold)
       s))
 
-  (define (show-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-up.png")))
+  (define (show-icon)
-  (define (hide-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-down.png")))
+    (make-object image-snip%
+      (build-path (collection-path "icons") "turn-up.png")))
+  (define (hide-icon)
+    (make-object image-snip%
+      (build-path (collection-path "icons") "turn-down.png")))
   
-  (define super-syntax-snip%
+  ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
-    (class* editor-snip% ()
-      (init-field ((stx syntax)))
-      (init-field (controller (the-syntax-controller)))
-      
-      (define -outer (new text%))
-      (super-new (editor -outer) (with-border? #f))
-
-      (define/private (hide-me)
-        (send* -outer
-          (lock #f)
-          (erase))
-        (outer:insert (show-icon) style:hyper (lambda _ (show-me)))
-        (outer:insert "#<syntax>")
-        (send -outer lock #t))
-      
-      (define/private (show-me)
-        (send* -outer
-          (lock #f)
-          (erase))
-        (outer:insert (new subservient-syntax-snip%
-                           (syntax stx)
-                           (controller controller)
-                           (f (lambda (t)
-                                (let* ([start (send t last-position)]
-                                       [_ (send t insert (hide-icon))]
-                                       [end (send t last-position)])
-                                  (send t insert " ")
-                                  (send t change-style style:hyper start end #f)
-                                  (send t set-clickback start end (lambda _ (hide-me))))))))
-        (send* -outer
-          (lock #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))))]))
-      
-      (define/override (copy)
-        (new super-syntax-snip% (controller controller) (syntax stx)))
-
-      (hide-me)
-      (send -outer hide-caret #t)
-      (send -outer lock #t)
-      ))
   
-  )
+  (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)
+      (error 'marshall-syntax "not syntax: ~s\n" stx))
+    `(syntax
+      (source ,(marshall-object (syntax-source stx)))
+      (source-module ,(marshall-object (syntax-source-module stx)))
+      (position ,(syntax-position stx))
+      (line ,(syntax-line stx))
+      (column ,(syntax-column stx))
+      (span ,(syntax-span stx))
+      (original? ,(syntax-original? stx))
+      (properties 
+       ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
+              (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)
+    (cond
+      [(syntax? obj) (marshall-syntax obj)]
+      [(pair? obj) 
+       `(pair ,(cons (marshall-object (car obj))
+                     (marshall-object (cdr obj))))]
+      [(or (symbol? obj)
+	   (char? obj)
+	   (number? obj)
+           (string? 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

@@ -61,8 +61,10 @@
       (toggle-props)
 
       (define/private (do-popup-context-window editor event)
-        (define x (send event get-x))
+        (define-values (x y)
-        (define y (send event get-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))