suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: c601fcdf5605489847ac3f277b4358441484c103
This commit is contained in:
Robby Findler 2004-06-22 14:32:51 +00:00
parent ff5a41e4ab
commit 3849d8bd4d
1 changed files with 73 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
collects/framework/private/text.ss
View File

@ -249,10 +249,9 @@ WARNING: printf is rebound in the body of the unit to always
(cons (car r) (loop (cdr r))))]))) (cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles) (recompute-range-rectangles)
(invalidate-rectangles old-rectangles)))))) (invalidate-rectangles old-rectangles))))))
(rename [super-on-paint on-paint])
(override on-paint) (override on-paint)
(define (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (define (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles) (recompute-range-rectangles)
(let ([b1 (box 0)] (let ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
@ -320,19 +319,17 @@ WARNING: printf is rebound in the body of the unit to always
(define (get-styles-fixed) styles-fixed?) (define (get-styles-fixed) styles-fixed?)
(define (set-styles-fixed b) (set! styles-fixed? b)) (define (set-styles-fixed b) (set! styles-fixed? b))
(rename [super-on-insert on-insert] (define/augment (on-insert start len)
[super-after-insert after-insert]) (inner (void) on-insert start len)
(define/override (on-insert start len) (begin-edit-sequence))
(begin-edit-sequence) (define/augment (after-insert start len)
(super-on-insert start len))
(define/override (after-insert start len)
(when styles-fixed? (when styles-fixed?
(change-style (send (get-style-list) find-named-style "Standard") (change-style (send (get-style-list) find-named-style "Standard")
start start
(+ start len) (+ start len)
#f)) #f))
(super-after-insert start len) (end-edit-sequence)
(end-edit-sequence)) (inner (void) after-insert start len))
(public move/copy-to-edit) (public move/copy-to-edit)
(define (move/copy-to-edit dest-edit start end dest-position) (define (move/copy-to-edit dest-edit start end dest-position)
@ -363,10 +360,11 @@ WARNING: printf is rebound in the body of the unit to always
(define hide-caret/selection<%> (interface (basic<%>))) (define hide-caret/selection<%> (interface (basic<%>)))
(define hide-caret/selection-mixin (define hide-caret/selection-mixin
(mixin (basic<%>) (hide-caret/selection<%>) (mixin (basic<%>) (hide-caret/selection<%>)
(override after-set-position)
(inherit get-start-position get-end-position hide-caret) (inherit get-start-position get-end-position hide-caret)
(define (after-set-position) (define/augment (after-set-position)
(hide-caret (= (get-start-position) (get-end-position)))) ;; >>> super was not here <<<
(hide-caret (= (get-start-position) (get-end-position)))
(inner (void) after-set-position))
(super-instantiate ()))) (super-instantiate ())))
(define nbsp->space<%> (interface ((class->interface text%)))) (define nbsp->space<%> (interface ((class->interface text%))))
@ -374,13 +372,11 @@ WARNING: printf is rebound in the body of the unit to always
(mixin ((class->interface text%)) (nbsp->space<%>) (mixin ((class->interface text%)) (nbsp->space<%>)
(field [rewriting #f]) (field [rewriting #f])
(inherit begin-edit-sequence end-edit-sequence delete insert get-character) (inherit begin-edit-sequence end-edit-sequence delete insert get-character)
(rename [super-on-insert on-insert] (define/augment (on-insert start len)
[super-after-insert after-insert]) (inner (void) on-insert start len)
(define/override (on-insert start len) (begin-edit-sequence))
(begin-edit-sequence)
(super-on-insert start len))
(inherit find-string) (inherit find-string)
(define/override (after-insert start len) (define/augment (after-insert start len)
(unless rewriting (unless rewriting
(set! rewriting #t) (set! rewriting #t)
(let ([str (string (integer->char 160))] (let ([str (string (integer->char 160))]
@ -393,24 +389,22 @@ WARNING: printf is rebound in the body of the unit to always
(insert " " next-pos next-pos #f) (insert " " next-pos next-pos #f)
(loop (+ next-pos 1))))))) (loop (+ next-pos 1)))))))
(set! rewriting #f)) (set! rewriting #f))
(super-after-insert start len) (end-edit-sequence)
(end-edit-sequence)) (inner (void) after-insert start len))
(super-instantiate ()))) (super-instantiate ())))
(define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching<%> (interface (editor:keymap<%> basic<%>)))
(define searching-mixin (define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>) (mixin (editor:keymap<%> basic<%>) (searching<%>)
(rename [super-get-keymaps get-keymaps])
(override get-keymaps) (override get-keymaps)
(define (get-keymaps) (define (get-keymaps)
(cons (keymap:get-search) (super-get-keymaps))) (cons (keymap:get-search) (super get-keymaps)))
(super-instantiate ()))) (super-instantiate ())))
(define return<%> (interface ((class->interface text%)))) (define return<%> (interface ((class->interface text%))))
(define return-mixin (define return-mixin
(mixin ((class->interface text%)) (return<%>) (mixin ((class->interface text%)) (return<%>)
(init-field return) (init-field return)
(rename [super-on-local-char on-local-char])
(override on-local-char) (override on-local-char)
(define (on-local-char key) (define (on-local-char key)
(let ([cr-code #\return] (let ([cr-code #\return]
@ -420,7 +414,7 @@ WARNING: printf is rebound in the body of the unit to always
(or (char=? lf-code code) (or (char=? lf-code code)
(char=? cr-code code)) (char=? cr-code code))
(return)) (return))
(super-on-local-char key)))) (super on-local-char key))))
(super-instantiate ()))) (super-instantiate ())))
(define delegate<%> (interface (basic<%>) (define delegate<%> (interface (basic<%>)
@ -484,10 +478,9 @@ WARNING: printf is rebound in the body of the unit to always
(define cache-function #f) (define cache-function #f)
(rename [super-insert insert])
(define/override (insert s len pos) (define/override (insert s len pos)
(set! cache-function #f) (set! cache-function #f)
(super-insert s len pos)) (super insert s len pos))
;; for-each/sections : string -> dc number number -> void ;; for-each/sections : string -> dc number number -> void
(define (for-each/sections str) (define (for-each/sections str)
@ -634,10 +627,9 @@ WARNING: printf is rebound in the body of the unit to always
(send delegate lock #t) (send delegate lock #t)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence)))
(rename [super-highlight-range highlight-range])
(define/override highlight-range (define/override highlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low]) (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
(let ([res (super-highlight-range start end color bitmap caret-space? priority)]) (let ([res (super highlight-range start end color bitmap caret-space? priority)])
(if delegate (if delegate
(let ([delegate-res (send delegate highlight-range (let ([delegate-res (send delegate highlight-range
start end color bitmap caret-space? priority)]) start end color bitmap caret-space? priority)])
@ -646,30 +638,26 @@ WARNING: printf is rebound in the body of the unit to always
(delegate-res))) (delegate-res)))
res)))) res))))
(rename [super-on-paint on-paint])
(inherit get-canvases get-active-canvas has-focus?) (inherit get-canvases get-active-canvas has-focus?)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret?) (define/override (on-paint before? dc left top right bottom dx dy draw-caret?)
(super-on-paint before? dc left top right bottom dx dy draw-caret?) (super on-paint before? dc left top right bottom dx dy draw-caret?)
(unless before? (unless before?
(let ([active-canvas (get-active-canvas)]) (let ([active-canvas (get-active-canvas)])
(when active-canvas (when active-canvas
(send (send active-canvas get-top-level-window) delegate-moved))))) (send (send active-canvas get-top-level-window) delegate-moved)))))
(rename [super-on-edit-sequence on-edit-sequence]) (define/augment (on-edit-sequence)
(define/override (on-edit-sequence)
(super-on-edit-sequence)
(when delegate (when delegate
(send delegate begin-edit-sequence))) (send delegate begin-edit-sequence))
(inner (void) on-edit-sequence))
(rename [super-after-edit-sequence after-edit-sequence]) (define/augment (after-edit-sequence)
(define/override (after-edit-sequence)
(super-after-edit-sequence)
(when delegate (when delegate
(send delegate end-edit-sequence))) (send delegate end-edit-sequence))
(inner (void) after-edit-sequence))
(rename [super-resized resized])
(define/override (resized snip redraw-now?) (define/override (resized snip redraw-now?)
(super-resized snip redraw-now?) (super resized snip redraw-now?)
(when (and delegate (when (and delegate
linked-snips linked-snips
(not (is-a? snip string-snip%))) (not (is-a? snip string-snip%)))
@ -677,9 +665,7 @@ WARNING: printf is rebound in the body of the unit to always
(when delegate-copy (when delegate-copy
(send delegate resized delegate-copy redraw-now?))))) (send delegate resized delegate-copy redraw-now?)))))
(rename [super-after-insert after-insert]) (define/augment (after-insert start len)
(define/override (after-insert start len)
(super-after-insert start len)
(when delegate (when delegate
(send delegate begin-edit-sequence) (send delegate begin-edit-sequence)
(send delegate lock #f) (send delegate lock #f)
@ -691,21 +677,19 @@ WARNING: printf is rebound in the body of the unit to always
(send delegate insert (copy snip) start start) (send delegate insert (copy snip) start start)
(loop (send snip previous))))) (loop (send snip previous)))))
(send delegate lock #t) (send delegate lock #t)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence))
(inner (void) after-insert start len))
(rename [super-after-delete after-delete]) (define/augment (after-delete start len)
(define/override (after-delete start len)
(super-after-delete start len)
(when delegate (when delegate
(send delegate lock #f) (send delegate lock #f)
(send delegate begin-edit-sequence) (send delegate begin-edit-sequence)
(send delegate delete start (+ start len)) (send delegate delete start (+ start len))
(send delegate end-edit-sequence) (send delegate end-edit-sequence)
(send delegate lock #t))) (send delegate lock #t))
(inner (void) after-delete start len))
(rename [super-after-change-style after-change-style]) (define/augment (after-change-style start len)
(define/override (after-change-style start len)
(super-after-change-style start len)
(when delegate (when delegate
(send delegate begin-edit-sequence) (send delegate begin-edit-sequence)
(send delegate lock #f) (send delegate lock #f)
@ -717,20 +701,19 @@ WARNING: printf is rebound in the body of the unit to always
style delegate-style-delta)]) style delegate-style-delta)])
(send delegate change-style style start (+ start len))) (send delegate change-style style start (+ start len)))
(send delegate lock #f) (send delegate lock #f)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence))
(inner (void) after-change-style start len))
(define filename #f) (define filename #f)
(define format #f) (define format #f)
(rename [super-on-load-file on-load-file] (define/augment (on-load-file _filename _format)
[super-after-load-file after-load-file])
(define/override (on-load-file _filename _format)
(super-on-load-file _filename _format)
(set! filename _filename) (set! filename _filename)
(set! format _format)) (set! format _format)
(define/override (after-load-file success?) (inner (void) on-load-file _filename _format))
(super-after-load-file success?) (define/augment (after-load-file success?)
(when success? (when success?
(refresh-delegate))) (refresh-delegate))
(inner (void) after-load-file success?))
(super-instantiate ()))) (super-instantiate ())))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))
@ -739,13 +722,6 @@ WARNING: printf is rebound in the body of the unit to always
(mixin (editor:keymap<%> basic<%>) (info<%>) (mixin (editor:keymap<%> basic<%>) (info<%>)
(inherit get-start-position get-end-position get-canvas (inherit get-start-position get-end-position get-canvas
run-after-edit-sequence) run-after-edit-sequence)
(rename [super-after-set-position after-set-position]
[super-after-edit-sequence after-edit-sequence]
[super-on-edit-sequence on-edit-sequence]
[super-after-insert after-insert]
[super-after-delete after-delete]
[super-set-overwrite-mode set-overwrite-mode]
[super-set-anchor set-anchor])
(define (enqueue-for-frame call-method tag) (define (enqueue-for-frame call-method tag)
(run-after-edit-sequence (run-after-edit-sequence
(rec from-enqueue-for-frame (rec from-enqueue-for-frame
@ -762,20 +738,22 @@ WARNING: printf is rebound in the body of the unit to always
(when (is-a? frame frame:text-info<%>) (when (is-a? frame frame:text-info<%>)
(call-method frame)))))) (call-method frame))))))
(override set-anchor set-overwrite-mode after-set-position after-insert after-delete) (override set-anchor set-overwrite-mode)
(augment after-set-position after-insert after-delete)
(define (set-anchor x) (define (set-anchor x)
(super-set-anchor x) (super set-anchor x)
(enqueue-for-frame (enqueue-for-frame
(lambda (x) (send x anchor-status-changed)) (lambda (x) (send x anchor-status-changed))
'framework:anchor-status-changed)) 'framework:anchor-status-changed))
(define (set-overwrite-mode x) (define (set-overwrite-mode x)
(super-set-overwrite-mode x) (super set-overwrite-mode x)
(enqueue-for-frame (enqueue-for-frame
(lambda (x) (send x overwrite-status-changed)) (lambda (x) (send x overwrite-status-changed))
'framework:overwrite-status-changed)) 'framework:overwrite-status-changed))
(define (after-set-position) (define (after-set-position)
(super-after-set-position) (maybe-queue-editor-position-update)
(maybe-queue-editor-position-update)) (inner (void) after-set-position))
;; maybe-queue-editor-position-update : -> void ;; maybe-queue-editor-position-update : -> void
;; updates the editor-position in the frame, ;; updates the editor-position in the frame,
@ -794,11 +772,11 @@ WARNING: printf is rebound in the body of the unit to always
'framework:info-frame:update-editor-position)) 'framework:info-frame:update-editor-position))
(define (after-insert start len) (define (after-insert start len)
(super-after-insert start len) (maybe-queue-editor-position-update)
(maybe-queue-editor-position-update)) (inner (void) after-insert start len))
(define (after-delete start len) (define (after-delete start len)
(super-after-delete start len) (maybe-queue-editor-position-update)
(maybe-queue-editor-position-update)) (inner (void) after-delete start len))
(super-instantiate ()))) (super-instantiate ())))
(define clever-file-format<%> (interface ((class->interface text%)))) (define clever-file-format<%> (interface ((class->interface text%))))
@ -806,7 +784,6 @@ WARNING: printf is rebound in the body of the unit to always
(define clever-file-format-mixin (define clever-file-format-mixin
(mixin ((class->interface text%)) (clever-file-format<%>) (mixin ((class->interface text%)) (clever-file-format<%>)
(inherit get-file-format set-file-format find-first-snip) (inherit get-file-format set-file-format find-first-snip)
(rename [super-on-save-file on-save-file])
(define (all-string-snips) (define (all-string-snips)
(let loop ([s (find-first-snip)]) (let loop ([s (find-first-snip)])
(cond (cond
@ -814,7 +791,7 @@ WARNING: printf is rebound in the body of the unit to always
[(is-a? s string-snip%) [(is-a? s string-snip%)
(loop (send s next))] (loop (send s next))]
[else #f]))) [else #f])))
(define/override (on-save-file name format) (define/augment (on-save-file name format)
(let ([all-strings? (all-string-snips)]) (let ([all-strings? (all-string-snips)])
(cond (cond
[(and all-strings? [(and all-strings?
@ -836,7 +813,7 @@ WARNING: printf is rebound in the body of the unit to always
(string-constant no)))) (string-constant no))))
(set-file-format 'standard)] (set-file-format 'standard)]
[else (void)])) [else (void)]))
(super-on-save-file name format)) (inner (void) on-save-file name format))
(super-instantiate ()))) (super-instantiate ())))
(define ports<%> (define ports<%>
@ -958,19 +935,16 @@ WARNING: printf is rebound in the body of the unit to always
;; editor integration ;; editor integration
;; ;;
(rename [super-can-insert? can-insert?]) (define/augment (can-insert? start len)
(define/override (can-insert? start len) (and (or allow-edits?
(and (super-can-insert? start len) (start . >= . insertion-point))
(or allow-edits? (inner #t can-insert? start len)))
(start . >= . insertion-point))))
(rename [super-can-delete? can-delete?]) (define/augment (can-delete? start len)
(define/override (can-delete? start len) (and (or allow-edits?
(and (super-can-delete? start len) (start . >= . insertion-point))
(or allow-edits? (inner #t can-delete? start len)))
(start . >= . insertion-point))))
(rename [super-on-local-char on-local-char])
(define/override (on-local-char key) (define/override (on-local-char key)
(let ([start (get-start-position)] (let ([start (get-start-position)]
[end (get-end-position)] [end (get-end-position)]
@ -979,7 +953,7 @@ WARNING: printf is rebound in the body of the unit to always
[(not (or (eq? code 'numpad-enter) [(not (or (eq? code 'numpad-enter)
(equal? code #\return) (equal? code #\return)
(equal? code #\newline))) (equal? code #\newline)))
(super-on-local-char key)] (super on-local-char key)]
[(and (insertion-point . <= . start) [(and (insertion-point . <= . start)
(= start end) (= start end)
(submit-to-port? key)) (submit-to-port? key))
@ -993,13 +967,13 @@ WARNING: printf is rebound in the body of the unit to always
(bytes->list (string->bytes/utf-8 (string s/c))))])) (bytes->list (string->bytes/utf-8 (string s/c))))]))
snips/chars) snips/chars)
(set! allow-tabify? #f) (set! allow-tabify? #f)
(super-on-local-char key) (super on-local-char key)
(set! allow-tabify? #t) (set! allow-tabify? #t)
(set! unread-start-point (last-position)) (set! unread-start-point (last-position))
(set! insertion-point (last-position)) (set! insertion-point (last-position))
(on-submit))] (on-submit))]
[else [else
(super-on-local-char key)]))) (super on-local-char key)])))
(define allow-tabify? #t) (define allow-tabify? #t)
; (rename [super-tabify-on-return? tabify-on-return?]) ; (rename [super-tabify-on-return? tabify-on-return?])
@ -1071,7 +1045,6 @@ WARNING: printf is rebound in the body of the unit to always
(lock locked?) (lock locked?)
(end-edit-sequence))) (end-edit-sequence)))
(define output-buffer-thread (define output-buffer-thread
(let ([buffer-full 40] (let ([buffer-full 40]
[converter (bytes-open-converter "UTF-8-permissive" "UTF-8")]) [converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
@ -1118,10 +1091,11 @@ WARNING: printf is rebound in the body of the unit to always
(define (make-write-bytes-proc style) (define (make-write-bytes-proc style)
(lambda (to-write start end block/buffer? enable-breaks?) (lambda (to-write start end block/buffer? enable-breaks?)
(cond (cond
[(eq? (current-thread) (eventspace-handler-thread eventspace)) [(= start end) (flush-proc)]
(error 'write-bytes-proc "cannot write to port on eventspace main thread")] [(eq? (current-thread) (eventspace-handler-thread eventspace))
[else (error 'write-bytes-proc "cannot write to port on eventspace main thread")]
(channel-put write-chan (cons (subbytes to-write start end) style))]) [else
(channel-put write-chan (cons (subbytes to-write start end) style))])
(- end start))) (- end start)))
(define (flush-proc) (define (flush-proc)