text-box class name changed to a lib path (not completely backward compatible)
svn: r5389
This commit is contained in:
Matthew Flatt
parent
4fe1f82d1b
commit
9b2426be7f
|
|
@ -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 %
|
||||
|
|
|
|||
133
collects/xml/text-snipclass.ss
Normal file
133
collects/xml/text-snipclass.ss
Normal file
|
|
@ -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))))
|
||||
Loading…
Reference in New Issue
Block a user