commit 333fcfab0244c683a20653518de7d87efd28ef62
parent 82aed89fa488bfe31158b404d43f7bfa4c4beb4d
Author: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 29 Jan 2010 00:08:15 +0000
merge to trunk
svn: r17877
original commit: 9789615ed9840f09a6708d27276cf892d334b653
Diffstat:
3 files changed, 2 insertions(+), 364 deletions(-)
diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss
@@ -25,7 +25,7 @@
(define (expand/show-predicate stx show?)
(let-values ([(result deriv) (trace/result stx)])
(when (exn? result) (raise result))
- (let-values ([(_steps _uses stx exn2)
+ (let-values ([(_steps _defs _uses stx exn2)
(parameterize ((macro-policy show?))
(reductions+ deriv))])
(when (exn? exn2) (raise exn2))
diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss
@@ -93,13 +93,6 @@
((if display-like? display write) (syntax-dummy-val obj) port)]
[else
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
- (define (pp-extend-style-table)
- (let* ([ids identifier-list]
- [syms (map (lambda (x) (hash-ref stx=>flat x)) ids)]
- [like-syms (map syntax-e ids)])
- (pretty-print-extend-style-table (pp-better-style-table)
- syms
- like-syms)))
(define (pp-better-style-table)
(pretty-print-extend-style-table (pretty-print-current-style-table)
(map car extended-style-list)
@@ -107,7 +100,7 @@
(parameterize
([pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
- [pretty-print-current-style-table (pp-extend-style-table)])
+ [pretty-print-current-style-table (pp-better-style-table)])
(pretty-print/defaults datum)))
(define (->show-function show)
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))))
