aspell.rkt
1 #lang racket/base 2 (require racket/system 3 racket/match 4 racket/contract 5 racket/port 6 string-constants) 7 8 (provide/contract 9 [query-aspell (->* ((and/c string? (not/c #rx"[\n]"))) 10 ((or/c #f string?)) 11 (listof (list/c number? number? (listof string?))))] 12 13 ;; may return #f when aspell is really ispell or when 14 ;; something goes wrong trying to get the list of dictionaries 15 [get-aspell-dicts (-> (or/c #f (listof string?)))] 16 17 [find-aspell-binary-path (-> (or/c path? #f))] 18 [aspell-problematic? (-> (or/c string? #f))]) 19 20 (define aspell-candidate-paths 21 '("/usr/bin" 22 "/bin" 23 "/usr/local/bin" 24 "/opt/local/bin/")) 25 26 (define (find-aspell-binary-path) 27 (define aspell (if (eq? (system-type) 'windows) "aspell.exe" "aspell")) 28 (define ispell (if (eq? (system-type) 'windows) "ispell.exe" "ispell")) 29 (or (find-executable-path aspell) 30 (find-executable-path ispell) 31 (for/or ([cp aspell-candidate-paths]) 32 (define c1 (build-path cp aspell)) 33 (define c2 (build-path cp ispell)) 34 (or (and (file-exists? c1) 35 c1) 36 (and (file-exists? c2) 37 c2))))) 38 39 (define (start-aspell asp dict) 40 (define aspell? (regexp-match? #rx"aspell" (path->string asp))) 41 (apply process* asp 42 (append 43 '("-a") 44 (if dict 45 (list "-d" dict) 46 '()) 47 (if aspell? '("--encoding=utf-8") '())))) 48 49 (define problematic 'dont-know) 50 (define (aspell-problematic?) 51 (when (eq? problematic 'dont-know) 52 (set! problematic (do-aspell-problematic)) 53 (asp-log (format "set problematic to ~s" problematic))) 54 problematic) 55 56 (define (do-aspell-problematic) 57 (define asp (find-aspell-binary-path)) 58 (cond 59 [(not asp) 60 (string-constant cannot-find-ispell-or-aspell-path)] 61 [else 62 (define cust (make-custodian)) 63 (define sp (open-output-string)) 64 (define timeout-amount .1) 65 (define timed-out? 66 (parameterize ([current-custodian cust]) 67 (define proc-lst (start-aspell asp #f)) 68 (define stdout (list-ref proc-lst 0)) 69 (define stderr (list-ref proc-lst 3)) 70 (close-output-port (list-ref proc-lst 1)) ;; close stdin 71 (close-input-port stdout) 72 (define copy-thread (thread (λ () (copy-port stderr sp)))) 73 (equal? (sync/timeout timeout-amount copy-thread) #f))) 74 (custodian-shutdown-all cust) 75 (define errmsg (get-output-string sp)) 76 (cond 77 [(not (equal? errmsg "")) 78 (string-append 79 (format (string-constant spell-program-wrote-to-stderr-on-startup) asp) 80 "\n\n" 81 errmsg)] 82 [timed-out? 83 (format (string-constant spell-program-did-not-respond-after-some-seconds) 84 asp 85 timeout-amount)] 86 [else #f])])) 87 88 (define asp-logger (make-logger 'framework/aspell (current-logger))) 89 (define-syntax-rule 90 (asp-log arg) 91 (when (log-level? asp-logger 'debug) 92 (asp-log/proc arg))) 93 (define (asp-log/proc arg) 94 (log-message asp-logger 'debug arg (current-continuation-marks))) 95 96 (define aspell-req-chan (make-channel)) 97 (define change-dict-chan (make-channel)) 98 (define aspell-thread #f) 99 (define (start-aspell-thread) 100 (unless aspell-thread 101 (set! aspell-thread 102 (thread 103 (λ () 104 (define aspell-proc #f) 105 (define already-attempted-aspell? #f) 106 (define current-dict #f) 107 (define is-actually-aspell? #f) 108 109 (define (fire-up-aspell) 110 (unless already-attempted-aspell? 111 (set! already-attempted-aspell? #t) 112 (define asp (find-aspell-binary-path)) 113 (when asp 114 (set! aspell-proc (start-aspell asp current-dict)) 115 (define line (with-handlers ((exn:fail? exn-message)) 116 (read-line (list-ref aspell-proc 0)))) 117 (asp-log (format "framework: started speller: ~a" line)) 118 (when (regexp-match? #rx"[Aa]spell" line) 119 (set! is-actually-aspell? #t)) 120 121 (when (and (string? line) 122 (regexp-match #rx"[Aa]spell" line)) 123 ;; put aspell in "terse" mode 124 (display "!\n" (list-ref aspell-proc 1)) 125 (flush-output (list-ref aspell-proc 1))) 126 127 (define stderr (list-ref aspell-proc 3)) 128 (thread 129 (λ () 130 (let loop () 131 (define l (with-handlers ((exn:fail? void)) 132 (read-line stderr))) 133 (when (string? l) 134 (asp-log (format "aspell-proc stderr: ~a" l)) 135 (loop)))))))) 136 137 (define (shutdown-aspell why) 138 (asp-log (format "aspell.rkt: shutdown connection to aspell: ~a" why)) 139 (define proc (list-ref aspell-proc 4)) 140 (close-input-port (list-ref aspell-proc 0)) 141 (close-output-port (list-ref aspell-proc 1)) 142 (close-input-port (list-ref aspell-proc 3)) 143 (proc 'kill) 144 (set! aspell-proc #f) 145 (set! is-actually-aspell? #f)) 146 147 (define (is-ascii? l) 148 (for/and ([s (in-string l)]) 149 (<= (char->integer s) 127))) 150 151 (let loop () 152 (sync 153 (handle-evt 154 aspell-req-chan 155 (match-lambda 156 [(list line new-dict resp-chan nack-evt) 157 (unless (equal? new-dict current-dict) 158 (when aspell-proc 159 (shutdown-aspell "changing dictionary") 160 (set! already-attempted-aspell? #f)) 161 (set! current-dict new-dict)) 162 (unless aspell-proc (fire-up-aspell)) 163 (define (send-resp resp) 164 (sync (channel-put-evt resp-chan resp) 165 nack-evt)) 166 (cond 167 [(and aspell-proc 168 (or is-actually-aspell? 169 (is-ascii? line))) 170 (define stdout (list-ref aspell-proc 0)) 171 (define stdin (list-ref aspell-proc 1)) 172 173 ;; always lead with a ^ character so aspell 174 ;; doesn't interpret anything as a command 175 (display "^" stdin) 176 (display line stdin) 177 (newline stdin) 178 (flush-output stdin) 179 (let loop ([resp '()]) 180 (define check-on-aspell (sync/timeout .5 stdout)) 181 (cond 182 [check-on-aspell 183 (define (handle-err x) 184 (asp-log 185 (format "error reading stdout of aspell process: ~a" 186 (exn-message x))) 187 eof) 188 (define l (with-handlers ((exn:fail? handle-err)) 189 (read-line stdout))) 190 (cond 191 [(eof-object? l) 192 (send-resp '()) 193 (shutdown-aspell "got eof from process")] 194 [(equal? l "") (send-resp (reverse resp))] 195 [(regexp-match #rx"^[*]" l) (loop resp)] 196 [(regexp-match #rx"^[&] ([^ ]*) [0-9]+ ([0-9]+): (.*)$" l) 197 => 198 (λ (m) 199 (define word-len (string-length (list-ref m 1))) 200 ;; subtract one to correct for the leading ^ 201 (define word-start (- (string->number (list-ref m 2)) 1)) 202 (define suggestions (list-ref m 3)) 203 (loop 204 (cons 205 (list word-start word-len (regexp-split #rx", " suggestions)) 206 resp)))] 207 [(regexp-match #rx"^[#] ([^ ]*) ([0-9]+)" l) 208 => 209 (λ (m) 210 (define word-len (string-length (list-ref m 1))) 211 ;; subtract one to correct for the leading ^ 212 (define word-start (- (string->number (list-ref m 2)) 1)) 213 (loop (cons (list word-start word-len '()) resp)))] 214 [else 215 (send-resp '()) 216 (shutdown-aspell (format "could not parse aspell output line: ~s" l))])] 217 [else 218 (send-resp '()) 219 (shutdown-aspell "interaction timed out")]))] 220 [else (send-resp '())]) 221 (loop)]))))))))) 222 223 (define (query-aspell line [dict #f]) 224 (cond 225 [(aspell-problematic?) 226 '()] 227 [else 228 (when dict 229 (unless (member dict (get-aspell-dicts)) 230 (set! dict #f))) 231 232 (start-aspell-thread) 233 (sync 234 (nack-guard-evt 235 (λ (nack-evt) 236 (define resp (make-channel)) 237 (channel-put aspell-req-chan (list line dict resp nack-evt)) 238 resp)))])) 239 240 (define aspell-dicts #f) 241 (define (get-aspell-dicts) 242 (unless (aspell-problematic?) 243 (unless aspell-dicts 244 (define asp (find-aspell-binary-path)) 245 (when (regexp-match? #rx"aspell" (path->string asp)) 246 (define proc-lst (process* asp "dump" "dicts")) 247 (define stdout (list-ref proc-lst 0)) 248 (define stderr (list-ref proc-lst 3)) 249 (close-output-port (list-ref proc-lst 1)) ;; close stdin 250 (close-input-port stderr) 251 (set! aspell-dicts 252 (let loop () 253 (define l (read-line stdout)) 254 (cond 255 [(eof-object? l) '()] 256 [else (cons l (loop))])))))) 257 aspell-dicts)