From 5b18645a9a5f1646d69f6d3ff1b761cb7def3e65 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 22 Nov 2012 19:24:22 -0600 Subject: [PATCH] added spelling dictionary support related to PR 13242 --- collects/drracket/private/unit.rkt | 27 ++++++ collects/framework/private/aspell.rkt | 90 +++++++++++++++---- collects/framework/private/color.rkt | 12 ++- collects/framework/private/main.rkt | 2 + collects/scribblings/framework/color.scrbl | 10 +++ .../private/english-string-constants.rkt | 2 + 6 files changed, 122 insertions(+), 21 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 46bb59c8d4..f174befeca 100644 --- a/collects/drracket/private/unit.rkt +++ b/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 #\/] diff --git a/collects/framework/private/aspell.rkt b/collects/framework/private/aspell.rkt index 4c5eddcd48..6a6006a268 100644 --- a/collects/framework/private/aspell.rkt +++ b/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) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 1879642e2a..caa79ad448 100644 --- a/collects/framework/private/color.rkt +++ b/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) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 43b8ef7004..d84cb1ef93 100644 --- a/collects/framework/private/main.rkt +++ b/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?) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 4407978c3c..bffb4bb9b9 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/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. diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 624b39bb78..2fe2bc8d03 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/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