c5330194a9
Specifically, two things:
- make drracket more careful to not crash when aspell
doesn't behave, and
- have a more careful test when clicking the menu item
(it now does a trial run of aspell instead of just
looking for the binary)
closes PR 13242 (I realize there is still a feature
request mentioned in the audit trail of that PR, but
since the main problem is fixed, I'll consider that
to just be something separate)
179 lines
7.4 KiB
Racket
179 lines
7.4 KiB
Racket
#lang racket/base
|
|
(require racket/system
|
|
racket/match
|
|
racket/contract
|
|
racket/port
|
|
string-constants)
|
|
|
|
(provide/contract
|
|
[query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))]
|
|
[find-aspell-binary-path (-> (or/c path? #f))]
|
|
[aspell-problematic? (-> (or/c string? #f))])
|
|
|
|
(define aspell-candidate-paths
|
|
'("/usr/bin"
|
|
"/usr/local/bin"
|
|
"/bin"))
|
|
|
|
(define (find-aspell-binary-path)
|
|
(define aspell (if (eq? (system-type) 'windows) "aspell.exe" "aspell"))
|
|
(define ispell (if (eq? (system-type) 'windows) "ispell.exe" "ispell"))
|
|
(or (find-executable-path aspell)
|
|
(find-executable-path ispell)
|
|
(for/or ([cp aspell-candidate-paths])
|
|
(define c1 (build-path cp aspell))
|
|
(define c2 (build-path cp ispell))
|
|
(or (and (file-exists? c1)
|
|
c1)
|
|
(and (file-exists? c2)
|
|
c2)))))
|
|
|
|
(define (start-aspell asp)
|
|
(define aspell? (regexp-match? #rx"aspell" (path->string asp)))
|
|
(apply process* asp "-a" (if aspell? '("--encoding=utf-8") '())))
|
|
|
|
(define (aspell-problematic?)
|
|
(define asp (find-aspell-binary-path))
|
|
(cond
|
|
[(not asp)
|
|
(string-constant cannot-find-ispell-or-aspell-path)]
|
|
[else
|
|
(define proc-lst (start-aspell asp))
|
|
(define stdout (list-ref proc-lst 0))
|
|
(define stderr (list-ref proc-lst 3))
|
|
(close-output-port (list-ref proc-lst 1)) ;; close stdin
|
|
(close-input-port stdout)
|
|
(define sp (open-output-string))
|
|
(copy-port stderr sp)
|
|
(define errmsg (get-output-string sp))
|
|
(close-input-port stderr)
|
|
(cond
|
|
[(not (equal? errmsg ""))
|
|
(string-append
|
|
(format (string-constant spell-program-wrote-to-stderr-on-startup) asp)
|
|
"\n\n"
|
|
errmsg)]
|
|
[else #f])]))
|
|
|
|
(define asp-logger (make-logger 'framework/aspell (current-logger)))
|
|
(define-syntax-rule
|
|
(asp-log arg)
|
|
(when (log-level? asp-logger 'debug)
|
|
(asp-log/proc arg)))
|
|
(define (asp-log/proc arg)
|
|
(log-message asp-logger 'debug arg (current-continuation-marks)))
|
|
|
|
(define aspell-req-chan (make-channel))
|
|
(define aspell-thread #f)
|
|
(define (start-aspell-thread)
|
|
(unless aspell-thread
|
|
(set! aspell-thread
|
|
(thread
|
|
(λ ()
|
|
(define aspell-proc #f)
|
|
(define already-attempted-aspell? #f)
|
|
|
|
(define (fire-up-aspell)
|
|
(unless already-attempted-aspell?
|
|
(set! already-attempted-aspell? #t)
|
|
(define asp (find-aspell-binary-path))
|
|
(when asp
|
|
(set! aspell-proc (start-aspell asp))
|
|
(define line (with-handlers ((exn:fail? exn-message))
|
|
(read-line (list-ref aspell-proc 0))))
|
|
(asp-log (format "framework: started speller: ~a" line))
|
|
|
|
(when (and (string? line)
|
|
(regexp-match #rx"[Aa]spell" line))
|
|
;; put aspell in "terse" mode
|
|
(display "!\n" (list-ref aspell-proc 1))
|
|
(flush-output (list-ref aspell-proc 1)))
|
|
|
|
(define stderr (list-ref aspell-proc 3))
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(define l (with-handlers ((exn:fail? void))
|
|
(read-line stderr)))
|
|
(when (string? l)
|
|
(asp-log (format "aspell-proc stderr: ~a" l))
|
|
(loop))))))))
|
|
|
|
(define (shutdown-aspell why)
|
|
(asp-log (format "aspell.rkt: shutdown connection to aspell: ~a" why))
|
|
(define proc (list-ref aspell-proc 4))
|
|
(close-input-port (list-ref aspell-proc 0))
|
|
(close-output-port (list-ref aspell-proc 1))
|
|
(close-input-port (list-ref aspell-proc 3))
|
|
(proc 'kill)
|
|
(set! aspell-proc #f))
|
|
|
|
(let loop ()
|
|
(sync
|
|
(handle-evt
|
|
aspell-req-chan
|
|
(match-lambda
|
|
[(list line resp-chan nack-evt)
|
|
(unless aspell-proc (fire-up-aspell))
|
|
(define (send-resp resp)
|
|
(sync (channel-put-evt resp-chan resp)
|
|
nack-evt))
|
|
(cond
|
|
[aspell-proc
|
|
(define stdout (list-ref aspell-proc 0))
|
|
(define stdin (list-ref aspell-proc 1))
|
|
|
|
;; always lead with a ^ character so aspell
|
|
;; doesn't interpret anything as a command
|
|
(display "^" stdin)
|
|
(display line stdin)
|
|
(newline stdin)
|
|
(flush-output stdin)
|
|
(let loop ([resp '()])
|
|
(define check-on-aspell (sync/timeout .5 stdout))
|
|
(cond
|
|
[check-on-aspell
|
|
(define l (with-handlers ((exn:fail? (λ (x)
|
|
(asp-log
|
|
(format "error reading stdout of aspell process: ~a"
|
|
(exn-message x)))
|
|
eof)))
|
|
(read-line stdout)))
|
|
(cond
|
|
[(eof-object? l)
|
|
(send-resp '())
|
|
(shutdown-aspell "got eof from process")]
|
|
[(equal? l "") (send-resp (reverse resp))]
|
|
[(regexp-match #rx"^[*]" l) (loop resp)]
|
|
[(regexp-match #rx"^[&] ([^ ]*) [0-9]+ ([0-9]+)" l)
|
|
=>
|
|
(λ (m)
|
|
(define word-len (string-length (list-ref m 1)))
|
|
;; subtract one to correct for the leading ^
|
|
(define word-start (- (string->number (list-ref m 2)) 1))
|
|
(loop (cons (list word-start word-len) resp)))]
|
|
[(regexp-match #rx"^[#] ([^ ]*) ([0-9]+)" l)
|
|
=>
|
|
(λ (m)
|
|
(define word-len (string-length (list-ref m 1)))
|
|
;; subtract one to correct for the leading ^
|
|
(define word-start (- (string->number (list-ref m 2)) 1))
|
|
(loop (cons (list word-start word-len) resp)))]
|
|
[else
|
|
(send-resp '())
|
|
(shutdown-aspell (format "could not parse aspell output line: ~s" l))])]
|
|
[else
|
|
(send-resp '())
|
|
(shutdown-aspell "interaction timed out")]))]
|
|
[else (send-resp '())])
|
|
(loop)])))))))))
|
|
|
|
(define (query-aspell line)
|
|
(start-aspell-thread)
|
|
(sync
|
|
(nack-guard-evt
|
|
(λ (nack-evt)
|
|
(define resp (make-channel))
|
|
(channel-put aspell-req-chan (list line resp nack-evt))
|
|
resp))))
|