add capability to spell-check string constants
(calls out to ispell or aspell)
This commit is contained in:
Robby Findler
parent
5bc108c7b1
commit
72fa1d45a1
|
|
@ -3628,6 +3628,23 @@ module browser threading seems wrong.
|
|||
|
||||
(define/override (edit-menu:between-find-and-preferences edit-menu)
|
||||
(super edit-menu:between-find-and-preferences edit-menu)
|
||||
(new menu:can-restore-checkable-menu-item%
|
||||
[label (string-constant spell-check-string-constants)]
|
||||
[shortcut #\c]
|
||||
[shortcut-prefix (cons 'shift (get-default-shortcut-prefix))]
|
||||
[parent edit-menu]
|
||||
[demand-callback
|
||||
(λ (item)
|
||||
(define ed (get-edit-target-object))
|
||||
(define on? (and ed (is-a? ed color:text<%>)))
|
||||
(send item enable ed)
|
||||
(send item check (and on? (send ed get-spell-check-strings))))]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
(define ed (get-edit-target-object))
|
||||
(define old-val (send ed get-spell-check-strings))
|
||||
(preferences:set 'framework:spell-check-on? (not old-val))
|
||||
(send ed set-spell-check-strings (not old-val)))])
|
||||
(new menu:can-restore-menu-item%
|
||||
[label (string-constant complete-word)]
|
||||
[shortcut #\/]
|
||||
|
|
|
|||
123
collects/framework/private/aspell.rkt
Normal file
123
collects/framework/private/aspell.rkt
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
#lang racket/base
|
||||
(require racket/system
|
||||
racket/match
|
||||
racket/contract)
|
||||
|
||||
(provide/contract
|
||||
[query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))])
|
||||
|
||||
(define aspell-candidate-paths
|
||||
'("/usr/bin"
|
||||
"/usr/local/bin"
|
||||
"/bin"))
|
||||
|
||||
(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 (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)))))
|
||||
|
||||
(when asp
|
||||
(set! aspell-proc (process* asp "-a"))
|
||||
(define line (read-line (list-ref aspell-proc 0)))
|
||||
(log-info (format "framework: started speller: ~a" line))
|
||||
|
||||
(when (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)
|
||||
(log-warning (format "aspell-proc stderr: ~a" l))
|
||||
(loop))))))))
|
||||
|
||||
(define (shutdown-aspell why)
|
||||
(log-warning (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)
|
||||
(unless aspell-proc (fire-up-aspell))
|
||||
(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 (read-line stdout))
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
(channel-put resp-chan '())
|
||||
(shutdown-aspell "got eof from process")]
|
||||
[(equal? l "") (channel-put resp-chan (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
|
||||
(channel-put resp-chan '())
|
||||
(shutdown-aspell (format "could not parse aspell output line: ~s" l))])]
|
||||
[else
|
||||
(channel-put resp-chan '())
|
||||
(shutdown-aspell "interaction timed out")]))]
|
||||
[else (channel-put resp-chan '())])
|
||||
(loop)])))))))))
|
||||
|
||||
(define (query-aspell line)
|
||||
(start-aspell-thread)
|
||||
(define resp (make-channel))
|
||||
(channel-put aspell-req-chan (list line resp))
|
||||
(channel-get resp))
|
||||
|
||||
|
|
@ -14,7 +14,8 @@ added get-regions
|
|||
syntax-color/default-lexer
|
||||
string-constants
|
||||
"../preferences.rkt"
|
||||
"sig.rkt")
|
||||
"sig.rkt"
|
||||
"aspell.rkt")
|
||||
|
||||
(import [prefix icon: framework:icon^]
|
||||
[prefix mode: framework:mode^]
|
||||
|
|
@ -60,7 +61,10 @@ added get-regions
|
|||
backward-containing-sexp
|
||||
forward-match
|
||||
insert-close-paren
|
||||
classify-position))
|
||||
classify-position
|
||||
|
||||
set-spell-check-strings
|
||||
get-spell-check-strings))
|
||||
|
||||
(define text-mixin
|
||||
(mixin (text:basic<%>) (-text<%>)
|
||||
|
|
@ -221,6 +225,15 @@ added get-regions
|
|||
;; ---------------------- Preferences -------------------------------
|
||||
(define should-color? #t)
|
||||
(define token-sym->style #f)
|
||||
(define spell-check-strings? (preferences:get 'framework:spell-check-on?))
|
||||
|
||||
(define/public (get-spell-check-strings) spell-check-strings?)
|
||||
(define/public (set-spell-check-strings s)
|
||||
(define new-val (and s #t))
|
||||
(unless (eq? new-val spell-check-strings?)
|
||||
(set! spell-check-strings? s)
|
||||
(reset-tokens)
|
||||
(start-colorer token-sym->style get-token pairs)))
|
||||
|
||||
;; ---------------------- Multi-threading ---------------------------
|
||||
;; A list of thunks that color the buffer
|
||||
|
|
@ -234,7 +247,7 @@ added get-regions
|
|||
(inherit change-style begin-edit-sequence end-edit-sequence highlight-range
|
||||
get-style-list in-edit-sequence? get-start-position get-end-position
|
||||
local-edit-sequence? get-styles-fixed has-focus?
|
||||
get-fixed-style)
|
||||
get-fixed-style get-text)
|
||||
|
||||
(define lexers-all-valid? #t)
|
||||
(define/private (update-lexer-state-observers)
|
||||
|
|
@ -319,15 +332,8 @@ added get-regions
|
|||
(set-lexer-state-current-lexer-mode! ls new-lexer-mode)
|
||||
(sync-invalid ls)
|
||||
(when (and should-color? (should-color-type? type) (not frozen?))
|
||||
(set! colors
|
||||
(cons
|
||||
(let* ([style-name (token-sym->style type)]
|
||||
(color (send (get-style-list) find-named-style style-name))
|
||||
(sp (+ in-start-pos (sub1 new-token-start)))
|
||||
(ep (+ in-start-pos (sub1 new-token-end))))
|
||||
(λ ()
|
||||
(change-style color sp ep #f)))
|
||||
colors)))
|
||||
(set! colors (cons (do-coloring type in-start-pos new-token-start new-token-end)
|
||||
colors)))
|
||||
;; Using the non-spec version takes 3 times as long as the spec
|
||||
;; version. In other words, the new greatly outweighs the tree
|
||||
;; operations.
|
||||
|
|
@ -352,6 +358,37 @@ added get-regions
|
|||
(enable-suspend #t)
|
||||
(re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
|
||||
|
||||
(define/private (do-coloring type in-start-pos new-token-start new-token-end)
|
||||
(define sp (+ in-start-pos (sub1 new-token-start)))
|
||||
(define ep (+ in-start-pos (sub1 new-token-end)))
|
||||
(define style-name (token-sym->style type))
|
||||
(define color (send (get-style-list) find-named-style style-name))
|
||||
(cond
|
||||
[(and spell-check-strings? (eq? type 'string))
|
||||
(define misspelled-color (send (get-style-list) find-named-style "Standard"))
|
||||
(define strs (regexp-split #rx"\n" (get-text sp ep)))
|
||||
(λ ()
|
||||
(let loop ([strs strs]
|
||||
[pos sp])
|
||||
(unless (null? strs)
|
||||
(define str (car strs))
|
||||
(let loop ([spellos (query-aspell str)]
|
||||
[lp 0])
|
||||
(cond
|
||||
[(null? spellos)
|
||||
(change-style color (+ sp lp) (+ sp (string-length str)) #f)]
|
||||
[else
|
||||
(define err (car spellos))
|
||||
(define err-start (list-ref err 0))
|
||||
(define err-len (list-ref err 1))
|
||||
|
||||
(change-style color (+ pos lp) (+ pos err-start) #f)
|
||||
(change-style misspelled-color (+ pos err-start) (+ pos err-start err-len) #f)
|
||||
(loop (cdr spellos) (+ err-start err-len))]))
|
||||
(loop (cdr strs)
|
||||
(+ pos (string-length str) 1)))))]
|
||||
[else (λ () (change-style color sp ep #f))]))
|
||||
|
||||
(define/private (show-tree t)
|
||||
(printf "Tree:\n")
|
||||
(send t search-min!)
|
||||
|
|
|
|||
|
|
@ -29,6 +29,8 @@
|
|||
;; used to time how long it takes to set a preference; the value is not actually used.
|
||||
(preferences:set-default 'drracket:prefs-debug #f (λ (x) #t))
|
||||
|
||||
(preferences:set-default 'framework:spell-check-on? #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:always-use-platform-specific-linefeed-convention #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:overwrite-mode-keybindings #f boolean?)
|
||||
|
|
|
|||
|
|
@ -171,6 +171,10 @@ case-sensitive and case-insensitive search.}
|
|||
|
||||
]}
|
||||
|
||||
@item{@defmenuitem{Spell Check String Constants} Uses @tt{aspell}
|
||||
or @tt{ispell} to look for unknown words in string constants
|
||||
(things that would otherwise be colored green).}
|
||||
|
||||
@item{@defmenuitem{Complete Word} Completes the word at the
|
||||
insertion point, using the manuals as a source of completions.}
|
||||
|
||||
|
|
|
|||
|
|
@ -1682,4 +1682,8 @@ please adhere to these guidelines:
|
|||
(hide-defs/ints-label "Hide Definitions/Interactions Labels") ;; popup menu
|
||||
(show-defs/ints-label "Show definitions/interactions labels") ;; preferences checkbox
|
||||
|
||||
;; menu item in the 'edit' menu; applies to editors with programs in them
|
||||
;; (technically, editors that implement color:text<%>)
|
||||
(spell-check-string-constants "Spell Check String Constants")
|
||||
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user