add capability to spell-check string constants

(calls out to ispell or aspell)

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 #\/]

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))
+  

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,14 +332,7 @@ 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
+            (set! colors (cons (do-coloring type in-start-pos new-token-start new-token-end)
-                  (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)))
           ;; Using the non-spec version takes 3 times as long as the spec
           ;; version.  In other words, the new greatly outweighs the tree
@@ -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!)

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?)

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.}
 

collects/string-constants/private/english-string-constants.rkt

@@ -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")
+  
   )