scheme/pretty: added quasisyntax reader macro

macro-debugger: added change layout menu items

svn: r18166

original commit: b68494250fff8a402a8bd9e51ee01521cac57bbd

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

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)

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)))

collects/macro-debugger/syntax-browser/pretty-helper.ss

@@ -171,8 +171,8 @@
                     (list expr))))))
 
 (define special-expression-keywords
-  '(quote quasiquote unquote unquote-splicing syntax))
+  '(quote quasiquote unquote unquote-splicing syntax
-;; FIXME: quasisyntax unsyntax unsyntax-splicing
+    quasisyntax unsyntax unsyntax-splicing))
 
 (define (suffix sym n)
   (string->symbol (format "~a:~a" sym n)))

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)
+(define (pp-better-style-table styles)
-  (basic-style-list)
+  (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%

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)