added spelling dictionary support

related to PR 13242

collects/drracket/private/unit.rkt

@@ -3667,6 +3667,33 @@ module browser threading seems wrong.
                   (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))]))])
+        (define dicts (get-aspell-dicts))
+        (when dicts
+          (define dicts-menu (new menu:can-restore-underscore-menu% 
+                                  [parent edit-menu]
+                                  [label (string-constant spelling-dictionaries)]))
+          (define (mk-item dict label)
+            (new menu:can-restore-checkable-menu-item%
+                 [parent dicts-menu]
+                 [label label]
+                 [callback
+                  (λ (item evt)
+                    (define ed (get-edit-target-object))
+                    (when (and ed (is-a? ed color:text<%>))
+                      (preferences:set 'framework:aspell-dict dict)
+                      (send ed set-spell-current-dict dict)))]
+                 [demand-callback 
+                  (λ (item)
+                    (define ed (get-edit-target-object))
+                    (send item enable (and ed (is-a? ed color:text<%>)))
+                    (send item check 
+                          (and ed 
+                               (is-a? ed color:text<%>)
+                               (equal? dict (send ed get-spell-current-dict)))))]))
+          (mk-item #f (string-constant default-spelling-dictionary))
+          (new separator-menu-item% [parent dicts-menu])
+          (for ([dict (in-list dicts)])
+            (mk-item dict dict)))
         (new menu:can-restore-menu-item%
              [label (string-constant complete-word)]
              [shortcut #\/]

collects/framework/private/aspell.rkt

@@ -6,7 +6,14 @@
          string-constants)
 
 (provide/contract
- [query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))]
+ [query-aspell (->* ((and/c string? (not/c #rx"[\n]")))
+                    ((or/c #f string?))
+                    (listof (list/c number? number?)))]
+
+ ;; may return #f when aspell is really ispell or when
+ ;; something goes wrong trying to get the list of dictionaries
+ [get-aspell-dicts (-> (or/c #f (listof string?)))]
+ 
  [find-aspell-binary-path (-> (or/c path? #f))]
  [aspell-problematic? (-> (or/c string? #f))])
 
@@ -28,17 +35,29 @@
             (and (file-exists? c2)
                  c2)))))
 
-(define (start-aspell asp)
+(define (start-aspell asp dict)
   (define aspell? (regexp-match? #rx"aspell" (path->string asp)))
-  (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '())))
+  (apply process* asp 
+         (append
+          '("-a")
+          (if dict
+              (list "-d" dict)
+              '())
+          (if aspell? '("--encoding=utf-8") '()))))
 
+(define problematic 'dont-know)
 (define (aspell-problematic?)
+  (when (eq? problematic 'dont-know)
+    (set! problematic (do-aspell-problematic)))
+  problematic)
+
+(define (do-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 proc-lst (start-aspell asp #f))
      (define stdout (list-ref proc-lst 0))
      (define stderr (list-ref proc-lst 3))
      (close-output-port (list-ref proc-lst 1)) ;; close stdin
@@ -64,6 +83,7 @@
   (log-message asp-logger 'debug arg (current-continuation-marks)))
 
 (define aspell-req-chan (make-channel))
+(define change-dict-chan (make-channel))
 (define aspell-thread #f)
 (define (start-aspell-thread)
   (unless aspell-thread
@@ -72,13 +92,14 @@
            (λ () 
              (define aspell-proc #f)
              (define already-attempted-aspell? #f)
+             (define current-dict #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))
+                   (set! aspell-proc (start-aspell asp current-dict))
                    (define line (with-handlers ((exn:fail? exn-message))
                                   (read-line (list-ref aspell-proc 0))))
                    (asp-log (format "framework: started speller: ~a" line))
@@ -113,7 +134,12 @@
                 (handle-evt
                  aspell-req-chan
                  (match-lambda
-                   [(list line resp-chan nack-evt)
+                   [(list line new-dict resp-chan nack-evt)
+                    (unless (equal? new-dict current-dict)
+                      (when aspell-proc
+                        (shutdown-aspell "changing dictionary")
+                        (set! already-attempted-aspell? #f))
+                      (set! current-dict new-dict))
                     (unless aspell-proc (fire-up-aspell))
                     (define (send-resp resp)
                       (sync (channel-put-evt resp-chan resp)
@@ -133,11 +159,12 @@
                          (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)))
+                            (define (handle-err x)
+                              (asp-log
+                               (format "error reading stdout of aspell process: ~a"
+                                       (exn-message x)))
+                              eof)
+                            (define l (with-handlers ((exn:fail? handle-err))
                                         (read-line stdout)))
                             (cond
                               [(eof-object? l) 
@@ -168,11 +195,36 @@
                       [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))))
+(define (query-aspell line [dict #f])
+  (unless (aspell-problematic?)
+    
+    (when dict
+      (unless (member dict (get-aspell-dicts))
+        (set! dict #f)))
+    
+    (start-aspell-thread)
+    (sync
+     (nack-guard-evt
+      (λ (nack-evt)
+        (define resp (make-channel))
+        (channel-put aspell-req-chan (list line dict resp nack-evt))
+        resp)))))
+
+(define aspell-dicts #f)
+(define (get-aspell-dicts)
+  (unless (aspell-problematic?)
+    (unless aspell-dicts
+      (define asp (find-aspell-binary-path))
+      (when (regexp-match? #rx"aspell" (path->string asp))
+        (define proc-lst (process* asp "dump" "dicts"))
+        (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 stderr)
+        (set! aspell-dicts
+              (let loop ()
+                (define l (read-line stdout))
+                (cond
+                  [(eof-object? l) '()]
+                  [else (cons l (loop))]))))))
+  aspell-dicts)

collects/framework/private/color.rkt

@@ -64,7 +64,8 @@ added get-regions
     get-token-range
     
     set-spell-check-strings
-    get-spell-check-strings))
+    get-spell-check-strings
+    get-spell-current-dict))
 
 (define text-mixin
   (mixin (text:basic<%>) (-text<%>)
@@ -234,6 +235,13 @@ added get-regions
         (set! spell-check-strings? s)
         (reset-tokens)
         (start-colorer token-sym->style get-token pairs)))
+    (define current-dict (preferences:get 'framework:aspell-dict))
+    (define/public (set-spell-current-dict d)
+      (unless (equal? d current-dict)
+        (set! current-dict d)
+        (reset-tokens)
+        (start-colorer token-sym->style get-token pairs)))
+    (define/public (get-spell-current-dict) current-dict)
     
     ;; ---------------------- Multi-threading ---------------------------
     ;; The editor revision when the last coloring was started
@@ -382,7 +390,7 @@ added get-regions
                        [pos sp])
               (unless (null? strs)
                 (define str (car strs))
-                (let loop ([spellos (query-aspell str)]
+                (let loop ([spellos (query-aspell str current-dict)]
                            [lp 0])
                   (cond
                     [(null? spellos) 

collects/framework/private/main.rkt

@@ -23,6 +23,8 @@
 
 (application-preferences-handler (λ () (preferences:show-dialog)))
 
+(preferences:set-default 'framework:aspell-dict #f (λ (x) (or (not x) (string? x))))
+
 (preferences:set-default 'framework:line-spacing-add-gap?
                          (not (eq? (system-type) 'windows))
                          boolean?)

collects/scribblings/framework/color.scrbl

@@ -165,6 +165,16 @@
     string constants. Otherwise, disable spell-checking of constants.
   }
   
+  @defmethod[(set-spell-current-dict [dict (or/c string? #f)])]{
+    Sets the current dictionary used with aspell to @racket[dict].
+    If @racket[dict] is @racket[#f], then the default dictionary is used.
+  }
+  
+  @defmethod[(get-spell-current-dict) (or/c string? #f)]{
+    Get the current dictionary used with aspell.
+    If the result is @racket[#f], then the default dictionary is used.
+  }
+  
   @defmethod*[(((get-regions) (listof (list/c number? (or/c (quote end) number?)))))]{
     This returns the list of regions that are currently being colored in the
     editor.

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

@@ -1711,6 +1711,8 @@ please adhere to these guidelines:
   ;; 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")
+  (spelling-dictionaries "Spelling Dictionaries") ; (sub)menu whose items are the different possible dictionaries
+  (default-spelling-dictionary "Default Dictionary") ; first item in menu from previous line
   (misspelled-text-color "Misspelled Text Color") ;; in the preferences dialog  
   (cannot-find-ispell-or-aspell-path "Cannot find the aspell or ispell binary")
   ; puts the path to the spell program in the ~a and then the error message