336 lines
12 KiB
Racket
336 lines
12 KiB
Racket
(module snipfile mzscheme
|
|
(require mzlib/class
|
|
mzlib/etc
|
|
mzlib/port
|
|
syntax/moddep
|
|
(prefix wx: "kernel.ss")
|
|
(prefix wx: "wxme/snip.ss")
|
|
(prefix wx: "wxme/cycle.ss")
|
|
"check.ss"
|
|
"editor.ss")
|
|
|
|
(provide readable-snip<%>
|
|
open-input-text-editor
|
|
open-input-graphical-file
|
|
text-editor-load-handler
|
|
open-output-text-editor )
|
|
|
|
;; snip-class% and editor-data-class% loaders
|
|
|
|
(define (ok-string-element? m)
|
|
(and (string? m)
|
|
(regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m)
|
|
(not (string=? m ".."))
|
|
(not (string=? m "."))))
|
|
|
|
(define (ok-lib-path? m)
|
|
(and (pair? m)
|
|
(eq? 'lib (car m))
|
|
(pair? (cdr m))
|
|
(list? m)
|
|
(andmap ok-string-element? (cdr m))))
|
|
|
|
(let ([load-one
|
|
(lambda (str id %)
|
|
(let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)])
|
|
(and (regexp-match #rx"^[(].*[)]$" str)
|
|
(let* ([p (open-input-string str)]
|
|
[m (read p)])
|
|
(and (eof-object? (read p))
|
|
m))))])
|
|
(if (or (ok-lib-path? m)
|
|
(and (list? m)
|
|
(= (length m) 2)
|
|
(ok-lib-path? (car m))
|
|
(ok-lib-path? (cadr m))))
|
|
(let ([m (if (ok-lib-path? m)
|
|
m
|
|
(car m))])
|
|
(let ([result (dynamic-require m id)])
|
|
(if (is-a? result %)
|
|
result
|
|
(error 'load-class "not a ~a% instance" id))))
|
|
#f)))])
|
|
;; install the getters:
|
|
(wx:set-get-snip-class!
|
|
(lambda (name)
|
|
(load-one name 'snip-class wx:snip-class%)))
|
|
(wx:set-get-editor-data-class!
|
|
(lambda (name)
|
|
(load-one name 'editor-data-class wx:editor-data-class%))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define readable-snip<%>
|
|
(interface ()
|
|
read-special))
|
|
|
|
(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
|
|
(opt-lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f])
|
|
;; Check arguments:
|
|
(unless (text . is-a? . text%)
|
|
(raise-type-error 'open-input-text-editor "text% object" text))
|
|
(check-non-negative-integer 'open-input-text-editor start)
|
|
(unless (or (eq? end 'end)
|
|
(and (integer? end) (exact? end) (not (negative? end))))
|
|
(raise-type-error 'open-input-text-editor "non-negative exact integer or 'end" end))
|
|
(let ([last (send text last-position)])
|
|
(when (start . > . last)
|
|
(raise-mismatch-error 'open-input-text-editor
|
|
(format "start index outside the range [0,~a]: " last)
|
|
start))
|
|
(unless (eq? end 'end)
|
|
(unless (<= start end last)
|
|
(raise-mismatch-error 'open-input-text-editor
|
|
(format "end index outside the range [~a,~a]: " start last)
|
|
end))))
|
|
(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])
|
|
(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)
|
|
eof)
|
|
(begin
|
|
(write-string (send text get-text start (+ start n)) pipe-w)
|
|
(set! start (+ start n))
|
|
(read-bytes-avail!* s pipe-r))))
|
|
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)])
|
|
(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]
|
|
[update-str-to-snip
|
|
(lambda (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) (- end snip-start))])
|
|
(write-string (send-generic snip get-text-generic 0 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)
|
|
(unless (= revision (grn))
|
|
(raise-mismatch-error
|
|
'text-input-port
|
|
"editor has changed since port was opened: "
|
|
text))
|
|
(set! snip (send-generic snip next-generic))
|
|
(update-str-to-snip 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 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)])
|
|
(if (eq? v 0)
|
|
(read-chars s)
|
|
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)))
|
|
close)])
|
|
(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 empty-string))
|
|
port)))))))
|
|
|
|
(define (text-editor-load-handler filename expected-module)
|
|
(unless (path? filename)
|
|
(raise-type-error 'text-editor-load-handler "path" filename))
|
|
(let-values ([(in-port src) (build-input-port filename)])
|
|
(dynamic-wind
|
|
(lambda () (void))
|
|
(lambda ()
|
|
(parameterize ([read-accept-compiled #t]
|
|
[read-on-demand-source (and (load-on-demand-enabled)
|
|
(path->complete-path filename))])
|
|
(if expected-module
|
|
(with-module-reading-parameterization
|
|
(lambda ()
|
|
(let* ([first (read-syntax src in-port)]
|
|
[module-ized-exp (check-module-form first expected-module filename)]
|
|
[second (read in-port)])
|
|
(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-object
|
|
#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)))))
|
|
|
|
|
|
;; 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)
|
|
(let ([p (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)
|
|
(open-input-text-editor t 0 'end values filename))]
|
|
[else p])])
|
|
(port-count-lines! p) ; in case it's new
|
|
(values p filename))))
|
|
|
|
(define (open-input-graphical-file filename)
|
|
(let-values ([(p name) (build-input-port filename)])
|
|
p))
|
|
|
|
(define open-output-text-editor
|
|
(opt-lambda (text [start 'end] [special-filter values] [port-name text])
|
|
(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)
|
|
(send text insert s pos)
|
|
(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)))
|