Mercurial > hg > xemacs-beta
comparison lisp/behavior.el @ 2546:5d1743698fb3
[xemacs-hg @ 2005-02-03 05:26:39 by ben]
behavior ws #3: behavior updates
behavior.el: Major update. Add documentation of how it works.
behavior-defs.el: Only define the basic behavior groups here.
Move the definitions for particular packages to the
appropriate package files.
mwheel.el: Add define-behavior for mwheel.
author | ben |
---|---|
date | Thu, 03 Feb 2005 05:26:41 +0000 |
parents | 01c57eb70ae9 |
children | ebb35ddea76a |
comparison
equal
deleted
inserted
replaced
2545:9caf26dd924f | 2546:5d1743698fb3 |
---|---|
1 ;;; behavior.el --- consistent interface onto behaviors | 1 ;;; behavior.el --- consistent interface onto packages |
2 | 2 |
3 ;; Copyright (C) 2000, 2001, 2002 Ben Wing. | 3 ;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. |
4 | 4 |
5 ;; Author: Ben Wing | 5 ;; Author: Ben Wing |
6 ;; Maintainer: XEmacs Development Team | 6 ;; Maintainer: XEmacs Development Team |
7 ;; Keywords: internal, dumped | 7 ;; Keywords: internal, dumped |
8 | 8 |
29 | 29 |
30 ;; Created July 2000 by Ben Wing. | 30 ;; Created July 2000 by Ben Wing. |
31 | 31 |
32 ;;; Commentary: | 32 ;;; Commentary: |
33 | 33 |
34 ;; This file will be dumped with XEmacs. | 34 ;; This file is dumped with XEmacs. |
35 | |
36 ;; This file is part of the "Behaviors" project and is a work in progress. | |
37 ;; The purpose of the project is to provide (a) a consistent interface (at | |
38 ;; the API level) onto the functionality provided by packages, and (b) an | |
39 ;; easy-to-use user interface for this functionality, something that | |
40 ;; *really works*. | |
41 ;; | |
42 ;; First, what characteristics do/should packages have? (NOTE: In this | |
43 ;; discussion below, `package' and `behavior' are being used more or less | |
44 ;; interchangeably. Eventually this will get resolved.) | |
45 | |
46 ;; 1) A file, or one or more file, containing the code of the package. In | |
47 ;; addition, a "head" file in the case that the package needs to be | |
48 ;; loaded in order to get its functionality (e.g. "load-to-enable" | |
49 ;; packages -- an abomination that is tolerated only with severe | |
50 ;; displeasure). | |
51 ;; 2) A Lisp name -- a fairly short symbol (2-3 words max), uncapitalized, | |
52 ;; without use of excessive abbreviation and with words set off by | |
53 ;; dashes. This should be the same as the name of the topmost custom | |
54 ;; group associated with the package (see next item), and preferably the | |
55 ;; same as the common prefix used for variables defined by your package | |
56 ;; and the name of the head file of the package. | |
57 ;; 3) Associated custom group listing the settings associated with the package. | |
58 ;; 4) Enable and disable methods for turning on or off the functionality of | |
59 ;; the package, if it's amenable to such a model. Most packages are of two | |
60 ;; types: | |
61 ;; | |
62 ;; (a) They add some functionality to XEmacs, which is incorporated | |
63 ;; into and makes changes to the normal functionality of XEmacs. Once the | |
64 ;; package is enabled, the user doesn't have to do anything specific for | |
65 ;; the package to do its thing -- it happens automatically if the user is | |
66 ;; using the area whose behavior has been changed. These include packages | |
67 ;; such as `avoid' (which makes the mouse poointer move when the cursor | |
68 ;; gets too close), EFS (which adds the ability to treat an FTP site as | |
69 ;; part of the local file system), the packages that supply the | |
70 ;; mode-specific handling for various files, etc | |
71 ;; | |
72 ;; (b) They provide functionality in the form of specific command to be | |
73 ;; invoked. This can be as simple as the `hippie-expand' command (tries | |
74 ;; lots of different expansion methods for the text before point, to | |
75 ;; try and get a result) and as complicated as GNUS or VM. | |
76 ;; | |
77 ;; Some packages might provide both -- you can enable them and they | |
78 ;; incorporate some functionality into the XEmacs base, but while | |
79 ;; they're enabled they provide certain commands. #### We need some | |
80 ;; thought here, and case-by-case analysis, to determine if this really | |
81 ;; makes sense -- can the enable/disable be removed and whatever needs | |
82 ;; to happen incorporated as part of the command? can the | |
83 ;; enable/disable just added to the commands? | |
84 ;; | |
85 ;; 5) Packages of type (b) just above will have a list of commands that can be | |
86 ;; run. They should be in standard menubar format -- i.e. just like a | |
87 ;; submenu, but without the initial string indidicating the name of the | |
88 ;; menu. | |
89 ;; 6) Short doc string, for use in a menu item. *NOT* necessarily the same | |
90 ;; as the documentation for the Custom group, which is often too long. | |
91 ;; 7) Long documentation. | |
92 ;; | |
93 ;; Good package etiquette: | |
94 ;; | |
95 ;; | |
96 ;; -- Never mess with the menu yourself, or try to "cheat" by putting yourself | |
97 ;; high up in the hierarchy, e.g. at the top-level or directly off a | |
98 ;; top-level group that expects to contain only groups of groups, not | |
99 ;; end-level groups. | |
100 ;; | |
101 ;; -- Never use the `override-behavior' commands or the like for specifying | |
102 ;; (in an overriding fashion) the exact appearance of the hierarchies. | |
103 ;; | |
104 ;; -- For type (a), with enable/disable methods: | |
105 ;; | |
106 ;; (a) Loading the file should NOT DO ANYTHING. Not enable, not add hooks, | |
107 ;; nothing. | |
108 ;; (b) Both enable and disable hooks must exist. The disable hook must | |
109 ;; completely reset the environment to how it was before the package | |
110 ;; was enabled. This includes restoring the prior bindings for | |
111 ;; modified key bindings. #### We need some helper function to assist | |
112 ;; with remembering the old key bindings and putting them back only | |
113 ;; when new key bindings haven't been made -- but recognize when those | |
114 ;; new key bondings were attached as a result of loading another | |
115 ;; package, so that after any order of loading and unloading a series | |
116 ;; of packages, the original bindings will eventually occur. (Something | |
117 ;; like `advice' for key definitions.) Replacement of functions should | |
118 ;; happen through `advice'. | |
119 ;; | |
120 ;; We recognize that many packages out there don't follow these precepts at | |
121 ;; all. Many or most of them are install-only, often happening | |
122 ;; automatically when the file is loaded. Converting these will be a step | |
123 ;; at a time: First, redo the latter type so that the initialization code | |
124 ;; is put into a function and not run automatically upon load. Next step, | |
125 ;; try to provide some sort of disable. Third step, work on making sure | |
126 ;; that disable removes *everything* and enable puts it all back. Fourth | |
127 ;; step, work on properly advising keys and functions. | |
128 ;; | |
129 | |
130 ;; Comparison/Integration with Custom: | |
131 | |
132 ;; Custom only handles variable settings, and has no concept of standard | |
133 ;; enable/disable methods for a package, a standard way of specifying | |
134 ;; package documentation, or a list of commands associated with a package. | |
135 ;; Also, its groups do not always map very well onto packages and the | |
136 ;; resulting hierarchy is too big, confusing, difficult-to-navigate, and | |
137 ;; incoherent. More generally it does not address at all the basic problem | |
138 ;; that a hierarchy created in a decentralized fashion -- and by a large | |
139 ;; number of authors, some more competent than others -- will inevitably be | |
140 ;; incoherent when put together. | |
141 ;; | |
142 | |
143 ;; In general, ease-of-use was not the overarching goal of Custom. The | |
144 ;; primary goal of Custom seems to have been to provide a consistent interface | |
145 ;; and get all the packages to use it. Ease-of-use -- or even following | |
146 ;; established user-interface standards -- has taken a far-distant second, and | |
147 ;; appears in many respects to be an afterthought that never had any serious | |
148 ;; effort investigated into it. | |
149 ;; | |
150 ;; The eventual intent of this project is to integrate with custom. The final | |
151 ;; intent of integration is that this project subsumes Custom completely, | |
152 ;; making Custom the unified, user-friendly means of controlling XEmacs that | |
153 ;; has never properly existed. However, that will take a lot of work. For | |
154 ;; the meantime, the plan is to develop the Behavior subsystem independent of | |
155 ;; Custom, with ease-of-use as the primary goal, and get it to the point where | |
156 ;; it encompasses most packages out there, has stabilized its interface, and | |
157 ;; works well. At that point, we will consider integration with Custom. (Note | |
158 ;; that the hard part of the Behavior work is not actually behaviorizing the | |
159 ;; packages, but developing the interface itself.) | |
160 ;; | |
161 ;; As for integrating with Custom -- ideally that would mean simply extending | |
162 ;; defgroup, but that is not really possible given that backward-compatibility | |
163 ;; would not work -- existing versions of `defgroup' give an error when | |
164 ;; presented with an unknown keyword. In practice, then, this might mean that | |
165 ;; a separate `define-behavior' command (or `defpackage', or the like) will | |
166 ;; still exist. | |
35 | 167 |
36 ;;; Code: | 168 ;;; Code: |
37 | 169 |
38 ;; Hash table mapping behavior names to property lists, with entries for | 170 ;; Hash table mapping behavior names to property lists, with entries for |
39 ;; :short-doc, :require, :enable, and :disable. | 171 ;; :group, :custom-group, :short-doc, :require, :enable, :disable, |
172 ;; and :commands. | |
40 (defconst behavior-hash-table (make-hash-table)) | 173 (defconst behavior-hash-table (make-hash-table)) |
174 ;; Hash table mapping groups to property lists (entries for :group, :children, | |
175 ;; :short-doc). | |
176 (defconst behavior-group-hash-table (make-hash-table)) | |
177 ;; Hash table with override information for groups. | |
178 ;; :short-doc). | |
179 (defconst behavior-override-hash-table (make-hash-table)) | |
41 | 180 |
42 (defvar within-behavior-enabling-disabling nil) | 181 (defvar within-behavior-enabling-disabling nil) |
43 | 182 |
44 (defgroup behaviors nil | 183 (defgroup behaviors nil |
45 "Behaviors -- high-level functionality interface.") | 184 "Behaviors -- high-level functionality interface.") |
66 | 205 |
67 | 206 |
68 (defvar behavior-history nil | 207 (defvar behavior-history nil |
69 "History of entered behaviors.") | 208 "History of entered behaviors.") |
70 | 209 |
71 (defun define-behavior (name doc-string &rest cl-keys) | 210 (defun behavior-group-p (group) |
211 "Non-nil if GROUP is the name of a valid behavior group." | |
212 (not (null (gethash group behavior-group-hash-table)))) | |
213 | |
214 (defun check-behavior-group (group) | |
215 "Verify that GROUP is a valid behavior group, or nil. | |
216 Return GROUP if so." | |
217 (or (behavior-group-p group) | |
218 (error 'invalid-argument "Invalid behavior group" group)) | |
219 group) | |
220 | |
221 (defun* define-behavior (name doc-string &key | |
222 group custom-group | |
223 (short-doc | |
224 (capitalize-string-as-title | |
225 (replace-in-string (symbol-name name) "-" " "))) | |
226 require enable disable commands | |
227 &allow-other-keys) | |
228 ;; We allow other keys to allow for the possibility of extensions by | |
229 ;; later versions of XEmacs. Packages should be able to support those | |
230 ;; extensions without worrying about causing problems with older versions | |
231 ;; of XEmacs. | |
72 "Define a behavior named NAME. | 232 "Define a behavior named NAME. |
73 DOC-STRING must be specified, a description of what the behavior does | 233 DOC-STRING must be specified, a description of what the behavior does |
74 when it's enabled and how to further control it (typically through | 234 when it's enabled and how to further control it (typically through |
75 custom variables). Accepted keywords are | 235 custom variables). Accepted keywords are |
76 | 236 |
237 :group Symbol naming the behavior group this behavior is within. | |
238 :custom-group Symbol naming the custom group containing the options that | |
239 can be set in association with this behavior. If not specified, | |
240 the custom group with the same name as the behavior will be | |
241 used, if it exists. | |
77 :short-doc A \"pretty\" version of the name, for use in menus. If omitted | 242 :short-doc A \"pretty\" version of the name, for use in menus. If omitted |
78 a prettified name will be generated. | 243 a prettified name will be generated. |
79 :require A single symbol or a list of such symbols, which need to be | 244 :require A single symbol or a list of such symbols, which need to be |
80 present at enable time, or will be loaded using `require'. | 245 present at enable time, or will be loaded using `require'. |
81 :enable A function of no variables, which turns the behavior on. | 246 :enable A function of no variables, which turns the behavior on. |
82 :disable A function of no variables, which turns the behavior off. | 247 :disable A function of no variables, which turns the behavior off. |
248 :commands A list of interactive commands that can be invoked in | |
249 conjunction with the behavior. These will appear in a submenu | |
250 along with the rest of the items for the behavior. | |
83 | 251 |
84 Behaviors are assumed to be global, and to take effect immediately; if | 252 Behaviors are assumed to be global, and to take effect immediately; if |
85 the underlying package is per-buffer, it may have to scan all existing | 253 the underlying package is per-buffer, it may have to scan all existing |
86 buffers and frob them. When a behavior is disabled, it should completely | 254 buffers and frob them. When a behavior is disabled, it should completely |
87 go away *everywhere*, as if it were never invoked at all. | 255 go away *everywhere*, as if it were never invoked at all. |
88 | 256 |
89 The :disable keywords can be missing, although this is considered bad | 257 The :disable keyword can be missing, although this is considered bad |
90 practice. In such a case, attempting to disable the behavior will signal | 258 practice. In such a case, attempting to disable the behavior will signal |
91 an error unless you use the `force' option." | 259 an error unless you use the `force' option. |
92 (cl-parsing-keywords | 260 |
93 ((:short-doc (capitalize-string-as-title (replace-in-string | 261 The :enable keyword can be missing. This is useful for behaviors that |
94 (symbol-name name) "-" " "))) | 262 are really a series of related commands without anything semantically |
95 :require | 263 corresponding to \"turning on\" or \"turning off\" the behavior. |
96 :enable | 264 |
97 :disable) | 265 A behavior with no :enable and no :command is possible. This might be |
98 t | 266 used, for example, by a behavior that encapsulates a series of related |
99 (let ((entry (list :short-doc cl-short-doc :require cl-require | 267 Lisp functions. Such behaviors may be handled specially, e.g. not |
100 :enable cl-enable :disable cl-disable))) | 268 displayed in the menus or displayed in a separate location, since they |
101 (puthash name entry behavior-hash-table)))) | 269 have no user-invocable behavior." |
270 (let ((entry (list :group (check-behavior-group group) | |
271 :custom-group custom-group | |
272 :short-doc short-doc :require require | |
273 :enable enable :disable disable | |
274 :commands commands))) | |
275 (puthash name entry behavior-hash-table)) | |
276 ;; update the children list of the group we're in (maybe nil). | |
277 (unless (member name (getf (gethash group behavior-group-hash-table) | |
278 :children)) | |
279 (push name (getf (gethash group behavior-group-hash-table) :children)))) | |
280 | |
281 (defun* override-behavior (name &key | |
282 short-doc | |
283 group | |
284 include | |
285 demote-others) | |
286 "Override the default properties of a behavior group NAME. | |
287 Normally, groups are created and assigned properties by individual packages. | |
288 The resulting hierarchy may not make much sense globally. This function | |
289 allows the hierarchy and appearance of a group to be specified globally, | |
290 and will take precendence over the properties assigned by `define-behavior-group'. This allows a global organization to be imposed on groups, while still allowing for graceful handling of new or unknown groups. | |
291 | |
292 NAME can be a symbol specifying a group name, or a list of | |
293 \(PARENT [...] NAME), where a path from a particular parent is explicitly | |
294 given. (This latter form allows the same name to be assigned to more than one | |
295 group.) | |
296 | |
297 Accepted keywords are | |
298 | |
299 :short-doc A \"pretty\" version of the name, for use in menus. | |
300 :group Parent group, if any. Should not be given if the parents are | |
301 explicitly specified in NAME. | |
302 :include A list of behaviors that are specifically included in this | |
303 group, in addition to those that are included by the behaviors | |
304 themselves. | |
305 :demote-others If non-nil, exclude all behaviors not specified in the :include | |
306 list and put them instead (i.e. \"demote\" them) to another group, | |
307 usually a subgroup." | |
308 (let ((entry (list :group (check-behavior-group group) | |
309 :short-doc short-doc | |
310 :include include | |
311 :demote-others demote-others))) | |
312 (puthash name entry behavior-override-hash-table))) | |
313 | |
314 (defun* define-behavior-group (name &key | |
315 (short-doc | |
316 (capitalize-string-as-title | |
317 (replace-in-string (symbol-name name) "-" | |
318 " "))) | |
319 group) | |
320 "Define a behavior group NAME. | |
321 | |
322 NAME can be a symbol specifying a group name, or a list of | |
323 \(PARENT [...] NAME), where a path from a particular parent is explicitly | |
324 given. (This latter form allows the same name to be assigned to more than one | |
325 group.) | |
326 | |
327 Accepted keywords are | |
328 | |
329 :short-doc A \"pretty\" version of the name, for use in menus. If omitted | |
330 a prettified name will be generated. | |
331 :group Parent group, if any. Should not be given if the parents are | |
332 explicitly specified in NAME." | |
333 (let ((entry (list :group (check-behavior-group group) | |
334 :short-doc short-doc))) | |
335 (puthash name entry behavior-group-hash-table)) | |
336 ;; update the children list of the parent (maybe nil). | |
337 (push name (getf (gethash group behavior-group-hash-table) :children))) | |
102 | 338 |
103 (defun read-behavior (prompt &optional must-match initial-contents history | 339 (defun read-behavior (prompt &optional must-match initial-contents history |
104 default-value) | 340 default-value) |
105 "Return a behavior symbol from the minibuffer, prompting with string PROMPT. | 341 "Return a behavior symbol from the minibuffer, prompting with string PROMPT. |
106 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert | 342 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert |
107 in the minibuffer before reading. | 343 in the minibuffer before reading. |
108 Third arg HISTORY, if non-nil, specifies a history list. (It defaults to | 344 Third arg HISTORY, if non-nil, specifies a history list. (It defaults to |
109 `behavior-history'.) | 345 `behavior-history'.) |
117 (maphash #'(lambda (key val) | 353 (maphash #'(lambda (key val) |
118 (push (cons key val) lis)) | 354 (push (cons key val) lis)) |
119 behavior-hash-table) | 355 behavior-hash-table) |
120 (nreverse lis)))) | 356 (nreverse lis)))) |
121 (mapc #'(lambda (aentry) | 357 (mapc #'(lambda (aentry) |
122 (setcar aentry (symbol-name | 358 (setcar aentry (symbol-name (car aentry)))) |
123 (car aentry)))) | |
124 table) | 359 table) |
125 table) | 360 table) |
126 nil must-match initial-contents | 361 nil must-match initial-contents (or history 'behavior-history) |
127 (or history 'behavior-history) | |
128 default-value))) | 362 default-value))) |
129 (if (and result (stringp result)) | 363 (if (and result (stringp result)) |
130 (intern result) | 364 (intern result) |
131 result))) | 365 result))) |
132 | 366 |
177 (message "Disabling behavior %s...done" behavior) | 411 (message "Disabling behavior %s...done" behavior) |
178 (let ((within-behavior-enabling-disabling t)) | 412 (let ((within-behavior-enabling-disabling t)) |
179 (customize-set-variable 'enabled-behavior-list | 413 (customize-set-variable 'enabled-behavior-list |
180 (delq behavior enabled-behavior-list)))))) | 414 (delq behavior enabled-behavior-list)))))) |
181 | 415 |
416 (defun compute-behavior-group-children (group hash) | |
417 "Compute the actual children for GROUP and its subgroups. | |
418 This takes into account the override information specified." | |
419 (let* ((group-plist (gethash group behavior-group-hash-table)) | |
420 (override (gethash group behavior-override-hash-table)) | |
421 (children (getf group-plist :children))) | |
422 ) | |
423 ) | |
424 | |
425 (defun behavior-menu-filter-1 (menu group) | |
426 (submenu-generate-accelerator-spec | |
427 (let* ( | |
428 ;;options | |
429 ;;help | |
430 (enable | |
431 (menu-split-long-menu | |
432 (menu-sort-menu | |
433 (let ((group-plist (gethash group behavior-group-hash-table))) | |
434 (loop for behavior in (getf group-plist :children) | |
435 nconc (if (behavior-group-p behavior) | |
436 (list | |
437 (cons (getf | |
438 (gethash behavior behavior-group-hash-table) | |
439 :short-doc) | |
440 (behavior-menu-filter-1 menu behavior))) | |
441 (let* ((plist (gethash behavior behavior-hash-table)) | |
442 (commands (getf plist :commands))) | |
443 (nconc | |
444 (if (getf plist :enable) | |
445 `([,(format "%s (%s) [toggle]" | |
446 (getf plist :short-doc) | |
447 behavior) | |
448 (if (memq ',behavior | |
449 enabled-behavior-list) | |
450 (disable-behavior ',behavior) | |
451 (enable-behavior ',behavior)) | |
452 :active ,(if (getf plist :disable) t | |
453 (not (memq | |
454 ',behavior | |
455 enabled-behavior-list))) | |
456 :style toggle | |
457 :selected (memq ',behavior | |
458 enabled-behavior-list)])) | |
459 (cond ((null commands) nil) | |
460 ((and (eq (length commands) 1) | |
461 (vectorp (elt commands 0))) | |
462 (let ((comm (copy-sequence | |
463 (elt commands 0)))) | |
464 (setf (elt comm 0) | |
465 (format "%s (%s)" | |
466 (elt comm 0) behavior)) | |
467 (list comm))) | |
468 (t (list | |
469 (cons (format "%s (%s) Commands" | |
470 (getf plist :short-doc) | |
471 behavior) | |
472 commands))))))))) | |
473 )) | |
474 ) | |
475 ) | |
476 enable) | |
477 '(?p))) | |
478 | |
479 (defun behavior-menu-filter (menu) | |
480 (append | |
481 '(("%_Package Utilities" | |
482 ("%_Set Download Site" | |
483 ("%_Official Releases" | |
484 :filter (lambda (&rest junk) | |
485 (menu-split-long-menu | |
486 (submenu-generate-accelerator-spec | |
487 (package-ui-download-menu))))) | |
488 ("%_Pre-Releases" | |
489 :filter (lambda (&rest junk) | |
490 (menu-split-long-menu | |
491 (submenu-generate-accelerator-spec | |
492 (package-ui-pre-release-download-menu))))) | |
493 ("%_Site Releases" | |
494 :filter (lambda (&rest junk) | |
495 (menu-split-long-menu | |
496 (submenu-generate-accelerator-spec | |
497 (package-ui-site-release-download-menu)))))) | |
498 "--:shadowEtchedIn" | |
499 ["%_Update Package Index" package-get-update-base] | |
500 ["%_List and Install" pui-list-packages] | |
501 ["U%_pdate Installed Packages" package-get-update-all] | |
502 ["%_Help" (Info-goto-node "(xemacs)Packages")]) | |
503 "----") | |
504 (behavior-menu-filter-1 menu nil))) | |
505 | |
506 ;; Initialize top-level group. | |
507 (puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table) | |
508 | |
182 (provide 'behavior) | 509 (provide 'behavior) |
183 | 510 |
184 ;;; finder-inf.el ends here | 511 ;;; finder-inf.el ends here |