lib/spellcheck.tcl

   1 # git-gui spellchecking support through aspell
   2 # Copyright (C) 2008 Shawn Pearce
   3
   4 class spellcheck {
   5
   6 field s_fd     {} ; # pipe to aspell
   7 field s_version   ; # aspell version string
   8 field s_lang      ; # current language code
   9
  10 field w_text      ; # text widget we are spelling
  11 field w_menu      ; # context menu for the widget
  12 field s_menuidx 0 ; # last index of insertion into $w_menu
  13
  14 field s_i              ; # timer registration for _run callbacks
  15 field s_clear        0 ; # did we erase mispelled tags yet?
  16 field s_seen    [list] ; # lines last seen from $w_text in _run
  17 field s_checked [list] ; # lines already checked
  18 field s_pending [list] ; # [$line $data] sent to aspell
  19 field s_suggest        ; # array, list of suggestions, keyed by misspelling
  20
  21 constructor init {pipe_fd ui_text ui_menu} {
  22         set w_text $ui_text
  23         set w_menu $ui_menu
  24
  25         _connect $this $pipe_fd
  26         return $this
  27 }
  28
  29 method _connect {pipe_fd} {
  30         fconfigure $pipe_fd \
  31                 -encoding utf-8 \
  32                 -eofchar {} \
  33                 -translation lf
  34
  35         if {[gets $pipe_fd s_version] <= 0} {
  36                 close $pipe_fd
  37                 error [mc "Not connected to aspell"]
  38         }
  39         if {{@(#) } ne [string range $s_version 0 4]} {
  40                 close $pipe_fd
  41                 error [strcat [mc "Unrecognized aspell version"] ": $s_version"]
  42         }
  43         set s_version [string range $s_version 5 end]
  44
  45         puts $pipe_fd !             ; # enable terse mode
  46         puts $pipe_fd {$$cr master} ; # fetch the language
  47         flush $pipe_fd
  48
  49         gets $pipe_fd s_lang
  50         regexp {[/\\]([^/\\]+)\.[^\.]+$} $s_lang _ s_lang
  51
  52         if {$::default_config(gui.spellingdictionary) eq {}
  53          && [get_config gui.spellingdictionary] eq {}} {
  54                 set ::default_config(gui.spellingdictionary) $s_lang
  55         }
  56
  57         if {$s_fd ne {}} {
  58                 catch {close $s_fd}
  59         }
  60         set s_fd $pipe_fd
  61
  62         fconfigure $s_fd -blocking 0
  63         fileevent $s_fd readable [cb _read]
  64
  65         $w_text tag conf misspelled \
  66                 -foreground red \
  67                 -underline 1
  68         bind_button3 $w_text [cb _popup_suggest %X %Y @%x,%y]
  69
  70         array unset s_suggest
  71         set s_seen    [list]
  72         set s_checked [list]
  73         set s_pending [list]
  74         _run $this
  75 }
  76
  77 method lang {{n {}}} {
  78         if {$n ne {} && $s_lang ne $n} {
  79                 set spell_cmd [list |]
  80                 lappend spell_cmd aspell
  81                 lappend spell_cmd --master=$n
  82                 lappend spell_cmd --mode=none
  83                 lappend spell_cmd --encoding=UTF-8
  84                 lappend spell_cmd pipe
  85                 _connect $this [open $spell_cmd r+]
  86         }
  87         return $s_lang
  88 }
  89
  90 method version {} {
  91         return "$s_version, $s_lang"
  92 }
  93
  94 method stop {} {
  95         while {$s_menuidx > 0} {
  96                 $w_menu delete 0
  97                 incr s_menuidx -1
  98         }
  99         $w_text tag delete misspelled
 100
 101         catch {close $s_fd}
 102         catch {after cancel $s_i}
 103         set s_fd {}
 104         set s_i {}
 105         set s_lang {}
 106 }
 107
 108 method _popup_suggest {X Y pos} {
 109         while {$s_menuidx > 0} {
 110                 $w_menu delete 0
 111                 incr s_menuidx -1
 112         }
 113
 114         set b_loc [$w_text index "$pos wordstart"]
 115         set e_loc [_wordend $this $b_loc]
 116         set orig  [$w_text get $b_loc $e_loc]
 117         set tags  [$w_text tag names $b_loc]
 118
 119         if {[lsearch -exact $tags misspelled] >= 0} {
 120                 if {[info exists s_suggest($orig)]} {
 121                         set cnt 0
 122                         foreach s $s_suggest($orig) {
 123                                 if {$cnt < 5} {
 124                                         $w_menu insert $s_menuidx command \
 125                                                 -label $s \
 126                                                 -command [cb _replace $b_loc $e_loc $s]
 127                                         incr s_menuidx
 128                                         incr cnt
 129                                 } else {
 130                                         break
 131                                 }
 132                         }
 133                 } else {
 134                         $w_menu insert $s_menuidx command \
 135                                 -label [mc "No Suggestions"] \
 136                                 -state disabled
 137                         incr s_menuidx
 138                 }
 139                 $w_menu insert $s_menuidx separator
 140                 incr s_menuidx
 141         }
 142
 143         $w_text mark set saved-insert insert
 144         tk_popup $w_menu $X $Y
 145 }
 146
 147 method _replace {b_loc e_loc word} {
 148         $w_text configure -autoseparators 0
 149         $w_text edit separator
 150
 151         $w_text delete $b_loc $e_loc
 152         $w_text insert $b_loc $word
 153
 154         $w_text edit separator
 155         $w_text configure -autoseparators 1
 156         $w_text mark set insert saved-insert
 157 }
 158
 159 method _restart_timer {} {
 160         set s_i [after 300 [cb _run]]
 161 }
 162
 163 proc _match_length {max_line arr_name} {
 164         upvar $arr_name a
 165
 166         if {[llength $a] > $max_line} {
 167                 set a [lrange $a 0 $max_line]
 168         }
 169         while {[llength $a] <= $max_line} {
 170                 lappend a {}
 171         }
 172 }
 173
 174 method _wordend {pos} {
 175         set pos  [$w_text index "$pos wordend"]
 176         set tags [$w_text tag names $pos]
 177         while {[lsearch -exact $tags misspelled] >= 0} {
 178                 set pos  [$w_text index "$pos +1c"]
 179                 set tags [$w_text tag names $pos]
 180         }
 181         return $pos
 182 }
 183
 184 method _run {} {
 185         set cur_pos  [$w_text index {insert -1c}]
 186         set cur_line [lindex [split $cur_pos .] 0]
 187         set max_line [lindex [split [$w_text index end] .] 0]
 188         _match_length $max_line s_seen
 189         _match_length $max_line s_checked
 190
 191         # Nothing in the message buffer?  Nothing to spellcheck.
 192         #
 193         if {$cur_line == 1
 194          && $max_line == 2
 195          && [$w_text get 1.0 end] eq "\n"} {
 196                 array unset s_suggest
 197                 _restart_timer $this
 198                 return
 199         }
 200
 201         set active 0
 202         for {set n 1} {$n <= $max_line} {incr n} {
 203                 set s [$w_text get "$n.0" "$n.end"]
 204
 205                 # Don't spellcheck the current line unless we are at
 206                 # a word boundary.  The user might be typing on it.
 207                 #
 208                 if {$n == $cur_line
 209                  && ![regexp {^\W$} [$w_text get $cur_pos insert]]} {
 210
 211                         # If the current word is mispelled remove the tag
 212                         # but force a spellcheck later.
 213                         #
 214                         set tags [$w_text tag names $cur_pos]
 215                         if {[lsearch -exact $tags misspelled] >= 0} {
 216                                 $w_text tag remove misspelled \
 217                                         "$cur_pos wordstart" \
 218                                         [_wordend $this $cur_pos]
 219                                 lset s_seen    $n $s
 220                                 lset s_checked $n {}
 221                         }
 222
 223                         continue
 224                 }
 225
 226                 if {[lindex $s_seen    $n] eq $s
 227                  && [lindex $s_checked $n] ne $s} {
 228                         # Don't send empty lines to Aspell it doesn't check them.
 229                         #
 230                         if {$s eq {}} {
 231                                 lset s_checked $n $s
 232                                 continue
 233                         }
 234
 235                         # Don't send typical s-b-o lines as the emails are
 236                         # almost always misspelled according to Aspell.
 237                         #
 238                         if {[regexp -nocase {^[a-z-]+-by:.*<.*@.*>$} $s]} {
 239                                 $w_text tag remove misspelled "$n.0" "$n.end"
 240                                 lset s_checked $n $s
 241                                 continue
 242                         }
 243
 244                         puts $s_fd ^$s
 245                         lappend s_pending [list $n $s]
 246                         set active 1
 247                 } else {
 248                         # Delay until another idle loop to make sure we don't
 249                         # spellcheck lines the user is actively changing.
 250                         #
 251                         lset s_seen $n $s
 252                 }
 253         }
 254
 255         if {$active} {
 256                 set s_clear 1
 257                 flush $s_fd
 258         } else {
 259                 _restart_timer $this
 260         }
 261 }
 262
 263 method _read {} {
 264         while {[gets $s_fd line] >= 0} {
 265                 set lineno [lindex $s_pending 0 0]
 266
 267                 if {$s_clear} {
 268                         $w_text tag remove misspelled "$lineno.0" "$lineno.end"
 269                         set s_clear 0
 270                 }
 271
 272                 if {$line eq {}} {
 273                         lset s_checked $lineno [lindex $s_pending 0 1]
 274                         set s_pending [lrange $s_pending 1 end]
 275                         set s_clear 1
 276                         continue
 277                 }
 278
 279                 set sugg [list]
 280                 switch -- [string range $line 0 1] {
 281                 {& } {
 282                         set line [split [string range $line 2 end] :]
 283                         set info [split [lindex $line 0] { }]
 284                         set orig [lindex $info 0]
 285                         set offs [lindex $info 2]
 286                         foreach s [split [lindex $line 1] ,] {
 287                                 lappend sugg [string range $s 1 end]
 288                         }
 289                 }
 290                 {# } {
 291                         set info [split [string range $line 2 end] { }]
 292                         set orig [lindex $info 0]
 293                         set offs [lindex $info 1]
 294                 }
 295                 default {
 296                         puts stderr "<spell> $line"
 297                         continue
 298                 }
 299                 }
 300
 301                 incr offs -1
 302                 set b_loc "$lineno.$offs"
 303                 set e_loc [$w_text index "$lineno.$offs wordend"]
 304                 set curr [$w_text get $b_loc $e_loc]
 305
 306                 # At least for English curr = "bob", orig = "bob's"
 307                 # so Tk didn't include the 's but Aspell did.  We
 308                 # try to round out the word.
 309                 #
 310                 while {$curr ne $orig
 311                  && [string equal -length [string length $curr] $curr $orig]} {
 312                         set n_loc  [$w_text index "$e_loc +1c"]
 313                         set n_curr [$w_text get $b_loc $n_loc]
 314                         if {$n_curr eq $curr} {
 315                                 break
 316                         }
 317                         set curr  $n_curr
 318                         set e_loc $n_loc
 319                 }
 320
 321                 if {$curr eq $orig} {
 322                         $w_text tag add misspelled $b_loc $e_loc
 323                         if {[llength $sugg] > 0} {
 324                                 set s_suggest($orig) $sugg
 325                         } else {
 326                                 unset -nocomplain s_suggest($orig)
 327                         }
 328                 } else {
 329                         unset -nocomplain s_suggest($orig)
 330                 }
 331         }
 332
 333         fconfigure $s_fd -block 1
 334         if {[eof $s_fd]} {
 335                 if {![catch {close $s_fd} err]} {
 336                         set err [mc "Unexpected EOF from aspell"]
 337                 }
 338                 catch {after cancel $s_i}
 339                 $w_text tag remove misspelled 1.0 end
 340                 error_popup [strcat [mc "Spell Checker Failed"] "\n\n" $err]
 341                 return
 342         }
 343         fconfigure $s_fd -block 0
 344
 345         if {[llength $s_pending] == 0} {
 346                 _restart_timer $this
 347         }
 348 }
 349
 350 proc available_langs {} {
 351         set langs [list]
 352         catch {
 353                 set fd [open [list | aspell dump dicts] r]
 354                 while {[gets $fd line] >= 0} {
 355                         if {$line eq {}} continue
 356                         lappend langs $line
 357                 }
 358                 close $fd
 359         }
 360         return $langs
 361 }
 362
 363 }