Newer
Older
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
(message "Spell Checking...%d%%"
(* 100 (/ (float (- (point) beg)) (- end beg))))
(setq count 0))
(setq count (+ 1 count)))
(flyspell-word)
(let ((cur (point)))
(forward-word 1)
(if (and (< (point) end) (> (point) (+ cur 1)))
(backward-char 1)))))
(backward-char 1)
(message "Spell Checking...done")
(flyspell-word)))
;*---------------------------------------------------------------------*/
;* flyspell-buffer ... */
;*---------------------------------------------------------------------*/
(defun flyspell-buffer ()
"Flyspell whole buffer."
(interactive)
(flyspell-region (point-min) (point-max)))
;*---------------------------------------------------------------------*/
;* flyspell-overlay-p ... */
;*---------------------------------------------------------------------*/
(defun flyspell-overlay-p (o)
"A predicate that return true iff O is an overlay used by flyspell."
(and (overlayp o) (overlay-get o 'flyspell-overlay)))
;*---------------------------------------------------------------------*/
;* flyspell-delete-all-overlays ... */
;* ------------------------------------------------------------- */
;* Remove all the overlays introduced by flyspell. */
;*---------------------------------------------------------------------*/
(defun flyspell-delete-all-overlays ()
"Delete all the overlays used by flyspell."
(let ((l (overlays-in (point-min) (point-max))))
(while (consp l)
(progn
(if (flyspell-overlay-p (car l))
(delete-overlay (car l)))
(setq l (cdr l))))))
;*---------------------------------------------------------------------*/
;* flyspell-unhighlight-at ... */
;*---------------------------------------------------------------------*/
(defun flyspell-unhighlight-at (pos)
"Remove the flyspell overlay that are located at POS."
(if flyspell-persistent-highlight
(let ((overlays (overlays-at pos)))
(while (consp overlays)
(if (flyspell-overlay-p (car overlays))
(delete-overlay (car overlays)))
(setq overlays (cdr overlays))))
(delete-overlay flyspell-overlay)))
;*---------------------------------------------------------------------*/
;* flyspell-properties-at-p ... */
;* ------------------------------------------------------------- */
;* Is there an highlight properties at position pos? */
;*---------------------------------------------------------------------*/
(defun flyspell-properties-at-p (pos)
"Return t if there is a text property at POS, not counting `local-map'.
If variable `flyspell-highlight-properties' is set to nil,
text with properties are not checked. This function is used to discover
if the character at POS has any other property."
(let ((prop (text-properties-at pos))
(keep t))
(while (and keep (consp prop))
(if (and (eq (car prop) 'local-map) (consp (cdr prop)))
(setq prop (cdr (cdr prop)))
(setq keep nil)))
(consp prop)))
;*---------------------------------------------------------------------*/
;* make-flyspell-overlay ... */
;*---------------------------------------------------------------------*/
(defun make-flyspell-overlay (beg end face mouse-face)
"Allocate an overlay to highlight an incorrect word.
BEG and END specify the range in the buffer of that word.
FACE and MOUSE-FACE specify the `face' and `mouse-face' properties
for the overlay."
(let ((flyspell-overlay (make-overlay beg end)))
(overlay-put flyspell-overlay 'face face)
(overlay-put flyspell-overlay 'mouse-face mouse-face)
(overlay-put flyspell-overlay 'flyspell-overlay t)
(if (eq flyspell-emacs 'xemacs)
(overlay-put flyspell-overlay
flyspell-overlay-keymap-property-name
flyspell-mouse-map))))
;*---------------------------------------------------------------------*/
;* flyspell-highlight-incorrect-region ... */
;*---------------------------------------------------------------------*/
(defun flyspell-highlight-incorrect-region (beg end)
"Set up an overlay on a misspelled word, in the buffer from BEG to END."
(run-hook-with-args 'flyspell-incorrect-hook beg end)
(if (or flyspell-highlight-properties (not (flyspell-properties-at-p beg)))
(progn
;; we cleanup current overlay at the same position
(if (and (not flyspell-persistent-highlight)
(overlayp flyspell-overlay))
(delete-overlay flyspell-overlay)
(let ((overlays (overlays-at beg)))
(while (consp overlays)
(if (flyspell-overlay-p (car overlays))
(delete-overlay (car overlays)))
(setq overlays (cdr overlays)))))
;; now we can use a new overlay
(setq flyspell-overlay
(make-flyspell-overlay beg end
'flyspell-incorrect-face 'highlight)))))
;*---------------------------------------------------------------------*/
;* flyspell-highlight-duplicate-region ... */
;*---------------------------------------------------------------------*/
(defun flyspell-highlight-duplicate-region (beg end)
"Set up an overlay on a duplicated word, in the buffer from BEG to END."
(if (or flyspell-highlight-properties (not (flyspell-properties-at-p beg)))
(progn
;; we cleanup current overlay at the same position
(if (and (not flyspell-persistent-highlight)
(overlayp flyspell-overlay))
(delete-overlay flyspell-overlay)
(let ((overlays (overlays-at beg)))
(while (consp overlays)
(if (flyspell-overlay-p (car overlays))
(delete-overlay (car overlays)))
(setq overlays (cdr overlays)))))
;; now we can use a new overlay
(setq flyspell-overlay
(make-flyspell-overlay beg end
'flyspell-duplicate-face 'highlight)))))
;*---------------------------------------------------------------------*/
;* flyspell-auto-correct-cache ... */
;*---------------------------------------------------------------------*/
(defvar flyspell-auto-correct-pos nil)
(defvar flyspell-auto-correct-region nil)
(defvar flyspell-auto-correct-ring nil)
;*---------------------------------------------------------------------*/
;* flyspell-auto-correct-word ... */
;*---------------------------------------------------------------------*/
(defun flyspell-auto-correct-word (pos)
"Correct the word at POS.
This command proposes various successive corrections for the word at POS.
The variable `flyspell-auto-correct-binding' specifies the key to bind
to this command."
(interactive "d")
;; use the correct dictionary
(if (eq flyspell-auto-correct-pos pos)
;; we have already been using the function at the same location
(progn
(save-excursion
(let ((start (car flyspell-auto-correct-region))
(len (cdr flyspell-auto-correct-region)))
(delete-region start (+ start len))
(setq flyspell-auto-correct-ring (cdr flyspell-auto-correct-ring))
(let* ((word (car flyspell-auto-correct-ring))
(len (length word)))
(rplacd flyspell-auto-correct-region len)
(goto-char start)
(insert word))))
(setq flyspell-auto-correct-pos (point)))
;; retain cursor location
(let ((cursor-location pos)
start end poss)
;; destructure return word info list.
(setq start (car (cdr word))
end (car (cdr (cdr word)))
word (car word))
;; now check spelling of word.
(process-send-string ispell-process "%\n") ;put in verbose mode
(process-send-string ispell-process (concat "^" word "\n"))
;; wait until ispell has processed word
(while (progn
(accept-process-output ispell-process)
(not (string= "" (car ispell-filter)))))
(setq ispell-filter (cdr ispell-filter))
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
(setq poss (ispell-parse-output (car ispell-filter))))
(cond ((or (eq poss t) (stringp poss))
;; don't correct word
t)
((null poss)
;; ispell error
(error "Ispell: error in Ispell process"))
(t
;; the word is incorrect, we have to propose a replacement
(let ((replacements (if flyspell-sort-corrections
(sort (car (cdr (cdr poss))) 'string<)
(car (cdr (cdr poss))))))
(if (consp replacements)
(progn
(let ((replace (car replacements)))
(setq word replace)
(setq cursor-location (+ (- (length word) (- end start))
cursor-location))
(if (not (equal word (car poss)))
(progn
;; the save the current replacements
(setq flyspell-auto-correct-pos cursor-location)
(setq flyspell-auto-correct-region
(cons start (length word)))
(let ((l replacements))
(while (consp (cdr l))
(setq l (cdr l)))
(rplacd l (cons (car poss) replacements)))
(setq flyspell-auto-correct-ring
(cdr replacements))
(delete-region start end)
(insert word)))))))))
;; return to original location
(goto-char cursor-location)
(ispell-pdict-save t))))
;*---------------------------------------------------------------------*/
;* flyspell-correct-word ... */
;*---------------------------------------------------------------------*/
(defun flyspell-correct-word (event)
"Check spelling of word under or before the cursor.
If the word is not found in dictionary, display possible corrections
in a popup menu allowing you to choose one.
Word syntax described by `ispell-dictionary-alist' (which see).
This will check or reload the dictionary. Use \\[ispell-change-dictionary]
or \\[ispell-region] to update the Ispell process."
(interactive "e")
(if (eq flyspell-emacs 'xemacs)
(flyspell-correct-word/mouse-keymap event)
(flyspell-correct-word/local-keymap event)))
;*---------------------------------------------------------------------*/
;* flyspell-correct-word/local-keymap ... */
;*---------------------------------------------------------------------*/
(defun flyspell-correct-word/local-keymap (event)
"emacs 19.xx seems to be buggous. Overlay keymap does not seems
to work correctly with local map. That is, if a key is not
defined for the overlay keymap, the current local map, is not
checked. The binding is resolved with the global map. The
consequence is that we can not use overlay map with flyspell."
(interactive "e")
(save-window-excursion
(let ((save (point)))
(mouse-set-point event)
;; we look for a flyspell overlay here
(let ((overlays (overlays-at (point)))
(overlay nil))
(while (consp overlays)
(if (flyspell-overlay-p (car overlays))
(progn
(setq overlay (car overlays))
(setq overlays nil))
(setq overlays (cdr overlays))))
;; we return to the correct location
(goto-char save)
;; we check to see if button2 has been used overlay a
;; flyspell overlay
(if overlay
;; yes, so we use the flyspell function
(flyspell-correct-word/mouse-keymap event)
;; no so we have to use the non flyspell binding
(let ((flyspell-mode nil))
(if (key-binding (this-command-keys))
(command-execute (key-binding (this-command-keys))))))))))
;*---------------------------------------------------------------------*/
;* flyspell-correct-word ... */
;*---------------------------------------------------------------------*/
(defun flyspell-correct-word/mouse-keymap (event)
"Pop up a menu of possible corrections for a misspelled word.
The word checked is the word at the mouse position."
(interactive "e")
;; use the correct dictionary
;; retain cursor location (I don't know why but save-excursion here fails).
(let ((save (point)))
(mouse-set-point event)
(let ((cursor-location (point))
start end poss replace)
;; destructure return word info list.
(setq start (car (cdr word))
end (car (cdr (cdr word)))
word (car word))
;; now check spelling of word.
(process-send-string ispell-process "%\n") ;put in verbose mode
(process-send-string ispell-process (concat "^" word "\n"))
;; wait until ispell has processed word
(while (progn
(accept-process-output ispell-process)
(not (string= "" (car ispell-filter)))))
(setq ispell-filter (cdr ispell-filter))
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
(setq poss (ispell-parse-output (car ispell-filter))))
(cond ((or (eq poss t) (stringp poss))
;; don't correct word
t)
((null poss)
;; ispell error
(error "Ispell: error in Ispell process"))
((string-match "GNU" (emacs-version))
;; the word is incorrect, we have to propose a replacement
(setq replace (flyspell-emacs-popup event poss word))
(cond ((eq replace 'ignore)
nil)
((eq replace 'save)
(process-send-string ispell-process (concat "*" word "\n"))
(flyspell-unhighlight-at cursor-location)
(setq ispell-pdict-modified-p '(t)))
((or (eq replace 'buffer) (eq replace 'session))
(process-send-string ispell-process (concat "@" word "\n"))
(if (null ispell-pdict-modified-p)
(setq ispell-pdict-modified-p
(list ispell-pdict-modified-p)))
(flyspell-unhighlight-at cursor-location)
(if (eq replace 'buffer)
(ispell-add-per-file-word-list word)))
(replace
(setq word (if (atom replace) replace (car replace))
cursor-location (+ (- (length word) (- end start))
cursor-location))
(if (not (equal word (car poss)))
(progn
(delete-region start end)
(insert word))))))
((string-match "XEmacs" (emacs-version))
(flyspell-xemacs-popup
event poss word cursor-location start end)))
(ispell-pdict-save t))
(if (< save (point-max))
(goto-char save)
(goto-char (point-max)))))
;*---------------------------------------------------------------------*/
;* flyspell-xemacs-correct ... */
;*---------------------------------------------------------------------*/
(defun flyspell-xemacs-correct (replace poss word cursor-location start end)
"The xemacs popup menu callback."
(cond ((eq replace 'ignore)
nil)
((eq replace 'save)
(process-send-string ispell-process (concat "*" word "\n"))
(flyspell-unhighlight-at cursor-location)
(setq ispell-pdict-modified-p '(t)))
((or (eq replace 'buffer) (eq replace 'session))
(process-send-string ispell-process (concat "@" word "\n"))
(flyspell-unhighlight-at cursor-location)
(if (null ispell-pdict-modified-p)
(setq ispell-pdict-modified-p
(list ispell-pdict-modified-p)))
(if (eq replace 'buffer)
(ispell-add-per-file-word-list word)))
(replace
(setq word (if (atom replace) replace (car replace))
cursor-location (+ (- (length word) (- end start))
cursor-location))
(if (not (equal word (car poss)))
(save-excursion
(delete-region start end)
(goto-char start)
(insert word))))))
;*---------------------------------------------------------------------*/
;* flyspell-emacs-popup ... */
;*---------------------------------------------------------------------*/
(defun flyspell-emacs-popup (event poss word)
"The Emacs popup menu."
(if (not event)
(let* ((mouse-pos (mouse-position))
(mouse-pos (if (nth 1 mouse-pos)
mouse-pos
(set-mouse-position (car mouse-pos)
(/ (frame-width) 2) 2)
(unfocus-frame)
(mouse-position))))
(setq event (list (list (car (cdr mouse-pos))
(1+ (cdr (cdr mouse-pos))))
(car mouse-pos)))))
(let* ((corrects (if flyspell-sort-corrections
(sort (car (cdr (cdr poss))) 'string<)
(car (cdr (cdr poss)))))
(cor-menu (if (consp corrects)
(mapcar (lambda (correct)
(list correct correct))
corrects)
'()))
(affix (car (cdr (cdr (cdr poss)))))
(base-menu (let ((save (if (consp affix)
(list
(list (concat "Save affix: " (car affix))
'save)
'("Accept (session)" accept)
'("Accept (buffer)" buffer))
'(("Save word" save)
("Accept (session)" session)
("Accept (buffer)" buffer)))))
(if (consp cor-menu)
(append cor-menu (cons "" save))
save)))
(menu (cons "flyspell correction menu" base-menu)))
(car (x-popup-menu event
(list (format "%s [%s]" word (or ispell-local-dictionary
ispell-dictionary))
menu)))))
;*---------------------------------------------------------------------*/
;* flyspell-xemacs-popup ... */
;*---------------------------------------------------------------------*/
(defun flyspell-xemacs-popup (event poss word cursor-location start end)
"The xemacs popup menu."
(let* ((corrects (if flyspell-sort-corrections
(sort (car (cdr (cdr poss))) 'string<)
(car (cdr (cdr poss)))))
(cor-menu (if (consp corrects)
(mapcar (lambda (correct)
(vector correct
(list 'flyspell-xemacs-correct
correct
(list 'quote poss)
word
cursor-location
start
end)
t))
corrects)
'()))
(affix (car (cdr (cdr (cdr poss)))))
(menu (let ((save (if (consp affix)
(vector
(concat "Save affix: " (car affix))
(list 'flyspell-xemacs-correct
''save
(list 'quote poss)
word
cursor-location
start
end)
t)
(vector
"Save word"
(list 'flyspell-xemacs-correct
''save
(list 'quote poss)
word
cursor-location
start
end)
t)))
(session (vector "Accept (session)"
(list 'flyspell-xemacs-correct
''session
(list 'quote poss)
word
cursor-location
start
end)
t))
(buffer (vector "Accept (buffer)"
(list 'flyspell-xemacs-correct
''buffer
(list 'quote poss)
word
cursor-location
start
end)
t)))
(if (consp cor-menu)
(append cor-menu (list "-" save session buffer))
(list save session buffer)))))
(popup-menu (cons (format "%s [%s]" word (or ispell-local-dictionary
ispell-dictionary))
menu))))
;;;###autoload
(if (fboundp 'add-minor-mode)
(add-minor-mode 'flyspell-mode
flyspell-mode-line-string
flyspell-mode-map
nil
'flyspell-mode)
(or (assoc 'flyspell-mode minor-mode-alist)
(setq minor-mode-alist
(cons '(flyspell-mode flyspell-mode-line-string)
minor-mode-alist)))
(or (assoc 'flyspell-mode minor-mode-map-alist)
(setq minor-mode-map-alist
(cons (cons 'flyspell-mode flyspell-mode-map)
minor-mode-map-alist))))
(provide 'flyspell)