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

added insert/io

Browse Source 
original commit: fc492049564ce0b7d2a3b6f889f4e9b86aef6ed4
This commit is contained in:
Robby Findler 2014-07-16 09:47:41 -05:00
parent 5672033374
commit 86b2e602a8
3 changed files with 48 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/gui-pkgs/gui-doc/scribblings/framework/text.scrbl
View File

@ -963,7 +963,19 @@
Both @racket[start] and @racket[end] must be less than
@method[text:ports<%> get-insertion-point] (or else it is safe to delete
them so you don't need this method).
them via @method[text% delete], so you don't need this method).
}
@defmethod[(insert/io [str string?] [pos exact-integer?]) void?]{
Inserts @racket[str] at the position @racket[start] without changing
the behavior of the ports (otherwise, inserting the text would break
internal invariants of the port).
The @racket[pos] argument must be less than
@method[text:ports<%> get-insertion-point] (or else it is safe to insert
the string via @method[text% insert], so you don't need this method).
@history[#:added "1.2"]
}
@defmethod[(do-submission) void?]{

52
pkgs/gui-pkgs/gui-lib/framework/private/text.rkt
View File

@ -2340,6 +2340,20 @@
(delete start end #f)
(set! allow-edits? before-allowed?)))
(define/public-final (insert/io str start [style #f])
(unless (<= start insertion-point)
(error 'insert/io "expected start (~a) <= insertion-point (~a)"
start (string-length str) insertion-point))
(define len (string-length str))
(set! insertion-point (+ insertion-point len))
(set! unread-start-point (+ unread-start-point len))
(let ([before-allowed? allow-edits?])
(set! allow-edits? #t)
(insert str start start #f)
(when style
(change-style (add-standard style) start (+ start len)))
(set! allow-edits? before-allowed?)))
(define/public-final (get-in-port)
(unless in-port (error 'get-in-port "not ready"))
in-port)
@ -2719,24 +2733,9 @@
(channel-put write-chan (cons #f to-send))])
#t))
(let* ([add-standard
(λ (sd)
(cond
[(string? sd)
(let ([style-list (get-style-list)])
(or (send style-list find-named-style sd)
(send style-list find-named-style "Standard")
(send style-list basic-style)))]
[sd
(let* ([style-list (get-style-list)]
[std (send style-list find-named-style "Standard")])
(if std
(send style-list find-or-create-style std sd)
(let ([basic (send style-list basic-style)])
(send style-list find-or-create-style basic sd))))]))]
[out-style (add-standard (get-out-style-delta))]
[err-style (add-standard (get-err-style-delta))]
[value-style (add-standard (get-value-style-delta))])
(let ([out-style (add-standard (get-out-style-delta))]
[err-style (add-standard (get-err-style-delta))]
[value-style (add-standard (get-value-style-delta))])
(set! out-port (make-output-port #f
always-evt
(make-write-bytes-proc out-style)
@ -2763,6 +2762,23 @@
(install-handlers err-port)
(install-handlers value-port))))
(define/private (add-standard sd)
(cond
[(string? sd)
(define style-list (get-style-list))
(or (send style-list find-named-style sd)
(send style-list find-named-style "Standard")
(send style-list basic-style))]
[sd
(define style-list (get-style-list))
(define std (send style-list find-named-style "Standard"))
(cond
[std
(send style-list find-or-create-style std sd)]
[else
(define basic (send style-list basic-style))
(send style-list find-or-create-style basic sd)])]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; helpers

2
pkgs/gui-pkgs/gui-lib/info.rkt
View File

@ -29,4 +29,4 @@
(define pkg-authors '(mflatt))
(define version "1.1")
(define version "1.2")