PageRenderTime 55ms CodeModel.GetById 28ms RepoModel.GetById 0ms app.codeStats 0ms

/emacspeak-29.0/lisp/emacspeak-personality.el

#
Emacs Lisp | 535 lines | 406 code | 42 blank | 87 comment | 6 complexity | 33d0b2855a2f595961c2a8e76fd6b40e MD5 | raw file
Possible License(s): MIT
  1. ;;; emacspeak-personality.el ---Emacspeak's new personality interface
  2. ;;; $Id: emacspeak-personality.el 5798 2008-08-22 17:35:01Z tv.raman.tv $
  3. ;;; $Author: tv.raman.tv $
  4. ;;; Description: Voice lock implementation
  5. ;;; Keywords: Emacspeak, Spoken Output, audio formatting
  6. ;;{{{ LCD Archive entry:
  7. ;;; LCD Archive Entry:
  8. ;;; emacspeak| T. V. Raman |raman@cs.cornell.edu
  9. ;;; A speech interface to Emacs |
  10. ;;; $Date: 2007-08-25 18:28:19 -0700 (Sat, 25 Aug 2007) $ |
  11. ;;; $Revision: 4555 $ |
  12. ;;; Location undetermined
  13. ;;;
  14. ;;}}}
  15. ;;{{{ Copyright:
  16. ;;;Copyright (C) 1995 -- 2007, T. V. Raman
  17. ;;; Copyright (c) 1994, 1995 by Digital Equipment Corporation.
  18. ;;; All Rights Reserved.
  19. ;;;
  20. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  21. ;;;
  22. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  23. ;;; it under the terms of the GNU General Public License as published by
  24. ;;; the Free Software Foundation; either version 2, or (at your option)
  25. ;;; any later version.
  26. ;;;
  27. ;;; GNU Emacs is distributed in the hope that it will be useful,
  28. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  29. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  30. ;;; GNU General Public License for more details.
  31. ;;;
  32. ;;; You should have received a copy of the GNU General Public License
  33. ;;; along with GNU Emacs; see the file COPYING. If not, write to
  34. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  35. ;;}}}
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;{{{ Introduction:
  38. ;;; Commentary:
  39. ;;; This module defines a personality interface for implementing voice
  40. ;;; lock via font lock.
  41. ;;; Context:
  42. ;;; At the time I implemented Emacspeak's voice lock feature in late
  43. ;;; 1994, font-lock was still evolving. Most packages that supported
  44. ;;; The font-lock module explicitly checked for windowing system and
  45. ;;; became active only when Emacs was running under a windowing
  46. ;;; system.
  47. ;;; Since I wanted emacspeak to work both within and outside X, and I
  48. ;;; did not want to change any of Emacs' code, I implemented
  49. ;;; voice-lock as a separate module.
  50. ;;; This also kept things stable as font-lock itself evolved and
  51. ;;; changed.
  52. ;;; 8 years later, font-lock is now stable.
  53. ;;; It is also active outside windowing systems, since Emacs can now
  54. ;;; colorize terminals.
  55. ;;; This module when complete will simplify the voice-lock code in
  56. ;;; Emacspeak by triggering voice locking directly from within the
  57. ;;; font-lock code.
  58. ;;; Emacspeak modules will still be able to voice lock independent of
  59. ;;; visual characteristics --this was a key goal of the original
  60. ;;; Emacspeak design and it will be preserved going forward.
  61. ;;; Finally, I am adding better support for overlays --again this was a
  62. ;;; part of Emacs that was at its nascent stage in 1994, but is now
  63. ;;; stable.
  64. ;;}}}
  65. ;;{{{ Required modules
  66. (require 'cl)
  67. (declaim (optimize (safety 0) (speed 3)))
  68. (require 'custom)
  69. (require 'emacspeak-speak)
  70. (require 'emacspeak-sounds)
  71. (require 'advice)
  72. (require 'voice-setup)
  73. ;;}}}
  74. ;;{{{ attach voice lock to global font lock
  75. (defadvice font-lock-mode (after emacspeak pre act comp)
  76. "Attach voice-lock-mode to font-lock-mode."
  77. (voice-lock-mode font-lock-mode))
  78. (defadvice global-font-lock-mode (after emacspeak pre act comp)
  79. "Attach voice lock to font lock."
  80. (when global-font-lock-mode
  81. (setq-default voice-lock-mode t)))
  82. ;;}}}
  83. ;;{{{ cumulative personalities
  84. ;;;###autoload
  85. (defsubst emacspeak-personality-put (start end personality object)
  86. "Apply personality to specified region, over-writing any current
  87. personality settings."
  88. (when (and (integer-or-marker-p start)
  89. (integer-or-marker-p end )
  90. (not (= start end)))
  91. (let ((v (if (listp personality)
  92. (delete-duplicates personality :test #'eq)
  93. personality)))
  94. (ems-modify-buffer-safely
  95. (ad-Orig-put-text-property start end 'personality v object)))))
  96. ;;;###autoload
  97. (defun emacspeak-personality-append (start end personality &optional object )
  98. "Append specified personality to text bounded by start and end.
  99. Existing personality properties on the text range are preserved."
  100. (when (and (integer-or-marker-p start)
  101. (integer-or-marker-p end )
  102. (not (= start end)))
  103. (ems-modify-buffer-safely
  104. (let ((v (if (listp personality)
  105. (delete-duplicates personality :test #'eq)
  106. personality))
  107. (orig (get-text-property start 'personality object))
  108. (new nil)
  109. (extent
  110. (next-single-property-change
  111. start 'personality object end)))
  112. (cond
  113. ((null orig) ;simple case
  114. (ad-Orig-put-text-property start extent 'personality v object)
  115. (when (< extent end)
  116. (emacspeak-personality-append extent end v object)))
  117. (t ;accumulate the new personality
  118. (unless (or (equal v orig)
  119. (listp orig)
  120. (and (listp orig)(memq v orig)))
  121. (setq new
  122. (delete-duplicates
  123. (nconc
  124. (if (listp orig) orig (list orig))
  125. (if (listp v) v (list v)))))
  126. (ad-Orig-put-text-property start extent
  127. 'personality new object))
  128. (when (< extent end)
  129. (emacspeak-personality-append extent end v object))))))))
  130. ;;;###autoload
  131. (defun emacspeak-personality-prepend (start end
  132. personality &optional object)
  133. "Prepend specified personality to text bounded by start and end.
  134. Existing personality properties on the text range are preserved."
  135. (when (and (integer-or-marker-p start)
  136. (integer-or-marker-p end )
  137. (not (= start end)))
  138. (ems-modify-buffer-safely
  139. (let ((v (if (listp personality)
  140. (delete-duplicates personality :test #'eq)
  141. personality))
  142. (orig (get-text-property start 'personality object))
  143. (new nil)
  144. (extent
  145. (next-single-property-change
  146. start 'personality object end)))
  147. (cond
  148. ((null orig) ;simple case
  149. (ad-Orig-put-text-property start extent 'personality v object)
  150. (when (< extent end)
  151. (emacspeak-personality-prepend extent end v object)))
  152. (t ;accumulate the new personality
  153. (unless (or (equal v orig)
  154. (listp orig)
  155. (and (listp orig) (memq v orig)))
  156. (setq new
  157. (delete-duplicates
  158. (nconc
  159. (if (listp v) v (list v))
  160. (if (listp orig) orig (list orig)))))
  161. (ad-Orig-put-text-property start extent
  162. 'personality new object))
  163. (when (< extent end)
  164. (emacspeak-personality-prepend extent end v object))))))))
  165. (defun emacspeak-personality-remove (start end
  166. personality
  167. &optional object)
  168. "Remove specified personality from text bounded by start and end.
  169. Other existing personality properties on the text range are
  170. preserved."
  171. (when (and (integer-or-marker-p start)
  172. (integer-or-marker-p end )
  173. (not (= start end)))
  174. (ems-modify-buffer-safely
  175. (let ((orig (get-text-property start 'personality object))
  176. (new nil)
  177. (extent
  178. (next-single-property-change
  179. start 'personality (current-buffer) end)))
  180. (cond
  181. ((null orig) ;simple case
  182. (when (< extent end)
  183. (emacspeak-personality-remove extent end personality)))
  184. (t ;remove the new personality
  185. (setq new
  186. (cond
  187. ((equal orig personality) nil)
  188. ((listp orig)
  189. (remove personality orig))
  190. (t nil)))
  191. (if new
  192. (ad-Orig-put-text-property start extent
  193. 'personality new object)
  194. (ad-Orig-remove-text-properties start extent
  195. (list 'personality )
  196. object))
  197. (when (< extent end)
  198. (emacspeak-personality-remove extent end
  199. personality))))))))
  200. ;;}}}
  201. ;;{{{ helper: face-p
  202. (defsubst emacspeak-personality-plist-face-p (plist)
  203. "Check if plist contains a face setting."
  204. (or (memq 'face plist)
  205. (memq 'font-lock-face plist)))
  206. (defsubst ems-plain-cons-p (value)
  207. "Help identify (a . b)."
  208. (and (consp value)
  209. (equal value (last value))
  210. (cdr value)))
  211. ;;}}}
  212. ;;{{{ advice put-text-personality
  213. (defcustom emacspeak-personality-voiceify-faces
  214. 'emacspeak-personality-put
  215. "Determines how and if we voiceify faces.
  216. None means that faces are not mapped to voices.
  217. Prepend means that the corresponding personality is prepended to the
  218. existing personalities on the text.
  219. Append means place corresponding personality at the end.
  220. Simple means that voiceification is not cumulative --this is the default."
  221. :type '(choice :tag "Face Voiceification"
  222. (const :tag "None" nil)
  223. (const :tag "Simple" emacspeak-personality-put)
  224. (const :tag "Prepend" emacspeak-personality-prepend)
  225. (const :tag "Append" emacspeak-personality-append))
  226. :group 'emacspeak-personality)
  227. (defcustom emacspeak-personality-show-unmapped-faces nil
  228. "If set, faces that dont have a corresponding personality are
  229. displayed in the messages area."
  230. :type 'boolean
  231. :group 'emacspeak-personality)
  232. (defvar emacspeak-personality-unmapped-faces (make-hash-table)
  233. "Records faces that we have not yet mapped to personalities.")
  234. (defadvice put-text-property (after emacspeak-personality pre act)
  235. "Used by emacspeak to augment font lock."
  236. (when voice-lock-mode
  237. (let ((start (ad-get-arg 0))
  238. (end (ad-get-arg 1 ))
  239. (prop (ad-get-arg 2))
  240. (value (ad-get-arg 3 ))
  241. (object (ad-get-arg 4))
  242. (voice nil))
  243. (when (and emacspeak-personality-voiceify-faces
  244. (not (= start end))
  245. (or (eq prop 'face) (eq prop 'font-lock-face)))
  246. (condition-case nil
  247. (progn
  248. (cond
  249. ((symbolp value)
  250. (setq voice (voice-setup-get-voice-for-face value)))
  251. ((ems-plain-cons-p value)) ;;pass on plain cons
  252. ( (listp value)
  253. (setq voice
  254. (delq nil
  255. (mapcar #'voice-setup-get-voice-for-face value))))
  256. (t (message "Got %s" value)))
  257. (when voice
  258. (funcall emacspeak-personality-voiceify-faces start end voice object))
  259. (when (and emacspeak-personality-show-unmapped-faces
  260. (not voice))
  261. (cond
  262. ((listp value)
  263. (mapcar #'(lambda (v)
  264. (puthash v t emacspeak-personality-unmapped-faces))
  265. value))
  266. (t (puthash value t emacspeak-personality-unmapped-faces)))))
  267. (error nil))))))
  268. (defadvice add-text-properties (after emacspeak-personality pre act)
  269. "Used by emacspeak to augment font lock."
  270. (when voice-lock-mode
  271. (let ((start (ad-get-arg 0))
  272. (end (ad-get-arg 1 ))
  273. (properties (ad-get-arg 2))
  274. (object (ad-get-arg 3))
  275. (facep nil)
  276. (voice nil)
  277. (value nil))
  278. (setq facep (emacspeak-personality-plist-face-p properties))
  279. (when (and emacspeak-personality-voiceify-faces
  280. facep)
  281. (setq value (second facep))
  282. (condition-case nil
  283. (progn
  284. (cond
  285. ((symbolp value)
  286. (setq voice (voice-setup-get-voice-for-face value)))
  287. ((ems-plain-cons-p value)) ;;pass on plain cons
  288. ( (listp value)
  289. (setq voice
  290. (delq nil
  291. (mapcar #'voice-setup-get-voice-for-face value))))
  292. (t (message "Got %s" value)))
  293. (when voice
  294. (funcall emacspeak-personality-voiceify-faces start end voice object))
  295. (when (and emacspeak-personality-show-unmapped-faces
  296. (not voice))
  297. (cond
  298. ((listp value)
  299. (mapcar #'(lambda (v)
  300. (puthash v t emacspeak-personality-unmapped-faces))
  301. value))
  302. (t (puthash value t emacspeak-personality-unmapped-faces)))))
  303. (error nil))))))
  304. (defadvice set-text-properties (after emacspeak-personality pre act)
  305. "Used by emacspeak to augment font lock."
  306. (when voice-lock-mode
  307. (let ((start (ad-get-arg 0))
  308. (end (ad-get-arg 1 ))
  309. (properties (ad-get-arg 2))
  310. (object (ad-get-arg 3))
  311. (facep nil)
  312. (voice nil)
  313. (value nil))
  314. (setq facep (emacspeak-personality-plist-face-p properties))
  315. (when (and emacspeak-personality-voiceify-faces
  316. facep)
  317. (setq value (second facep))
  318. (condition-case nil
  319. (progn
  320. (cond
  321. ((symbolp value)
  322. (setq voice (voice-setup-get-voice-for-face value)))
  323. ((ems-plain-cons-p value)) ;;pass on plain cons
  324. ( (listp value)
  325. (setq voice
  326. (delq nil
  327. (mapcar #'voice-setup-get-voice-for-face value))))
  328. (t (message "Got %s" value)))
  329. (when voice
  330. (funcall emacspeak-personality-voiceify-faces start end voice object))
  331. (when (and emacspeak-personality-show-unmapped-faces
  332. (not voice))
  333. (cond
  334. ((listp value)
  335. (mapcar #'(lambda (v)
  336. (puthash v t emacspeak-personality-unmapped-faces))
  337. value))
  338. (t (puthash value t emacspeak-personality-unmapped-faces))))
  339. )
  340. (error nil))))))
  341. (defadvice propertize (around emacspeak-personality pre act)
  342. "Used by emacspeak to augment font lock."
  343. (let ((string (ad-get-arg 0))
  344. (properties (ad-get-args 1))
  345. (facep nil)
  346. (voice nil)
  347. (value nil))
  348. (setq facep (emacspeak-personality-plist-face-p properties))
  349. (cond
  350. ((and emacspeak-personality-voiceify-faces
  351. facep)
  352. ad-do-it
  353. (setq value (second facep))
  354. (condition-case nil
  355. (progn
  356. (cond
  357. ((symbolp value)
  358. (setq voice (voice-setup-get-voice-for-face value)))
  359. ( (listp value)
  360. (setq voice
  361. (delq nil
  362. (mapcar #'voice-setup-get-voice-for-face value))))
  363. (t (message "Got %s" value)))
  364. (when voice
  365. (funcall emacspeak-personality-voiceify-faces 0
  366. (length ad-return-value) voice ad-return-value))
  367. (when (and emacspeak-personality-show-unmapped-faces
  368. (not voice))
  369. (cond
  370. ((listp value)
  371. (mapcar #'(lambda (v)
  372. (puthash v t emacspeak-personality-unmapped-faces))
  373. value))
  374. (t (puthash value t emacspeak-personality-unmapped-faces)))))
  375. (error nil)))
  376. (t ad-do-it))
  377. ad-return-value))
  378. (defadvice remove-text-properties (before emacspeak-personality pre act comp)
  379. "Undo any voiceification if needed."
  380. (when voice-lock-mode
  381. (let ((start (ad-get-arg 0))
  382. (end (ad-get-arg 1))
  383. (props (ad-get-arg 2))
  384. (object (ad-get-arg 3))
  385. (voice nil)
  386. (face nil))
  387. (when (and (not (= start end))
  388. (emacspeak-personality-plist-face-p props) ) ;;; simple minded for now
  389. (ad-Orig-put-text-property start end
  390. 'personality nil object)))))
  391. (defadvice remove-list-of-text-properties (before emacspeak-personality pre act comp)
  392. "Undo any voiceification if needed."
  393. (when voice-lock-mode
  394. (let ((start (ad-get-arg 0))
  395. (end (ad-get-arg 1))
  396. (props (ad-get-arg 2))
  397. (object (ad-get-arg 3))
  398. (voice nil)
  399. (face nil))
  400. (when (and (not (= start end))
  401. (emacspeak-personality-plist-face-p props) ) ;;; simple minded for now
  402. (put-text-property start end
  403. 'personality nil object)))))
  404. ;;}}}
  405. ;;{{{ advice overlay-put
  406. (defcustom emacspeak-personality-voiceify-overlays
  407. 'emacspeak-personality-prepend
  408. "Determines how and if we voiceify overlays.
  409. None means that overlay faces are not mapped to voices.
  410. Prepend means that the corresponding personality is prepended to the
  411. existing personalities on the text under overlay.
  412. Append means place corresponding personality at the end."
  413. :type '(choice :tag "Overlay Voiceification"
  414. (const :tag "None" nil)
  415. (const :tag "Prepend" emacspeak-personality-prepend)
  416. (const :tag "Append" emacspeak-personality-append))
  417. :group 'emacspeak-personality)
  418. (defadvice overlay-put (after emacspeak-personality pre act)
  419. "Used by emacspeak to augment font lock."
  420. (let ((overlay (ad-get-arg 0))
  421. (prop (ad-get-arg 1))
  422. (value (ad-get-arg 2))
  423. (voice nil))
  424. (when (and
  425. (or (eq prop 'face)
  426. (and (eq prop 'category)
  427. (get value 'face)))
  428. (integer-or-marker-p (overlay-start overlay))
  429. (integer-or-marker-p (overlay-end overlay)))
  430. (and (eq prop 'category)
  431. (setq value (get value 'face)))
  432. (cond
  433. ((symbolp value)
  434. (setq voice (voice-setup-get-voice-for-face value)))
  435. ((listp value)
  436. (setq voice
  437. (delq nil
  438. (mapcar
  439. #'voice-setup-get-voice-for-face value))))
  440. (t (message "Got %s" value)))
  441. (when voice
  442. (and emacspeak-personality-voiceify-overlays
  443. (funcall emacspeak-personality-voiceify-overlays
  444. (overlay-start overlay)
  445. (overlay-end overlay)
  446. voice))
  447. (overlay-put overlay 'personality voice))
  448. (when (and emacspeak-personality-show-unmapped-faces
  449. (not voice))
  450. (cond
  451. ((listp value)
  452. (mapcar #'(lambda (v)
  453. (puthash v t emacspeak-personality-unmapped-faces))
  454. value))
  455. (t (puthash value t
  456. emacspeak-personality-unmapped-faces)))))))
  457. (defadvice move-overlay (before emacspeak-personality pre act)
  458. "Used by emacspeak to augment font lock."
  459. (let ((overlay (ad-get-arg 0))
  460. (beg (ad-get-arg 1))
  461. (end (ad-get-arg 2))
  462. (object (ad-get-arg 3))
  463. (voice nil))
  464. (setq voice (overlay-get overlay 'personality))
  465. (when (and voice
  466. emacspeak-personality-voiceify-overlays
  467. (integer-or-marker-p (overlay-start overlay))
  468. (integer-or-marker-p (overlay-end overlay)))
  469. (emacspeak-personality-remove
  470. (overlay-start overlay)
  471. (overlay-end overlay)
  472. voice object)
  473. (funcall emacspeak-personality-voiceify-overlays
  474. beg end voice))))
  475. ;;}}}
  476. ;;{{{ silence font-lock's error messages
  477. (loop for f in
  478. '(font-lock-default-fontify-region
  479. font-lock-default-fontify-buffer)
  480. do
  481. (eval
  482. `(defadvice ,f (around emacspeak pre act comp)
  483. "Silence auditory feedback from redisplay errors."
  484. (ems-with-errors-silenced ad-do-it))))
  485. ;;}}}
  486. (provide 'emacspeak-personality )
  487. ;;{{{ end of file
  488. ;;; local variables:
  489. ;;; folded-file: t
  490. ;;; byte-compile-dynamic: t
  491. ;;; end:
  492. ;;}}}