95841b9303
cannot change its revision number during reading This restriction was enforced only for editors that have non string-snip% snips. The restriction was in place because the implementation strategy was to chain thru the snips in the editor using (send snip next) and that isn't safe if the revision number changes. The lifting of the restriction is implemented by tracking the position in the editor where the last snip ended and, if the revision number changes, starting over trying to get a snip from that position. This has the effect that, if the revision number never changes, the code should behave the same as it was doing before (so hopefully any new bugs I've introduced in this commit will only show up if the old implementation would have raised an error) Also, exploit the lifting of this restriction in the colorer so it doesn't to restart the port during to coloring that happens along with the parsing
416 lines
20 KiB
Racket
416 lines
20 KiB
Racket
(module snipfile racket/base
|
|
(require racket/class
|
|
racket/port
|
|
syntax/moddep
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: racket/snip/private/snip)
|
|
"check.rkt"
|
|
"editor.rkt")
|
|
|
|
(provide open-input-text-editor
|
|
open-input-graphical-file
|
|
text-editor-load-handler
|
|
open-output-text-editor)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define empty-string (make-bytes 0))
|
|
|
|
;; open-input-text-editor : (instanceof text%) num num -> input-port
|
|
;; creates a user port whose input is taken from the text%,
|
|
;; starting at position `start-in'
|
|
;; and ending at position `end'.
|
|
(define open-input-text-editor
|
|
(lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f]
|
|
#:lock-while-reading? [lock-while-reading? #f])
|
|
;; Check arguments:
|
|
(unless (text . is-a? . text%)
|
|
(raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text))
|
|
(check-non-negative-integer 'open-input-text-editor start)
|
|
(unless (or (eq? end 'end)
|
|
(and (integer? end) (exact? end) (not (negative? end))))
|
|
(raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end))
|
|
(let ([last (send text last-position)])
|
|
(when (start . > . last)
|
|
(raise-range-error 'open-input-text-editor "editor" "starting "
|
|
start text 0 last #f))
|
|
(unless (eq? end 'end)
|
|
(unless (<= start end last)
|
|
(raise-range-error 'open-input-text-editor "editor" "ending "
|
|
end text start last 0))))
|
|
(let ([end (if (eq? end 'end) (send text last-position) end)]
|
|
[snip (send text find-snip start 'after-or-none)])
|
|
;; If the region is small enough, and if the editor contains
|
|
;; only string snips, then it's probably better to move
|
|
;; all of the text into a string port:
|
|
(if (or (not snip)
|
|
(and (is-a? snip wx:string-snip%)
|
|
(let ([s (send text find-next-non-string-snip snip)])
|
|
(or (not s)
|
|
((send text get-snip-position s) . >= . end)))))
|
|
(if (or expect-to-read-all?
|
|
((- end start) . < . 4096))
|
|
;; It's all text, and it's short enough: just read it into a string
|
|
(open-input-string (send text get-text start end) port-name)
|
|
;; It's all text, so the reading process is simple:
|
|
(let ([start start])
|
|
(when lock-while-reading?
|
|
(send text begin-edit-sequence)
|
|
(send text lock #t))
|
|
(let-values ([(pipe-r pipe-w) (make-pipe)])
|
|
(make-input-port/read-to-peek
|
|
port-name
|
|
(lambda (s)
|
|
(let ([v (read-bytes-avail!* s pipe-r)])
|
|
(if (eq? v 0)
|
|
(let ([n (min 4096 (- end start))])
|
|
(if (zero? n)
|
|
(begin
|
|
(close-output-port pipe-w)
|
|
(when lock-while-reading?
|
|
(set! lock-while-reading? #f)
|
|
(send text lock #f)
|
|
(send text end-edit-sequence))
|
|
eof)
|
|
(begin
|
|
(write-string (send text get-text start (+ start n)) pipe-w)
|
|
(set! start (+ start n))
|
|
(let ([ans (read-bytes-avail!* s pipe-r)])
|
|
(when lock-while-reading?
|
|
(when (eof-object? ans)
|
|
(set! lock-while-reading? #f)
|
|
(send text lock #f)
|
|
(send text edit-edit-sequence)))
|
|
ans))))
|
|
v)))
|
|
(lambda (s skip general-peek)
|
|
(let ([v (peek-bytes-avail!* s skip #f pipe-r)])
|
|
(if (eq? v 0)
|
|
(general-peek s skip)
|
|
v)))
|
|
void))))
|
|
;; General case, which handles non-text context:
|
|
(with-method ([gsp (text get-snip-position)]
|
|
[grn (text get-revision-number)]
|
|
[fs (text find-snip)])
|
|
(let-values ([(pipe-r pipe-w) (make-pipe)])
|
|
(let* ([get-text-generic (generic wx:snip% get-text)]
|
|
[get-count-generic (generic wx:snip% get-count)]
|
|
[next-generic (generic wx:snip% next)]
|
|
[revision (grn)]
|
|
[next? #f]
|
|
[snip-end-position (+ (gsp snip) (send-generic snip get-count-generic))]
|
|
[update-str-to-snip
|
|
(lambda (skip to-str)
|
|
(if snip
|
|
(let ([snip-start (gsp snip)])
|
|
(cond
|
|
[(snip-start . >= . end)
|
|
(set! snip #f)
|
|
(set! next? #f)
|
|
0]
|
|
[(is-a? snip wx:string-snip%)
|
|
(set! next? #t)
|
|
(let ([c (min (- (send-generic snip get-count-generic) skip)
|
|
(- end snip-start))])
|
|
(write-string (send-generic snip get-text-generic skip c) pipe-w)
|
|
(read-bytes-avail!* to-str pipe-r))]
|
|
[else
|
|
(set! next? #f)
|
|
0]))
|
|
(begin
|
|
(set! next? #f)
|
|
0)))]
|
|
[next-snip
|
|
(lambda (to-str)
|
|
(cond
|
|
[(= revision (grn))
|
|
(set! snip (send-generic snip next-generic))
|
|
(set! snip-end-position (and snip (+ (gsp snip) (send-generic snip get-count-generic))))
|
|
(update-str-to-snip 0 to-str)]
|
|
[else
|
|
(set! revision (grn))
|
|
(define old-snip-end-position snip-end-position)
|
|
(set! snip (fs snip-end-position 'after-or-none))
|
|
(define snip-start-position (and snip (gsp snip)))
|
|
(set! snip-end-position (and snip (+ snip-start-position (send-generic snip get-count-generic))))
|
|
(update-str-to-snip (if snip (- old-snip-end-position snip-start-position) 0) to-str)]))]
|
|
[read-chars (lambda (to-str)
|
|
(cond
|
|
[next?
|
|
(next-snip to-str)]
|
|
[snip
|
|
(let ([the-snip (snip-filter snip)])
|
|
(next-snip empty-string)
|
|
(lambda (file line col ppos)
|
|
(if (is-a? the-snip wx:snip%)
|
|
(if (is-a? the-snip wx:readable-snip<%>)
|
|
(send the-snip read-special file line col ppos)
|
|
(send the-snip copy))
|
|
the-snip)))]
|
|
[else eof]))]
|
|
[close (lambda () (void))]
|
|
[port (make-input-port/read-to-peek
|
|
port-name
|
|
(lambda (s)
|
|
(let* ([v (read-bytes-avail!* s pipe-r)]
|
|
[res (if (eq? v 0) (read-chars s) v)])
|
|
(when (eof-object? res)
|
|
(when lock-while-reading?
|
|
(set! lock-while-reading? #f)
|
|
(send text lock #f)
|
|
(send text end-edit-sequence)))
|
|
res))
|
|
(lambda (s skip general-peek)
|
|
(let ([v (peek-bytes-avail!* s skip #f pipe-r)])
|
|
(if (eq? v 0)
|
|
(general-peek s skip)
|
|
v)))
|
|
close)])
|
|
(when lock-while-reading?
|
|
(send text begin-edit-sequence)
|
|
(send text lock #t))
|
|
(if (is-a? snip wx:string-snip%)
|
|
;; Special handling for initial snip string in
|
|
;; case it starts too early:
|
|
(let* ([snip-start (gsp snip)]
|
|
[skip (- start snip-start)]
|
|
[c (min (- (send-generic snip get-count-generic) skip)
|
|
(- end snip-start))])
|
|
(set! next? #t)
|
|
(display (send-generic snip get-text-generic skip c) pipe-w))
|
|
(update-str-to-snip 0 empty-string))
|
|
port)))))))
|
|
|
|
(define (jump-to-submodule in-port expected-module k)
|
|
(let ([header (bytes-append #"^#~"
|
|
(bytes (string-length (version)))
|
|
(regexp-quote (string->bytes/utf-8 (version)))
|
|
#"D")])
|
|
(cond
|
|
[(regexp-match-peek header in-port)
|
|
;; The input has a submodule table:
|
|
(define encoded-expected
|
|
(apply bytes-append
|
|
(for/list ([n (in-list (if (pair? expected-module)
|
|
(cdr expected-module)
|
|
'()))])
|
|
(define s (string->bytes/utf-8 (symbol->string n)))
|
|
(define l (bytes-length s))
|
|
(bytes-append (if (l . < . 255)
|
|
(bytes l)
|
|
(bytes 255
|
|
(bitwise-and l 255)
|
|
(bitwise-and (arithmetic-shift l -8) 255)
|
|
(bitwise-and (arithmetic-shift l -16) 255)
|
|
(bitwise-and (arithmetic-shift l -24) 255)))
|
|
s))))
|
|
(define (skip-bytes amt)
|
|
(if (file-stream-port? in-port)
|
|
(file-position in-port (+ (file-position in-port) amt))
|
|
(read-bytes amt in-port)))
|
|
(define len (+ 2 1 (string-length (version)) 1 4)) ; 4 for table count
|
|
(skip-bytes len)
|
|
(let loop ([pos len])
|
|
;; Each node in the table's btree is <name-len> <name> <start> <len> <left> <right>
|
|
(define (read-num)
|
|
(integer-bytes->integer (read-bytes 4 in-port) #f #f))
|
|
(define len (read-num))
|
|
(define new-pos (+ pos 4))
|
|
(define name (read-bytes len in-port))
|
|
(define code-start (read-num))
|
|
(define code-len (read-num))
|
|
(define left (read-num))
|
|
(define right (read-num))
|
|
(define after-pos (+ new-pos len 16))
|
|
(cond
|
|
[(bytes=? encoded-expected name)
|
|
(skip-bytes (- code-start after-pos))
|
|
(k #f)]
|
|
[(bytes<? encoded-expected name)
|
|
(if (zero? left)
|
|
(void)
|
|
(begin
|
|
(skip-bytes (- left after-pos))
|
|
(loop left)))]
|
|
[else
|
|
(if (zero? right)
|
|
(void)
|
|
(begin
|
|
(skip-bytes (- right after-pos))
|
|
(loop right)))]))]
|
|
[(or (not (pair? expected-module))
|
|
(car expected-module))
|
|
;; No table; ok to load source or full bytecode:
|
|
(k #t)]
|
|
[else
|
|
;; don't load the file from source or reload useless bytecode:
|
|
(void)])))
|
|
|
|
(define original-load-handler (current-load))
|
|
|
|
(define (text-editor-load-handler filename expected-module)
|
|
(unless (path? filename)
|
|
(raise-argument-error 'text-editor-load-handler "path?" filename))
|
|
(unless (or (not expected-module)
|
|
(symbol? expected-module)
|
|
(and (pair? expected-module)
|
|
(list? expected-module)
|
|
(pair? (cdr expected-module))
|
|
(or (not (car expected-module))
|
|
(symbol? (car expected-module)))
|
|
(andmap symbol? (cdr expected-module))))
|
|
(raise-argument-error 'text-editor-load-handler
|
|
"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))"
|
|
expected-module))
|
|
(let-values ([(in-port src wxme?) (build-input-port filename)])
|
|
(if wxme?
|
|
(dynamic-wind
|
|
(lambda () (void))
|
|
(lambda ()
|
|
(parameterize ([read-accept-compiled #t]
|
|
[read-accept-reader #t]
|
|
[read-accept-lang #t]
|
|
[read-on-demand-source (and (load-on-demand-enabled)
|
|
(path->complete-path filename))])
|
|
(if expected-module
|
|
(with-module-reading-parameterization
|
|
(lambda ()
|
|
(jump-to-submodule
|
|
in-port
|
|
expected-module
|
|
(lambda (check-second?)
|
|
(with-module-reading-parameterization
|
|
(lambda ()
|
|
(let* ([first (read-syntax src in-port)]
|
|
[module-ized-exp (check-module-form first expected-module filename)]
|
|
[second (if check-second?
|
|
(read in-port)
|
|
eof)])
|
|
(unless (eof-object? second)
|
|
(raise-syntax-error
|
|
'text-editor-load-handler
|
|
(format "expected only a `module' declaration for `~s', but found an extra expression"
|
|
expected-module)
|
|
second))
|
|
(eval module-ized-exp))))))))
|
|
(let loop ([last-time-values (list (void))])
|
|
(let ([exp (read-syntax src in-port)])
|
|
(if (eof-object? exp)
|
|
(apply values last-time-values)
|
|
(call-with-values (lambda () (call-with-continuation-prompt
|
|
(lambda () (eval
|
|
(datum->syntax
|
|
#f
|
|
(cons '#%top-interaction exp)
|
|
exp)))
|
|
(default-continuation-prompt-tag)
|
|
(lambda args
|
|
(apply
|
|
abort-current-continuation
|
|
(default-continuation-prompt-tag)
|
|
args))))
|
|
(lambda x (loop x)))))))))
|
|
(lambda ()
|
|
(close-input-port in-port)))
|
|
(begin
|
|
(close-input-port in-port)
|
|
(original-load-handler filename expected-module)))))
|
|
|
|
|
|
;; build-input-port : string -> (values input any)
|
|
;; constructs an input port for the load handler. Also
|
|
;; returns a value representing the source of code read from the file.
|
|
(define (build-input-port filename)
|
|
(let ([p (open-input-file filename)])
|
|
(port-count-lines! p)
|
|
(define-values (new-p changed?)
|
|
(cond
|
|
[(regexp-match-peek #rx#"^(?:#reader[(]lib\"read[.]ss\"\"wxme\"[)])?WXME01[0-9][0-9] ##[ \r\n]" p)
|
|
(let ([t (make-object text%)])
|
|
(send t insert-port p 'standard)
|
|
(close-input-port p)
|
|
(values (open-input-text-editor t 0 'end values filename) #t))]
|
|
[else (values p #f)]))
|
|
(when changed?
|
|
(port-count-lines! new-p)) ; in case it's new
|
|
(values new-p filename changed?)))
|
|
|
|
(define (open-input-graphical-file filename)
|
|
(let-values ([(p name wxme?) (build-input-port filename)])
|
|
p))
|
|
|
|
(define open-output-text-editor
|
|
(lambda (text [start 'end] [special-filter values] [port-name text]
|
|
#:eventspace [eventspace (wx:current-eventspace)])
|
|
(define pos (if (eq? start 'end)
|
|
(send text last-position)
|
|
(min start
|
|
(send text last-position))))
|
|
(define-values (in out) (make-pipe))
|
|
(define cvt (bytes-open-converter "UTF-8-permissive" "UTF-8"))
|
|
(define raw-buffer (make-bytes 128))
|
|
(define utf8-buffer (make-bytes 128))
|
|
(define (show s)
|
|
(define (insert)
|
|
(send text begin-edit-sequence)
|
|
(send text insert s pos)
|
|
(send text end-edit-sequence))
|
|
(if (and eventspace
|
|
(and (not (eq? (current-thread)
|
|
(wx:eventspace-handler-thread eventspace)))))
|
|
(parameterize ([wx:current-eventspace eventspace])
|
|
(wx:queue-callback insert #f))
|
|
(insert))
|
|
(set! pos (+ (string-length s) pos)))
|
|
(define (flush-text)
|
|
(let ([cnt (peek-bytes-avail!* raw-buffer 0 #f in)])
|
|
(when (positive? cnt)
|
|
(let-values ([(got used status) (bytes-convert cvt raw-buffer 0 cnt utf8-buffer)])
|
|
(cond
|
|
[(positive? got)
|
|
(read-bytes-avail!* raw-buffer in 0 used)
|
|
(show (bytes->string/utf-8 utf8-buffer #\? 0 got))
|
|
(flush-text)]
|
|
[(eq? status 'error)
|
|
(read-byte in)
|
|
(show "?")
|
|
(flush-text)])))))
|
|
(define (force-text)
|
|
(when (byte-ready? in)
|
|
(show "?")
|
|
(read-byte in)
|
|
(flush-text)
|
|
(force-text)))
|
|
(define port
|
|
(make-output-port
|
|
text
|
|
always-evt
|
|
(lambda (s start end nonblock? breakable?)
|
|
;; Put bytes into pipe:
|
|
(write-bytes s out start end)
|
|
;; Extract as many string characters as are ready:
|
|
(flush-text)
|
|
(- end start))
|
|
(lambda ()
|
|
(force-text))
|
|
(lambda (special nonblock? breakable?)
|
|
(let ([special (special-filter special)])
|
|
(cond
|
|
[(special . is-a? . wx:snip%)
|
|
(force-text)
|
|
(send text insert special pos)
|
|
(set! pos (+ pos (send special get-count)))]
|
|
[else
|
|
(display special port)]))
|
|
#t)
|
|
#f #f
|
|
(lambda ()
|
|
(let ([line (send text position-line pos)])
|
|
(values (add1 line)
|
|
(- pos (send text line-start-position line))
|
|
(add1 pos))))
|
|
void
|
|
(add1 pos)))
|
|
port)))
|