diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index dc0cb2e08c..563a932cfd 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -29,7 +29,8 @@ ;; print-syntax-to-editor : syntax text controller<%> config number number ;; -> display<%> -(define (print-syntax-to-editor stx text controller config columns insertion-point) +(define (print-syntax-to-editor stx text controller config columns + [insertion-point (send text last-position)]) (begin-with-definitions (define output-port (open-output-string/count-lines)) (define range diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/snip-decorated.ss similarity index 52% rename from collects/macro-debugger/syntax-browser/syntax-snip.ss rename to collects/macro-debugger/syntax-browser/snip-decorated.ss index c5063b0c4b..55f0574048 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/snip-decorated.ss @@ -2,76 +2,17 @@ (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") + "prefs.ss" + (except-in "snip.ss" + snip-class)) -(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))) - )) +(provide decorated-syntax-snip% + snip-class) (define top-aligned (make-object style-delta% 'change-alignment 'top)) @@ -155,18 +96,18 @@ (refresh-contents) )) -;; syntax-snip% -(define syntax-snip% +;; decorated-syntax-snip% +(define decorated-syntax-snip% (class* clicky-snip% (readable-snip<%>) (init-field ((stx syntax))) (init-field [controller (new controller%)]) - (init-field [config (new syntax-snip-config%)]) + (init-field [config (new syntax-prefs%)]) (inherit set-snipclass refresh-contents) (define the-syntax-snip - (new syntax-value-snip% + (new syntax-snip% (syntax stx) (controller controller) (config config))) @@ -193,7 +134,10 @@ ;; Snip methods (define/override (copy) - (new syntax-snip% (syntax stx))) + (new decorated-syntax-snip% + (syntax stx) + (controller controller) + (config config))) (define/override (write stream) (send stream put (string->bytes/utf-8 @@ -251,105 +195,19 @@ (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))])) +;; SNIPCLASS ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss -(define syntax-snipclass% +(define decorated-syntax-snipclass% (class snip-class% (define/override (read stream) - (make-object syntax-snip% - (unmarshall-syntax (read-from-string (send stream get-bytes))))) - (super-instantiate ()))) + (new decorated-syntax-snip% + (syntax (unmarshall-syntax + (read-from-string (send stream get-bytes)))))) + (super-new))) -(define snip-class (make-object syntax-snipclass%)) +(define snip-class (make-object decorated-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)))) + (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.ss"))) diff --git a/collects/macro-debugger/syntax-browser/snip.ss b/collects/macro-debugger/syntax-browser/snip.ss new file mode 100644 index 0000000000..7116afcbff --- /dev/null +++ b/collects/macro-debugger/syntax-browser/snip.ss @@ -0,0 +1,181 @@ +#lang scheme/base +(require scheme/class + (rename-in unstable/class-iop + [send/i send:]) + scheme/match + mzlib/string + mred + framework + "interfaces.ss" + "display.ss" + "controller.ss" + "keymap.ss" + "prefs.ss") + +(provide syntax-snip% + marshall-syntax + unmarshall-syntax + snip-class) + +;; syntax-snip% +(define syntax-snip% + (class* editor-snip% (readable-snip<%>) + (init-field ((stx syntax))) + (init-field (controller (new controller%))) + (init-field (config (new syntax-prefs/readonly%))) + (init-field (columns 40)) + + (inherit set-margin + set-inset + set-snipclass) + + (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 columns)) + (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-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/override (write stream) + (send stream put + (string->bytes/utf-8 + (format "~s" (marshall-syntax stx))))) + + (set-snipclass snip-class))) + +;; Marshalling stuff + +;; 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))])) + +(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)))) + +;; SNIPCLASS + +;; 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 (new syntax-snipclass%)) +(send snip-class set-version 2) +(send snip-class set-classname + (format "~s" '(lib "macro-debugger/syntax-browser/snip.ss")))