Macro stepper:

syntax snips display properties inline
  changed read-special to use procedures instead of promises

svn: r5534

original commit: 8ac1fe54e1ec645b50f31f05c6400435924cbd8b

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

@@ -4,67 +4,145 @@
            "util.ss"
            (lib "class.ss")
            (lib "mred.ss" "mred"))
-  (provide properties-view%)
+  (provide properties-view%
+           properties-snip%)
 
-  ;; properties-view%
+  ;; properties-view-base-mixin
-  (define properties-view%
+  (define properties-view-base-mixin
-    (class* object% ()
+    (mixin () ()
-      (init parent)
+      (init)
-      (define selected-syntax #f)
 
-      (define tab-choices (get-tab-choices))
+      ;; selected-syntax : syntax
-      (define tab-panel (new tab-panel% 
+      (field (selected-syntax #f))
-                             (choices (map car tab-choices))
-                             (parent parent)
-                             (callback (lambda _ (refresh)))))
-      
-      (define text (new text%))
-      (send text set-styles-sticky #f)
-      (define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))
 
+      ;; set-syntax : syntax -> void
       (define/public (set-syntax stx)
         (set! selected-syntax stx)
         (refresh))
 
-      ;; get-tab-choices : (listof (cons string thunk))
+      ;; mode : maybe symbol in '(term stxobj)
-      ;; Override to add or remove panels
+      (define mode 'term)
-      (define/public (get-tab-choices)
-        (list (cons "Term" (lambda () (display-meaning-info)))
-              (cons "Syntax Object" (lambda () (display-stxobj-info)))))
 
-      (define/private (refresh)
+      ;; get-mode : -> symbol
+      (define/public (get-mode) mode)
+
+      ;; set-mode : symbol -> void
+      (define/public (set-mode m)
+        (set! mode m)
+        (refresh))
+
+      ;; refresh : -> void
+      (define/public (refresh)
         (send* text
           (lock #f)
           (begin-edit-sequence)
           (erase))
         (when (syntax? selected-syntax)
-          (let ([tab (send tab-panel get-item-label (send tab-panel get-selection))])
+          (refresh/mode mode))
-            (cond [(assoc tab tab-choices) => (lambda (p) ((cdr p)))]
-                  [else (error 'properties-view%:refresh "internal error: no such tab: ~s" tab)])))
         (send* text
           (end-edit-sequence)
           (lock #t)
           (scroll-to-position 0)))
 
-      (define/pubment (display-meaning-info)
+      ;; refresh/mode : symbol -> void
-        (when (and (identifier? selected-syntax)
+      (define/public (refresh/mode mode)
-                   (uninterned? (syntax-e selected-syntax)))
+        (case mode
+          ((term) (send pdisplayer display-meaning-info selected-syntax))
+          ((stxobj) (send pdisplayer display-stxobj-info selected-syntax))
+          ((#f) (void))
+          (else (error 'properties-view%:refresh "internal error: no such mode: ~s" mode))))
+
+      ;; text : text%
+      (field (text (new text%)))
+      (field (pdisplayer (new properties-displayer% (text text))))
+
+      (send text set-styles-sticky #f)
+      #;(send text hide-caret #t)
+      (send text lock #t)
+      (super-new)))
+
+
+  ;; properties-snip%
+  (define properties-snip%
+    (class (properties-view-base-mixin editor-snip%)
+      (inherit-field text)
+      (inherit-field pdisplayer)
+      (inherit set-mode)
+
+      (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-text last-position)])
+            (send outer-text insert text)
+            (let ([end (send outer-text last-position)])
+              (send outer-text change-style style start end #f)
+              (when clickback
+                    (send outer-text set-clickback start end clickback))))]))
+
+      (define outer-text (new text%))
+      (super-new (editor outer-text))
+      (outer:insert "Term" style:hyper (lambda _ (set-mode 'term)))
+      (outer:insert " ")
+      (outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj)))
+      (outer:insert "\n")
+      (outer:insert (new editor-snip% (editor text)))
+      (send outer-text hide-caret #t)
+      (send outer-text lock #t)))
+
+  ;; properties-view%
+  (define properties-view%
+    (class* (properties-view-base-mixin object%) ()
+      (init parent)
+      (inherit-field text)
+      (inherit-field pdisplayer)
+      (inherit set-mode)
+
+      ;; get-tab-choices : (listof (cons string thunk))
+      ;; Override to add or remove panels
+      (define/public (get-tab-choices)
+        (list (cons "Term" 'term)
+              (cons "Syntax Object" 'stxobj)))
+
+      (super-new)
+      (define tab-choices (get-tab-choices))
+      (define tab-panel (new tab-panel% 
+                             (choices (map car tab-choices))
+                             (parent parent)
+                             (callback
+                              (lambda (tp e)
+                                (set-mode
+                                 (cdr (list-ref tab-choices (send tp get-selection))))))))
+      (define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
+
+  ;; properties-displayer%
+  (define properties-displayer%
+    (class* object% ()
+      (init-field text)
+
+      ;; display-meaning-info : syntax -> void
+      (define/public (display-meaning-info stx)
+        (when (and (identifier? stx)
+                   (uninterned? (syntax-e stx)))
           (display "Uninterned symbol!\n\n" key-sd))
-        (display-binding-info)
+        (display-binding-info stx))
-        (inner (void) display-meaning-info))
 
-      
+      ;; display-binding-info : syntax -> void
-      (define/private (display-binding-info)
+      (define/private (display-binding-info stx)
         (display "Apparent identifier binding\n" key-sd)
-        (unless (identifier? selected-syntax)
+        (unless (identifier? stx)
           (display "Not applicable\n\n" n/a-sd))
-        (when (identifier? selected-syntax)
+        (when (identifier? stx)
-          (if (eq? (identifier-binding selected-syntax) 'lexical)
+          (if (eq? (identifier-binding stx) 'lexical)
               (display "lexical (all phases)\n" #f)
-              (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) selected-syntax)))
+              (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx)))
                         binding-properties))
           (display "\n" #f)))
 
+      ;; display-binding-kvs : string bindinginfo -> void
       (define/private (display-binding-kvs k v)
         (display k sub-key-sd)
         (display "\n" #f)
@@ -78,18 +156,19 @@
                (if (list-ref v 4)
                    (display "  via define-for-syntax" sub-key-sd))]))
 
-      (define/pubment (display-stxobj-info)
+      ;; display-stxobj-info : syntax -> void
-        (display-source-info)
+      (define/public (display-stxobj-info stx)
-        (display-extra-source-info)
+        (display-source-info stx)
-        (inner (void) display-stxobj-info)
+        (display-extra-source-info stx)
-        (display-symbol-property-info))
+        (display-symbol-property-info stx))
 
-      (define/private (display-source-info)
+      ;; display-source-info : syntax -> void
-        (define s-source (syntax-source selected-syntax))
+      (define/private (display-source-info stx)
-        (define s-line (syntax-line selected-syntax))
+        (define s-source (syntax-source stx))
-        (define s-column (syntax-column selected-syntax))
+        (define s-line (syntax-line stx))
-        (define s-position (syntax-position selected-syntax))
+        (define s-column (syntax-column stx))
-        (define s-span0 (syntax-span selected-syntax))
+        (define s-position (syntax-position stx))
+        (define s-span0 (syntax-span stx))
         (define s-span (if (zero? s-span0) #f s-span0))
         (display "Source location\n" key-sd)
         (if (or s-source s-line s-column s-position s-span)
@@ -102,40 +181,45 @@
             (display "No source location available\n" n/a-sd))
         (display "\n" #f))
 
-      (define/private (display-extra-source-info)
+      ;; display-extra-source-info : syntax -> void
+      (define/private (display-extra-source-info stx)
         (display "Built-in properties\n" key-sd)
         (display-subkv "source module"
-                       (let ([mod (syntax-source-module selected-syntax)])
+                       (let ([mod (syntax-source-module stx)])
                          (and mod (mpi->string mod))))
-        (display-subkv "original?" (syntax-original? selected-syntax))
+        (display-subkv "original?" (syntax-original? stx))
         (display "\n" #f))
 
-      (define/private (display-symbol-property-info)
+      ;; display-symbol-property-info : syntax -> void
-        (let ([keys (syntax-property-symbol-keys selected-syntax)])
+      (define/private (display-symbol-property-info stx)
+        (let ([keys (syntax-property-symbol-keys stx)])
           (display "Additional properties\n" key-sd)
           (when (null? keys)
             (display "No additional properties available.\n" n/a-sd))
           (when (pair? keys)
-            (for-each (lambda (k) (display-subkv k (syntax-property selected-syntax k)))
+            (for-each (lambda (k) (display-subkv k (syntax-property stx k)))
                       keys))))
 
+      ;; display-kv : any any -> void
       (define/private (display-kv key value)
         (display (format "~a~n" key) key-sd)
         (display (format "~s~n~n" value) #f))
 
+      ;; display-subkv : any any -> void
       (define/public (display-subkv k v)
         (display (format "~a: " k) sub-key-sd)
         (display (format "~a~n" v) #f))
 
+      ;; display : string style-delta -> void
       (define/private (display item sd)
         (let ([p0 (send text last-position)])
           (send text insert item)
           (let ([p1 (send text last-position)])
             (send text change-style sd p0 p1))))
 
-      (send text lock #t)
       (super-new)))
 
+
   ;; lift/id : (identifier -> void) 'a -> void
   (define (lift/id f)
     (lambda (stx) (when (identifier? stx) (f stx))))
@@ -175,4 +259,11 @@
       (send sd set-delta-foreground "gray")
       sd))
 
+  (define style:normal (make-object style-delta% 'change-normal))
+
+  (define style:hyper
+    (let ([s (make-object style-delta% 'change-normal)])
+      (send s set-delta 'change-toggle-underline)
+      (send s set-delta-foreground "blue")
+      s))
   )

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

@@ -7,7 +7,8 @@
            "interfaces.ss"
            "controller.ss"
            "properties.ss"
-           "typesetter.ss")
+           "typesetter.ss"
+           "partition.ss")
   (provide snip@
            snip-keymap-extension@)
 
@@ -26,8 +27,6 @@
       (define (syntax-snip stx)
         (new syntax-snip% (syntax stx)))
       
-      (define *syntax-controller* #f)
-      
       ;; syntax-value-snip%
       (define syntax-value-snip%
         (class* editor-snip% (readable-snip<%>)
@@ -81,11 +80,11 @@
           (define/override (copy)
             (new syntax-value-snip% (controller controller) (syntax stx)))
           
+          ;; read-special : any number/#f number/#f number/#f -> syntax
+          ;; Produces 3D syntax to preserve eq-ness of syntax
+          ;; #'#'stx would be lose identity when wrapped
           (define/public (read-special src line col pos)
-            #;(datum->syntax-object #f
+            #`((,(lambda () stx))))
-                                    `(,#'quote-syntax ,stx)
-                                    (list src line col pos 1))
-            #`(force '#,(delay stx)))
           ))
 
 
@@ -97,14 +96,13 @@
                    set-inset
                    set-snipclass
                    set-tight-text-fit
-                   show-border)
+                   show-border
+                   get-admin)
 
-          (define controller (new syntax-controller%))
+          (define controller
-          (define properties-controller
+            (new syntax-controller% (primary-partition (find-primary-partition))))
-            (new independent-properties-controller%
+          (define properties-snip (new properties-snip%))
-                 (syntax stx)
+          (send controller set-properties-controller this)
-                 (controller controller)))
-          (send controller set-properties-controller properties-controller)
 
           (define -outer (new text%))
           (super-new (editor -outer) (with-border? #f))
@@ -122,32 +120,42 @@
                   (format "#<syntax:~s:~s>" line col)
                   "#<syntax>")))
           
-          (define/private (hide-me)
+          (define shown? #f)
+          (define/public (refresh)
+            (if shown?
+                (refresh/shown)
+                (refresh/hidden)))
+
+          (define/private (refresh/hidden)
             (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 (show-icon) style:hyper 
+                          (lambda _ (set! shown? #t) (refresh)))
             (outer:insert the-summary)
             (send* -outer 
               (lock #t)
               (end-edit-sequence)))
 
-          (define/private (show-me)
+          (define/private (refresh/shown)
             (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 (hide-icon) style:hyper
+                          (lambda _ (set! shown? #f) (refresh)))
             (outer:insert " ")
             (outer:insert the-syntax-snip)
             (outer:insert " ")
-            (outer:insert (show-properties-icon) style:hyper 
+            (if (props-shown?)
-                          (lambda _ (send properties-controller show #t)))
+                (begin (outer:insert "<" style:green (lambda _ (show #f)))
+                       (outer:insert properties-snip))
+                (begin (outer:insert ">" style:green (lambda _ (show #t)))))
             (send* -outer
               (change-style (make-object style-delta% 'change-alignment 'top)
                             0
@@ -177,12 +185,28 @@
           (define/public (read-special src line col pos)
             (send the-syntax-snip read-special src line col pos))
 
-          (hide-me)
+          (define/private (find-primary-partition)
+            #;(define editor (send (get-admin) get-editor))
+            (new-bound-partition))
+
+
+          ;; syntax-properties-controller methods
+          (define properties-shown? #f)
+          (define/public (props-shown?)
+            properties-shown?)
+          (define/public (show ?)
+            (set! properties-shown? ?)
+            (refresh))
+          (define/public (set-syntax stx)
+            (send properties-snip set-syntax stx))
+
+          (refresh)
           (send -outer hide-caret #t)
           (send -outer lock #t)
           ))
       
       ;; independent-properties-controller%
+      #;
       (define independent-properties-controller%
         (class* object% (syntax-properties-controller<%>)
           (init-field controller)
@@ -192,13 +216,6 @@
           (define parent
             (new frame% (label "Properties") (height (pref:height))
                  (width (floor (* (pref:props-percentage) (pref:width))))))
-          ;(define vp (new panel:vertical-dragable% (parent parent)))
-          ;(define syntax-text (new text%))
-          ;(define syntax-canvas (new editor-canvas% (parent vp) (editor syntax-text)))
-          ;(let ([ss (new syntax-value-snip% (syntax stx) (controller controller))])
-          ;  (send syntax-text insert ss)
-          ;  ...)
-          ;(send syntax-text lock #t)
           (define pv (new properties-view% (parent parent)))
           
           (define/private (show-properties)
@@ -211,6 +228,7 @@
             (send parent show ?))
           (define/public (props-shown?)
             (send parent is-shown?))
+
           (super-new)))
       ))
 
@@ -237,6 +255,10 @@
       (send s set-delta 'change-toggle-underline)
       (send s set-delta-foreground "blue")
       s))
+  (define style:green
+    (let ([s (make-object style-delta% 'change-normal)])
+      (send s set-delta-foreground "darkgreen")
+      s))
   (define style:bold
     (let ([s (make-object style-delta% 'change-normal)])
       (send s set-delta 'change-bold)