From 333fcfab0244c683a20653518de7d87efd28ef62 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 29 Jan 2010 00:08:15 +0000 Subject: [PATCH] merge to trunk svn: r17877 original commit: 9789615ed9840f09a6708d27276cf892d334b653 --- collects/macro-debugger/expand.ss | 2 +- collects/macro-debugger/stepper-text.ss | 9 +- .../syntax-browser/syntax-snip.ss | 355 ------------------ 3 files changed, 2 insertions(+), 364 deletions(-) delete mode 100644 collects/macro-debugger/syntax-browser/syntax-snip.ss diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index 29f6d77..48d4c22 100644 --- 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 index 3df8213..327b52a 100644 --- 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 deleted file mode 100644 index c5063b0..0000000 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ /dev/null @@ -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))))