From 9b2426be7f94a239a43bcb4e55931e3c08812e97 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 18 Jan 2007 12:15:32 +0000 Subject: [PATCH] text-box class name changed to a lib path (not completely backward compatible) svn: r5389 --- collects/xml/text-box-tool.ss | 123 +----------------------------- collects/xml/text-snipclass.ss | 133 +++++++++++++++++++++++++++++++++ 2 files changed, 134 insertions(+), 122 deletions(-) create mode 100644 collects/xml/text-snipclass.ss diff --git a/collects/xml/text-box-tool.ss b/collects/xml/text-box-tool.ss index 78fd796005..404df11b26 100644 --- a/collects/xml/text-box-tool.ss +++ b/collects/xml/text-box-tool.ss @@ -2,6 +2,7 @@ (require (lib "tool.ss" "drscheme") (lib "mred.ss" "mred") (lib "framework.ss" "framework") + "text-snipclass.ss" (lib "unit.ss") (lib "class.ss") (lib "contract.ss") @@ -10,134 +11,12 @@ (provide tool@) - ;; chunk-string: (listof any) -> (listof any) - (define (chunk-string s acc) - (cond - ((and (null? s) (null? acc)) null) - ((null? s) (list (list->string (reverse acc)))) - ((char? (car s)) (chunk-string (cdr s) (cons (car s) acc))) - ((null? acc) (cons (car s) (chunk-string (cdr s) null))) - (else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null)))))) - - ;; marshall: writable -> string - (define (marshall s) - (let ((os (open-output-string))) - (with-handlers ((exn:fail? (lambda (x) ""))) - (write s os) - (get-output-string os)))) - - (define icon - (let* ((x (make-object bitmap% 10 10)) - (y (make-object bitmap-dc% x))) - (send y set-font (make-object font% 24 'default 'normal 'normal )) - (send y draw-text "\"" 0 0) - x)) - (define tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) (define (phase1) (void)) (define (phase2) (void)) - - (define snipclass-text-box% - (class decorated-editor-snipclass% - (define/override (make-snip stream-in) (new text-box%)) - (super-instantiate ()))) - - (define snipclass (new snipclass-text-box%)) - (send snipclass set-version 1) - (send snipclass set-classname "text-box%") - (send (get-the-snip-class-list) add snipclass) - - (define text-box% - (class* decorated-editor-snip% (readable-snip<%>) - (define/override (make-editor) (new text:keymap%)) - (define/override (make-snip) (make-object text-box%)) - (inherit get-editor get-admin) - - - (define/override (get-corner-bitmap) - 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)) - - ;; 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)))) - - ;; 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))))) - - (super-instantiate ()) - (inherit set-snipclass) - (set-snipclass snipclass))) - (define (text-box-mixin %) (class % diff --git a/collects/xml/text-snipclass.ss b/collects/xml/text-snipclass.ss new file mode 100644 index 0000000000..0a7498fa3f --- /dev/null +++ b/collects/xml/text-snipclass.ss @@ -0,0 +1,133 @@ +(module text-snipclass mzscheme + (require (lib "framework.ss" "framework") + (lib "class.ss") + (lib "mred.ss" "mred")) + + (provide text-box% + (rename snipclass snip-class)) + + ;; chunk-string: (listof any) -> (listof any) + (define (chunk-string s acc) + (cond + ((and (null? s) (null? acc)) null) + ((null? s) (list (list->string (reverse acc)))) + ((char? (car s)) (chunk-string (cdr s) (cons (car s) acc))) + ((null? acc) (cons (car s) (chunk-string (cdr s) null))) + (else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null)))))) + + (define icon + (let* ((x (make-object bitmap% 10 10)) + (y (make-object bitmap-dc% x))) + (send y set-font (make-object font% 24 'default 'normal 'normal )) + (send y draw-text "\"" 0 0) + x)) + + ;; marshall: writable -> string + (define (marshall s) + (let ((os (open-output-string))) + (with-handlers ((exn:fail? (lambda (x) ""))) + (write s os) + (get-output-string os)))) + + (define snipclass-text-box% + (class decorated-editor-snipclass% + (define/override (make-snip stream-in) (new text-box%)) + (super-instantiate ()))) + + (define old-snipclass (new snipclass-text-box%)) + (send old-snipclass set-version 1) + (send old-snipclass set-classname "text-box%") + (send (get-the-snip-class-list) add old-snipclass) + + (define snipclass (new snipclass-text-box%)) + (send snipclass set-version 1) + (send snipclass set-classname (format "~s" '(lib "text-snipclass.ss" "xml"))) + (send (get-the-snip-class-list) add snipclass) + + (define text-box% + (class* decorated-editor-snip% (readable-snip<%>) + (define/override (make-editor) (new text:keymap%)) + (define/override (make-snip) (make-object text-box%)) + (inherit get-editor get-admin) + + + (define/override (get-corner-bitmap) + 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)) + + ;; 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)))) + + ;; 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))))) + + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass snipclass))))