Mercurial > hg > xemacs-beta

comparison lisp/behavior.el @ 2546:5d1743698fb3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[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