From 72fa1d45a18e2e38444db4c11300a1d9f344035c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 14 Oct 2012 17:40:26 -0500 Subject: [PATCH] add capability to spell-check string constants (calls out to ispell or aspell) --- collects/drracket/private/unit.rkt | 17 +++ collects/framework/private/aspell.rkt | 123 ++++++++++++++++++ collects/framework/private/color.rkt | 61 +++++++-- collects/framework/private/main.rkt | 2 + collects/scribblings/drracket/menus.scrbl | 4 + .../private/english-string-constants.rkt | 4 + 6 files changed, 199 insertions(+), 12 deletions(-) create mode 100644 collects/framework/private/aspell.rkt diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 918e68fa97..fff3259d09 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -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 #\/] diff --git a/collects/framework/private/aspell.rkt b/collects/framework/private/aspell.rkt new file mode 100644 index 0000000000..6f94e40a54 --- /dev/null +++ b/collects/framework/private/aspell.rkt @@ -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)) + \ No newline at end of file diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 87ad45f593..00b16783fb 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -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. @@ -351,6 +357,37 @@ added get-regions [else (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") diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index e1322473dc..f91a6289dc 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -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?) diff --git a/collects/scribblings/drracket/menus.scrbl b/collects/scribblings/drracket/menus.scrbl index 77ab028c8e..3245713d23 100644 --- a/collects/scribblings/drracket/menus.scrbl +++ b/collects/scribblings/drracket/menus.scrbl @@ -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.} diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index e2ee195ec1..2a8ea92a45 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1681,5 +1681,9 @@ please adhere to these guidelines: (interactions-window-label "interactions") (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") )