diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index 1734199..dc0cb2e 100644 --- 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 index e462cf7..3affaa4 100644 --- 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 index 81d1f33..8df1e63 100644 --- 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 index 456eff0..af67d15 100644 --- 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 index f0aa609..4787e83 100644 --- 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 index 6d82876..bce6763 100644 --- 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)