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 expected-module)])
|
|
(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 expected-module)
|
|
(let ([p (open-input-file filename #:for-module? expected-module)])
|
|
(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 #f)])
|
|
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)))
|