commit debe673ceb598d67c45289423250f87daf060e4e
parent f616cdbf542f01a4fee8837373759fb4da0dcbe3
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 18 Feb 2010 22:53:11 +0000
scheme/pretty: added quasisyntax reader macro
macro-debugger: added change layout menu items
svn: r18166
original commit: b68494250fff8a402a8bd9e51ee01521cac57bbd
Diffstat:
6 files changed, 56 insertions(+), 16 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -37,6 +37,7 @@
(send: controller controller<%> get-primary-partition)
(length (send: config config<%> get-colors))
(send: config config<%> get-suffix-option)
+ (send config get-pretty-styles)
columns))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss
@@ -74,6 +74,14 @@
(lambda (i e)
(send config set-props-shown? #f)))
+ (define ((pretty-print-as sym) i e)
+ (let ([stx (selected-syntax)])
+ (when (identifier? stx)
+ (send config set-pretty-styles
+ (hash-set (send config get-pretty-styles)
+ (syntax-e stx)
+ sym)))))
+
(define/override (add-context-menu-items menu)
(new menu-item% (label "Copy") (parent menu)
(demand-callback
@@ -83,6 +91,27 @@
(lambda (i e)
(call-function "copy-syntax-as-text" i e))))
(new separator-menu-item% (parent menu))
+ (let ([pretty-menu
+ (new menu%
+ (label "Change layout")
+ (parent menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (and (identifier? (selected-syntax)) #t)))))])
+ (for ([sym+desc '((and "like and")
+ (begin "like begin (0 up)")
+ (lambda "like lambda (1 up)")
+ (do "like do (2 up)"))])
+ (new menu-item%
+ (label (format "Format identifier ~a" (cadr sym+desc)))
+ (parent pretty-menu)
+ (demand-callback
+ (lambda (i)
+ (let ([stx (selected-syntax)])
+ (send i set-label
+ (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))
+ (callback
+ (pretty-print-as (car sym+desc))))))
(new menu-item%
(label "Clear selection")
(parent menu)
diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss
@@ -24,6 +24,10 @@
;; suffix-option : SuffixOption
(define-notify suffix-option (new notify-box% (value 'over-limit)))
+ ;; pretty-styles : ImmutableHash[symbol -> symbol]
+ (define-notify pretty-styles
+ (new notify-box% (value (make-immutable-hasheq null))))
+
;; syntax-font-size : number/#f
;; When non-false, overrides the default font size
(define-notify syntax-font-size (new notify-box% (value #f)))
diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss
@@ -171,8 +171,8 @@
(list expr))))))
(define special-expression-keywords
- '(quote quasiquote unquote unquote-splicing syntax))
-;; FIXME: quasisyntax unsyntax unsyntax-splicing
+ '(quote quasiquote unquote unquote-splicing syntax
+ quasisyntax unsyntax unsyntax-splicing))
(define (suffix sym n)
(string->symbol (format "~a:~a" sym n)))
diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss
@@ -9,9 +9,9 @@
;; FIXME: Need to disable printing of structs with custom-write property
-;; pretty-print-syntax : syntax port partition number SuffixOption number
+;; pretty-print-syntax : syntax port partition number SuffixOption hasheq number
;; -> range%
-(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
+(define (pretty-print-syntax stx port primary-partition colors suffix-option styles columns)
(define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition colors suffix-option))
@@ -45,7 +45,7 @@
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-remap-stylable pp-remap-stylable]
- [pretty-print-current-style-table (pp-better-style-table)]
+ [pretty-print-current-style-table (pp-better-style-table styles)]
[pretty-print-columns columns])
(pretty-print/defaults datum port)
(new range%
@@ -72,8 +72,21 @@
(define (pp-remap-stylable obj)
(and (id-syntax-dummy? obj) (id-syntax-dummy-remap obj)))
-(define (pp-better-style-table)
- (basic-style-list)
+(define (pp-better-style-table styles)
+ (define style-list (for/list ([(k v) (in-hash styles)]) (cons k v)))
+ (pretty-print-extend-style-table
+ (basic-style-list)
+ (map car style-list)
+ (map cdr style-list)))
+
+(define (basic-style-list)
+ (pretty-print-extend-style-table
+ (pretty-print-current-style-table)
+ (map car basic-styles)
+ (map cdr basic-styles)))
+(define basic-styles
+ '((define-values . define)
+ (define-syntaxes . define-syntax))
#|
;; Messes up formatting too much :(
(let* ([pref (pref:tabify)]
@@ -88,15 +101,6 @@
(map cdr style-list))))
|#)
-(define (basic-style-list)
- (pretty-print-extend-style-table
- (pretty-print-current-style-table)
- (map car basic-styles)
- (map cdr basic-styles)))
-(define basic-styles
- '((define-values . define)
- (define-syntaxes . define-syntax)))
-
(define-local-member-name range:get-ranges)
;; range-builder%
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -168,6 +168,8 @@
(lambda (_) (refresh/re-reduce)))
(listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?))))
+ (send config listen-pretty-styles
+ (lambda (_) (update/preserve-view)))
(define nav:up
(new button% (label "Previous term") (parent navigator)
