commit ca576ca4858353852ba12bf1f18ac86497808cee
parent 6a2575ac34aacbe1739b64cd5812aa80f814df3b
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 1 Feb 2007 23:10:38 +0000
Macro stepper:
syntax snips display properties inline
changed read-special to use procedures instead of promises
svn: r5534
original commit: 8ac1fe54e1ec645b50f31f05c6400435924cbd8b
Diffstat:
2 files changed, 213 insertions(+), 100 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/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%
- (define properties-view%
- (class* object% ()
- (init parent)
- (define selected-syntax #f)
-
- (define tab-choices (get-tab-choices))
- (define tab-panel (new tab-panel%
- (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)))
+ ;; properties-view-base-mixin
+ (define properties-view-base-mixin
+ (mixin () ()
+ (init)
+
+ ;; selected-syntax : syntax
+ (field (selected-syntax #f))
+ ;; set-syntax : syntax -> void
(define/public (set-syntax stx)
(set! selected-syntax stx)
(refresh))
-
- ;; get-tab-choices : (listof (cons string thunk))
- ;; Override to add or remove panels
- (define/public (get-tab-choices)
- (list (cons "Term" (lambda () (display-meaning-info)))
- (cons "Syntax Object" (lambda () (display-stxobj-info)))))
-
- (define/private (refresh)
+
+ ;; mode : maybe symbol in '(term stxobj)
+ (define mode 'term)
+
+ ;; 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))])
- (cond [(assoc tab tab-choices) => (lambda (p) ((cdr p)))]
- [else (error 'properties-view%:refresh "internal error: no such tab: ~s" tab)])))
+ (refresh/mode mode))
(send* text
(end-edit-sequence)
(lock #t)
(scroll-to-position 0)))
- (define/pubment (display-meaning-info)
- (when (and (identifier? selected-syntax)
- (uninterned? (syntax-e selected-syntax)))
+ ;; refresh/mode : symbol -> void
+ (define/public (refresh/mode mode)
+ (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)
- (inner (void) display-meaning-info))
-
-
- (define/private (display-binding-info)
+ (display-binding-info stx))
+
+ ;; display-binding-info : syntax -> void
+ (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)
- (if (eq? (identifier-binding selected-syntax) 'lexical)
+ (when (identifier? stx)
+ (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)
@@ -77,19 +155,20 @@
(display-subkv " as" (list-ref v 3))
(if (list-ref v 4)
(display " via define-for-syntax" sub-key-sd))]))
-
- (define/pubment (display-stxobj-info)
- (display-source-info)
- (display-extra-source-info)
- (inner (void) display-stxobj-info)
- (display-symbol-property-info))
-
- (define/private (display-source-info)
- (define s-source (syntax-source selected-syntax))
- (define s-line (syntax-line selected-syntax))
- (define s-column (syntax-column selected-syntax))
- (define s-position (syntax-position selected-syntax))
- (define s-span0 (syntax-span selected-syntax))
+
+ ;; display-stxobj-info : syntax -> void
+ (define/public (display-stxobj-info stx)
+ (display-source-info stx)
+ (display-extra-source-info stx)
+ (display-symbol-property-info stx))
+
+ ;; display-source-info : syntax -> void
+ (define/private (display-source-info stx)
+ (define s-source (syntax-source stx))
+ (define s-line (syntax-line stx))
+ (define s-column (syntax-column stx))
+ (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)
@@ -101,41 +180,46 @@
(display-subkv "span" s-span0))
(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)
- (let ([keys (syntax-property-symbol-keys selected-syntax)])
+
+ ;; display-symbol-property-info : syntax -> void
+ (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))))
@@ -174,5 +258,12 @@
(let ([sd (new style-delta%)])
(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))
)
diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/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<%>)
@@ -35,7 +34,7 @@
(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)
@@ -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
- `(,#'quote-syntax ,stx)
- (list src line col pos 1))
- #`(force '#,(delay stx)))
+ #`((,(lambda () stx))))
))
@@ -97,15 +96,14 @@
set-inset
set-snipclass
set-tight-text-fit
- show-border)
-
- (define controller (new syntax-controller%))
- (define properties-controller
- (new independent-properties-controller%
- (syntax stx)
- (controller controller)))
- (send controller set-properties-controller properties-controller)
-
+ show-border
+ get-admin)
+
+ (define controller
+ (new syntax-controller% (primary-partition (find-primary-partition))))
+ (define properties-snip (new properties-snip%))
+ (send controller set-properties-controller this)
+
(define -outer (new text%))
(super-new (editor -outer) (with-border? #f))
(set-margin 0 0 0 0)
@@ -122,39 +120,49 @@
(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
- (lambda _ (send properties-controller show #t)))
+ (if (props-shown?)
+ (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
(send -outer last-position))
(lock #t)
(end-edit-sequence)))
-
+
(define/private outer:insert
(case-lambda
[(obj)
@@ -176,13 +184,29 @@
(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)
+
+ (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)
