diff --git a/collects/xml/scheme-snipclass.rkt b/collects/xml/scheme-snipclass.rkt index 94c7f3500c..9c51111112 100644 --- a/collects/xml/scheme-snipclass.rkt +++ b/collects/xml/scheme-snipclass.rkt @@ -7,27 +7,27 @@ (define scheme-snip% (class* editor-snip% (scheme-snip<%> readable-snip<%>) - (init-field splice?) - (define/public (get-splice?) splice?) + (init-field splice?) + (define/public (get-splice?) splice?) - (define/public (read-special file line col pos) - (scheme-read-special this - file - line - col - pos)) + (define/public (read-special file line col pos) + (scheme-read-special this + file + line + col + pos)) - (super-instantiate ()))) + (super-instantiate ()))) (define scheme-snipclass% (class snip-class% - (define/override (read stream-in) - (let* ([splice? (zero? (send stream-in get-exact))] - [snip (instantiate scheme-snip% () - (splice? splice?))]) - (send (send snip get-editor) read-from-file stream-in #f) - snip)) - (super-instantiate ()))) + (define/override (read stream-in) + (let* ([splice? (zero? (send stream-in get-exact))] + [snip (instantiate scheme-snip% () + (splice? splice?))]) + (send (send snip get-editor) read-from-file stream-in #f) + snip)) + (super-instantiate ()))) (define snip-class (make-object scheme-snipclass%)) (send snip-class set-version 1) diff --git a/collects/xml/text-snipclass.rkt b/collects/xml/text-snipclass.rkt index 7ee5cf77a5..b2ca06f4c5 100644 --- a/collects/xml/text-snipclass.rkt +++ b/collects/xml/text-snipclass.rkt @@ -44,8 +44,8 @@ (define snipclass-text-box% (class decorated-editor-snipclass% - (define/override (make-snip stream-in) (new text-box%)) - (super-instantiate ()))) + (define/override (make-snip stream-in) (new text-box%)) + (super-instantiate ()))) (define old-snipclass (new snipclass-text-box%)) (send old-snipclass set-version 1) @@ -59,90 +59,90 @@ (define text-box% (class* decorated-editor-snip% (readable-snip<%>) - (define/override (make-editor) (let ([e (new text:keymap%)]) - (send e set-max-undo-history 'forever) - e)) - (define/override (make-snip) (make-object text-box%)) - (inherit get-editor get-admin) + (define/override (make-editor) (let ([e (new text:keymap%)]) + (send e set-max-undo-history 'forever) + e)) + (define/override (make-snip) (make-object text-box%)) + (inherit get-editor get-admin) - (define/override (get-corner-bitmap) - (get-icon)) + (define/override (get-corner-bitmap) + (get-icon)) - (define/override (get-menu) - (let ([menu (new popup-menu%)]) - (new menu-item% - (label "Convert to string") - (parent menu) - (callback - (lambda (x y) - (let ([to-ed (find-containing-editor)]) - (when to-ed - (let ([this-pos (find-this-position)]) - (when this-pos - (let ([from-ed (get-editor)]) - (send to-ed begin-edit-sequence) - (send from-ed begin-edit-sequence) - (send to-ed delete this-pos (+ this-pos 1)) - (let* ((p (open-input-text-editor from-ed 0 'end - (lambda (s) - (values (box s) 1)))) - (contents - (let loop ((next (read-char-or-special p))) - (cond - ((eof-object? next) null) - (else - (cons next (loop (read-char-or-special p))))))) - (repaired-contents - (map (lambda (x) - (if (string? x) - (marshall x) - (send (unbox x) copy))) - (chunk-string contents null)))) - (for-each - (lambda (x) - (send to-ed insert x this-pos)) - (reverse repaired-contents))) - (send to-ed end-edit-sequence) - (send from-ed end-edit-sequence))))))))) - menu)) + (define/override (get-menu) + (let ([menu (new popup-menu%)]) + (new menu-item% + (label "Convert to string") + (parent menu) + (callback + (lambda (x y) + (let ([to-ed (find-containing-editor)]) + (when to-ed + (let ([this-pos (find-this-position)]) + (when this-pos + (let ([from-ed (get-editor)]) + (send to-ed begin-edit-sequence) + (send from-ed begin-edit-sequence) + (send to-ed delete this-pos (+ this-pos 1)) + (let* ((p (open-input-text-editor from-ed 0 'end + (lambda (s) + (values (box s) 1)))) + (contents + (let loop ((next (read-char-or-special p))) + (cond + ((eof-object? next) null) + (else + (cons next (loop (read-char-or-special p))))))) + (repaired-contents + (map (lambda (x) + (if (string? x) + (marshall x) + (send (unbox x) copy))) + (chunk-string contents null)))) + (for-each + (lambda (x) + (send to-ed insert x this-pos)) + (reverse repaired-contents))) + (send to-ed end-edit-sequence) + (send from-ed end-edit-sequence))))))))) + menu)) - ;; find-containing-editor : -> (union #f editor) - (define/private (find-containing-editor) - (let ([admin (get-admin)]) - (and admin - (send admin get-editor)))) + ;; find-containing-editor : -> (union #f editor) + (define/private (find-containing-editor) + (let ([admin (get-admin)]) + (and admin + (send admin get-editor)))) - ;; find-this-position : -> (union #f number) - (define/private (find-this-position) - (let ([ed (find-containing-editor)]) - (and ed - (send ed get-snip-position this)))) + ;; find-this-position : -> (union #f number) + (define/private (find-this-position) + (let ([ed (find-containing-editor)]) + (and ed + (send ed get-snip-position this)))) - ;; input-port -> (union (listof char) char eof-object? syntax-object) - (define/private (get-next port) - (let ([v (read-char-or-special port)]) - (if (special-comment? v) - (get-next port) - v))) + ;; input-port -> (union (listof char) char eof-object? syntax-object) + (define/private (get-next port) + (let ([v (read-char-or-special port)]) + (if (special-comment? v) + (get-next port) + v))) - (define/public (read-special source line column position) - (let* ((ed (get-editor)) - (port (open-input-text-editor ed)) - (str (let loop ((next (get-next port))) - (cond - ((eof-object? next) null) - ((char? next) - (cons next (loop (get-next port)))) - (else (cons #`(marshall #,next) (loop (get-next port)))))))) - #`(let ((marshall - (lambda (s) - (let ((os (open-output-string))) - (with-handlers ((exn:fail? (lambda (x) ""))) - (display s os) - (get-output-string os)))))) - (string-append #,@(chunk-string str null))))) + (define/public (read-special source line column position) + (let* ((ed (get-editor)) + (port (open-input-text-editor ed)) + (str (let loop ((next (get-next port))) + (cond + ((eof-object? next) null) + ((char? next) + (cons next (loop (get-next port)))) + (else (cons #`(marshall #,next) (loop (get-next port)))))))) + #`(let ((marshall + (lambda (s) + (let ((os (open-output-string))) + (with-handlers ((exn:fail? (lambda (x) ""))) + (display s os) + (get-output-string os)))))) + (string-append #,@(chunk-string str null))))) - (super-instantiate ()) - (inherit set-snipclass) - (set-snipclass snipclass))) + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass snipclass))) diff --git a/collects/xml/xml-snipclass.rkt b/collects/xml/xml-snipclass.rkt index 65490f8b07..28594acfb7 100644 --- a/collects/xml/xml-snipclass.rkt +++ b/collects/xml/xml-snipclass.rkt @@ -7,27 +7,27 @@ (define xml-snip% (class* editor-snip% (xml-snip<%> readable-snip<%>) - (init-field eliminate-whitespace-in-empty-tags?) + (init-field eliminate-whitespace-in-empty-tags?) - (define/public (read-special file line col pos) - (xml-read-special eliminate-whitespace-in-empty-tags? - this - file - line - col - pos)) + (define/public (read-special file line col pos) + (xml-read-special eliminate-whitespace-in-empty-tags? + this + file + line + col + pos)) - (super-new))) + (super-new))) (define xml-snipclass% (class snip-class% - (define/override (read stream-in) - (let* ([eliminate-whitespace-in-empty-tags? (zero? (send stream-in get-exact))] - [snip (instantiate xml-snip% () - (eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?))]) - (send (send snip get-editor) read-from-file stream-in #f) - snip)) - (super-new))) + (define/override (read stream-in) + (let* ([eliminate-whitespace-in-empty-tags? (zero? (send stream-in get-exact))] + [snip (instantiate xml-snip% () + (eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?))]) + (send (send snip get-editor) read-from-file stream-in #f) + snip)) + (super-new))) (define snip-class (make-object xml-snipclass%)) (send snip-class set-version 1)