commit f612916a6b9027a9c9256f4a71701b8ca7845361
parent debe673ceb598d67c45289423250f87daf060e4e
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 19 Feb 2010 05:45:54 +0000
macro-debugger: some work on syntax snips
svn: r18182
original commit: cb16dde709387c4398a1ec787d0e09771c1011ed
Diffstat:
4 files changed, 396 insertions(+), 356 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -29,7 +29,8 @@
;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%>
-(define (print-syntax-to-editor stx text controller config columns insertion-point)
+(define (print-syntax-to-editor stx text controller config columns
+ [insertion-point (send text last-position)])
(begin-with-definitions
(define output-port (open-output-string/count-lines))
(define range
diff --git a/collects/macro-debugger/syntax-browser/snip-decorated.ss b/collects/macro-debugger/syntax-browser/snip-decorated.ss
@@ -0,0 +1,213 @@
+#lang scheme/base
+(require scheme/class
+ (rename-in unstable/class-iop
+ [send/i send:])
+ mzlib/string
+ mred
+ "interfaces.ss"
+ "controller.ss"
+ "properties.ss"
+ "prefs.ss"
+ (except-in "snip.ss"
+ snip-class))
+
+(provide decorated-syntax-snip%
+ snip-class)
+
+(define top-aligned
+ (make-object style-delta% 'change-alignment 'top))
+
+(define-struct styled (contents style clickback))
+
+;; clicky-snip%
+(define clicky-snip%
+ (class* editor-snip% ()
+
+ (init-field [open-style '(border)]
+ [closed-style '(tight-text-fit)])
+
+ (inherit set-margin
+ set-inset
+ set-snipclass
+ set-tight-text-fit
+ show-border
+ get-admin)
+
+ (define -outer (new text%))
+ (super-new (editor -outer) (with-border? #f))
+ (set-margin 2 2 2 2)
+ (set-inset 2 2 2 2)
+ ;;(set-margin 3 0 0 0)
+ ;;(set-inset 1 0 0 0)
+ ;;(set-margin 0 0 0 0)
+ ;;(set-inset 0 0 0 0)
+
+ (define/public (closed-contents) null)
+ (define/public (open-contents) null)
+
+ (define open? #f)
+
+ (define/public (refresh-contents)
+ (send* -outer
+ (begin-edit-sequence)
+ (lock #f)
+ (erase))
+ (do-style (if open? open-style closed-style))
+ (outer:insert (if open? (hide-icon) (show-icon))
+ style:hyper
+ (if open?
+ (lambda _
+ (set! open? #f)
+ (refresh-contents))
+ (lambda _
+ (set! open? #t)
+ (refresh-contents))))
+ (for-each (lambda (s) (outer:insert s))
+ (if open? (open-contents) (closed-contents)))
+ (send* -outer
+ (change-style top-aligned 0 (send -outer last-position))
+ (lock #t)
+ (end-edit-sequence)))
+
+ (define/private (do-style style)
+ (show-border (memq 'border style))
+ (set-tight-text-fit (memq 'tight-text-fit style)))
+
+ (define/private outer:insert
+ (case-lambda
+ [(obj)
+ (if (styled? obj)
+ (outer:insert (styled-contents obj)
+ (styled-style obj)
+ (styled-clickback 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))))]))
+
+ (send -outer hide-caret #t)
+ (send -outer lock #t)
+ (refresh-contents)
+ ))
+
+;; decorated-syntax-snip%
+(define decorated-syntax-snip%
+ (class* clicky-snip% (readable-snip<%>)
+ (init-field ((stx syntax)))
+ (init-field [controller (new controller%)])
+ (init-field [config (new syntax-prefs%)])
+
+ (inherit set-snipclass
+ refresh-contents)
+
+ (define the-syntax-snip
+ (new syntax-snip%
+ (syntax stx)
+ (controller controller)
+ (config config)))
+ (define the-summary
+ (let* ([t (new text%)]
+ [es (new editor-snip% (editor t) (with-border? #f))])
+ (send es set-margin 0 0 0 0)
+ (send es set-inset 0 0 0 0)
+ (send t insert (format "~s" stx))
+ es))
+
+ (define properties-snip
+ (new properties-container-snip%
+ (controller controller)))
+
+ (define/override (closed-contents)
+ (list the-summary))
+
+ (define/override (open-contents)
+ (list " "
+ the-syntax-snip
+ " "
+ properties-snip))
+
+ ;; Snip methods
+ (define/override (copy)
+ (new decorated-syntax-snip%
+ (syntax stx)
+ (controller controller)
+ (config config)))
+ (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))
+
+ (send: config config<%> listen-props-shown?
+ (lambda (?) (refresh-contents)))
+
+ (super-new)
+ (set-snipclass snip-class)
+ ))
+
+(define properties-container-snip%
+ (class clicky-snip%
+ (init controller)
+
+ (define properties-snip
+ (new properties-snip% (controller controller)))
+
+ (define/override (open-contents)
+ (list #;(show-properties-icon)
+ properties-snip))
+
+ (define/override (closed-contents)
+ (list (show-properties-icon)))
+
+ (super-new (open-style '())
+ (closed-style '()))))
+
+(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))
+(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)
+ s))
+
+(define (show-icon)
+ (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 (show-properties-icon)
+ (make-object image-snip%
+ (build-path (collection-path "icons") "syncheck.png")))
+
+
+;; SNIPCLASS
+
+;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
+(define decorated-syntax-snipclass%
+ (class snip-class%
+ (define/override (read stream)
+ (new decorated-syntax-snip%
+ (syntax (unmarshall-syntax
+ (read-from-string (send stream get-bytes))))))
+ (super-new)))
+
+(define snip-class (make-object decorated-syntax-snipclass%))
+(send snip-class set-version 2)
+(send snip-class set-classname
+ (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.ss")))
diff --git a/collects/macro-debugger/syntax-browser/snip.ss b/collects/macro-debugger/syntax-browser/snip.ss
@@ -0,0 +1,181 @@
+#lang scheme/base
+(require scheme/class
+ (rename-in unstable/class-iop
+ [send/i send:])
+ scheme/match
+ mzlib/string
+ mred
+ framework
+ "interfaces.ss"
+ "display.ss"
+ "controller.ss"
+ "keymap.ss"
+ "prefs.ss")
+
+(provide syntax-snip%
+ marshall-syntax
+ unmarshall-syntax
+ snip-class)
+
+;; syntax-snip%
+(define syntax-snip%
+ (class* editor-snip% (readable-snip<%>)
+ (init-field ((stx syntax)))
+ (init-field (controller (new controller%)))
+ (init-field (config (new syntax-prefs/readonly%)))
+ (init-field (columns 40))
+
+ (inherit set-margin
+ set-inset
+ set-snipclass)
+
+ (define text (new text:standard-style-list%))
+ (super-new (editor text) (with-border? #f))
+
+ (set-margin 0 0 0 0)
+ ;;(set-inset 2 2 2 2)
+ ;;(set-margin 2 2 2 2)
+ (set-inset 0 0 0 0)
+
+ (send text begin-edit-sequence)
+ (send text change-style (make-object style-delta% 'change-alignment 'top))
+ (define display
+ (print-syntax-to-editor stx text controller config columns))
+ (send text lock #t)
+ (send text end-edit-sequence)
+ (send text hide-caret #t)
+
+ (setup-keymap text)
+
+ (define/public (setup-keymap text)
+ (new syntax-keymap%
+ (controller controller)
+ (config config)
+ (editor text)))
+
+ ;; snip% Methods
+ (define/override (copy)
+ (new syntax-snip%
+ (config config)
+ (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)
+ (with-syntax ([p (lambda () stx)])
+ #'(p)))
+
+ (define/override (write stream)
+ (send stream put
+ (string->bytes/utf-8
+ (format "~s" (marshall-syntax stx)))))
+
+ (set-snipclass snip-class)))
+
+;; Marshalling stuff
+
+;; 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
+ #'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 (lambda () (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))))
+
+;; SNIPCLASS
+
+;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
+(define syntax-snipclass%
+ (class snip-class%
+ (define/override (read stream)
+ (make-object syntax-snip%
+ (unmarshall-syntax (read-from-string (send stream get-bytes)))))
+ (super-instantiate ())))
+
+(define snip-class (new syntax-snipclass%))
+(send snip-class set-version 2)
+(send snip-class set-classname
+ (format "~s" '(lib "macro-debugger/syntax-browser/snip.ss")))
diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss
@@ -1,355 +0,0 @@
-#lang scheme/base
-(require scheme/class
- (rename-in unstable/class-iop
- [send/i send:])
- scheme/match
- scheme/list
- mzlib/string
- mred
- framework
- unstable/gui/notify
- "interfaces.ss"
- "display.ss"
- "controller.ss"
- "keymap.ss"
- "properties.ss"
- "partition.ss"
- "prefs.ss")
-
-(provide syntax-snip%
- syntax-value-snip%)
-
-(define syntax-snip-config%
- (class prefs-base%
- (define-notify props-shown? (new notify-box% (value #f)))
- (super-new)))
-
-;; syntax-value-snip%
-(define syntax-value-snip%
- (class* editor-snip% (readable-snip<%>)
- (init-field ((stx syntax)))
- (init-field (controller (new controller%)))
- (init-field (config (new syntax-snip-config%)))
-
- (inherit set-margin
- set-inset)
-
- (define text (new text:standard-style-list%))
- (super-new (editor text) (with-border? #f))
-
- (set-margin 0 0 0 0)
- ;;(set-inset 2 2 2 2)
- ;;(set-margin 2 2 2 2)
- (set-inset 0 0 0 0)
-
- (send text begin-edit-sequence)
- (send text change-style (make-object style-delta% 'change-alignment 'top))
- (define display
- (print-syntax-to-editor stx text controller config))
- (send text lock #t)
- (send text end-edit-sequence)
- (send text hide-caret #t)
-
- (setup-keymap text)
-
- (define/public (setup-keymap text)
- (new syntax-keymap%
- (controller controller)
- (config config)
- (editor text)))
-
- ;; snip% Methods
- (define/override (copy)
- (new syntax-value-snip%
- (config config)
- (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)
- (with-syntax ([p (lambda () stx)])
- #'(p)))
- ))
-
-(define top-aligned
- (make-object style-delta% 'change-alignment 'top))
-
-(define-struct styled (contents style clickback))
-
-;; clicky-snip%
-(define clicky-snip%
- (class* editor-snip% ()
-
- (init-field [open-style '(border)]
- [closed-style '(tight-text-fit)])
-
- (inherit set-margin
- set-inset
- set-snipclass
- set-tight-text-fit
- show-border
- get-admin)
-
- (define -outer (new text%))
- (super-new (editor -outer) (with-border? #f))
- (set-margin 2 2 2 2)
- (set-inset 2 2 2 2)
- ;;(set-margin 3 0 0 0)
- ;;(set-inset 1 0 0 0)
- ;;(set-margin 0 0 0 0)
- ;;(set-inset 0 0 0 0)
-
- (define/public (closed-contents) null)
- (define/public (open-contents) null)
-
- (define open? #f)
-
- (define/public (refresh-contents)
- (send* -outer
- (begin-edit-sequence)
- (lock #f)
- (erase))
- (do-style (if open? open-style closed-style))
- (outer:insert (if open? (hide-icon) (show-icon))
- style:hyper
- (if open?
- (lambda _
- (set! open? #f)
- (refresh-contents))
- (lambda _
- (set! open? #t)
- (refresh-contents))))
- (for-each (lambda (s) (outer:insert s))
- (if open? (open-contents) (closed-contents)))
- (send* -outer
- (change-style top-aligned 0 (send -outer last-position))
- (lock #t)
- (end-edit-sequence)))
-
- (define/private (do-style style)
- (show-border (memq 'border style))
- (set-tight-text-fit (memq 'tight-text-fit style)))
-
- (define/private outer:insert
- (case-lambda
- [(obj)
- (if (styled? obj)
- (outer:insert (styled-contents obj)
- (styled-style obj)
- (styled-clickback 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))))]))
-
- (send -outer hide-caret #t)
- (send -outer lock #t)
- (refresh-contents)
- ))
-
-;; syntax-snip%
-(define syntax-snip%
- (class* clicky-snip% (readable-snip<%>)
- (init-field ((stx syntax)))
- (init-field [controller (new controller%)])
- (init-field [config (new syntax-snip-config%)])
-
- (inherit set-snipclass
- refresh-contents)
-
- (define the-syntax-snip
- (new syntax-value-snip%
- (syntax stx)
- (controller controller)
- (config config)))
- (define the-summary
- (let* ([t (new text%)]
- [es (new editor-snip% (editor t) (with-border? #f))])
- (send es set-margin 0 0 0 0)
- (send es set-inset 0 0 0 0)
- (send t insert (format "~s" stx))
- es))
-
- (define properties-snip
- (new properties-container-snip%
- (controller controller)))
-
- (define/override (closed-contents)
- (list the-summary))
-
- (define/override (open-contents)
- (list " "
- the-syntax-snip
- " "
- properties-snip))
-
- ;; Snip methods
- (define/override (copy)
- (new syntax-snip% (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))
-
- (send: config config<%> listen-props-shown?
- (lambda (?) (refresh-contents)))
-
- (super-new)
- (set-snipclass snip-class)
- ))
-
-(define properties-container-snip%
- (class clicky-snip%
- (init controller)
-
- (define properties-snip
- (new properties-snip% (controller controller)))
-
- (define/override (open-contents)
- (list #;(show-properties-icon)
- properties-snip))
-
- (define/override (closed-contents)
- (list (show-properties-icon)))
-
- (super-new (open-style '())
- (closed-style '()))))
-
-(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))
-(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)
- s))
-
-(define (show-icon)
- (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 (show-properties-icon)
- (make-object image-snip%
- (build-path (collection-path "icons") "syncheck.png")))
-
-;; 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))]))
-
-;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
-(define syntax-snipclass%
- (class snip-class%
- (define/override (read stream)
- (make-object syntax-snip%
- (unmarshall-syntax (read-from-string (send stream get-bytes)))))
- (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
- #'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 (lambda () (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))))
