--- a/lisp/behavior.el	Thu Feb 03 05:03:45 2005 +0000
+++ b/lisp/behavior.el	Thu Feb 03 05:26:41 2005 +0000
@@ -1,6 +1,6 @@
-;;; behavior.el --- consistent interface onto behaviors
+;;; behavior.el --- consistent interface onto packages
 
-;; Copyright (C) 2000, 2001, 2002 Ben Wing.
+;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing.
 
 ;; Author: Ben Wing
 ;; Maintainer: XEmacs Development Team
@@ -31,13 +31,152 @@
 
 ;;; Commentary:
 
-;; This file will be dumped with XEmacs.
+;; This file is dumped with XEmacs.
+
+;; This file is part of the "Behaviors" project and is a work in progress.
+;; The purpose of the project is to provide (a) a consistent interface (at
+;; the API level) onto the functionality provided by packages, and (b) an
+;; easy-to-use user interface for this functionality, something that
+;; *really works*.
+;;
+;; First, what characteristics do/should packages have? (NOTE: In this
+;; discussion below, `package' and `behavior' are being used more or less
+;; interchangeably.  Eventually this will get resolved.)
+
+;; 1) A file, or one or more file, containing the code of the package.  In
+;;    addition, a "head" file in the case that the package needs to be
+;;    loaded in order to get its functionality (e.g. "load-to-enable"
+;;    packages -- an abomination that is tolerated only with severe
+;;    displeasure).
+;; 2) A Lisp name -- a fairly short symbol (2-3 words max), uncapitalized,
+;;    without use of excessive abbreviation and with words set off by
+;;    dashes.  This should be the same as the name of the topmost custom
+;;    group associated with the package (see next item), and preferably the
+;;    same as the common prefix used for variables defined by your package
+;;    and the name of the head file of the package.
+;; 3) Associated custom group listing the settings associated with the package.
+;; 4) Enable and disable methods for turning on or off the functionality of
+;;    the package, if it's amenable to such a model.  Most packages are of two
+;;    types:
+;; 
+;;    (a) They add some functionality to XEmacs, which is incorporated
+;;    into and makes changes to the normal functionality of XEmacs.  Once the
+;;    package is enabled, the user doesn't have to do anything specific for
+;;    the package to do its thing -- it happens automatically if the user is
+;;    using the area whose behavior has been changed.  These include packages
+;;    such as `avoid' (which makes the mouse poointer move when the cursor
+;;    gets too close), EFS (which adds the ability to treat an FTP site as
+;;    part of the local file system), the packages that supply the
+;;    mode-specific handling for various files, etc
+;; 
+;;    (b) They provide functionality in the form of specific command to be
+;;    invoked.  This can be as simple as the `hippie-expand' command (tries
+;;    lots of different expansion methods for the text before point, to
+;;    try and get a result) and as complicated as GNUS or VM.
+;; 
+;;    Some packages might provide both -- you can enable them and they
+;;    incorporate some functionality into the XEmacs base, but while
+;;    they're enabled they provide certain commands.  #### We need some
+;;    thought here, and case-by-case analysis, to determine if this really
+;;    makes sense -- can the enable/disable be removed and whatever needs
+;;    to happen incorporated as part of the command?  can the
+;;    enable/disable just added to the commands?
+;; 
+;; 5) Packages of type (b) just above will have a list of commands that can be
+;;    run.  They should be in standard menubar format -- i.e. just like a
+;;    submenu, but without the initial string indidicating the name of the
+;;    menu.
+;; 6) Short doc string, for use in a menu item.  *NOT* necessarily the same
+;;    as the documentation for the Custom group, which is often too long.
+;; 7) Long documentation.
+;; 
+;; Good package etiquette:
+;; 
+;; 
+;; -- Never mess with the menu yourself, or try to "cheat" by putting yourself
+;;    high up in the hierarchy, e.g. at the top-level or directly off a
+;;    top-level group that expects to contain only groups of groups, not
+;;    end-level groups.
+;; 
+;; -- Never use the `override-behavior' commands or the like for specifying
+;; (in an overriding fashion) the exact appearance of the hierarchies.
+;; 
+;; -- For type (a), with enable/disable methods:
+;; 
+;;    (a) Loading the file should NOT DO ANYTHING.  Not enable, not add hooks,
+;;        nothing.
+;;    (b) Both enable and disable hooks must exist.  The disable hook must
+;;        completely reset the environment to how it was before the package
+;;        was enabled.  This includes restoring the prior bindings for
+;;        modified key bindings.  #### We need some helper function to assist
+;;        with remembering the old key bindings and putting them back only
+;;        when new key bindings haven't been made -- but recognize when those
+;;        new key bondings were attached as a result of loading another
+;;        package, so that after any order of loading and unloading a series
+;;        of packages, the original bindings will eventually occur. (Something
+;;        like `advice' for key definitions.) Replacement of functions should
+;;        happen through `advice'.
+;; 
+;;    We recognize that many packages out there don't follow these precepts at
+;;    all.  Many or most of them are install-only, often happening
+;;    automatically when the file is loaded.  Converting these will be a step
+;;    at a time: First, redo the latter type so that the initialization code
+;;    is put into a function and not run automatically upon load.  Next step,
+;;    try to provide some sort of disable.  Third step, work on making sure
+;;    that disable removes *everything* and enable puts it all back.  Fourth
+;;    step, work on properly advising keys and functions.
+;; 
+
+;; Comparison/Integration with Custom:
+
+;; Custom only handles variable settings, and has no concept of standard
+;; enable/disable methods for a package, a standard way of specifying
+;; package documentation, or a list of commands associated with a package.
+;; Also, its groups do not always map very well onto packages and the
+;; resulting hierarchy is too big, confusing, difficult-to-navigate, and
+;; incoherent.  More generally it does not address at all the basic problem
+;; that a hierarchy created in a decentralized fashion -- and by a large
+;; number of authors, some more competent than others -- will inevitably be
+;; incoherent when put together.
+;;
+
+;; In general, ease-of-use was not the overarching goal of Custom.  The
+;; primary goal of Custom seems to have been to provide a consistent interface
+;; and get all the packages to use it.  Ease-of-use -- or even following
+;; established user-interface standards -- has taken a far-distant second, and
+;; appears in many respects to be an afterthought that never had any serious
+;; effort investigated into it.
+;; 
+;; The eventual intent of this project is to integrate with custom.  The final
+;; intent of integration is that this project subsumes Custom completely,
+;; making Custom the unified, user-friendly means of controlling XEmacs that
+;; has never properly existed.  However, that will take a lot of work.  For
+;; the meantime, the plan is to develop the Behavior subsystem independent of
+;; Custom, with ease-of-use as the primary goal, and get it to the point where
+;; it encompasses most packages out there, has stabilized its interface, and
+;; works well.  At that point, we will consider integration with Custom. (Note
+;; that the hard part of the Behavior work is not actually behaviorizing the
+;; packages, but developing the interface itself.)
+;; 
+;; As for integrating with Custom -- ideally that would mean simply extending
+;; defgroup, but that is not really possible given that backward-compatibility
+;; would not work -- existing versions of `defgroup' give an error when
+;; presented with an unknown keyword.  In practice, then, this might mean that
+;; a separate `define-behavior' command (or `defpackage', or the like) will
+;; still exist.
 
 ;;; Code:
 
 ;; Hash table mapping behavior names to property lists, with entries for
-;; :short-doc, :require, :enable, and :disable.
+;; :group, :custom-group, :short-doc, :require, :enable, :disable,
+;; and :commands.
 (defconst behavior-hash-table (make-hash-table))
+;; Hash table mapping groups to property lists (entries for :group, :children,
+;; :short-doc).
+(defconst behavior-group-hash-table (make-hash-table))
+;; Hash table with override information for groups.
+;; :short-doc).
+(defconst behavior-override-hash-table (make-hash-table))
 
 (defvar within-behavior-enabling-disabling nil)
 
@@ -68,40 +207,137 @@
 (defvar behavior-history nil
   "History of entered behaviors.")
 
-(defun define-behavior (name doc-string &rest cl-keys)
+(defun behavior-group-p (group)
+  "Non-nil if GROUP is the name of a valid behavior group."
+  (not (null (gethash group behavior-group-hash-table))))
+
+(defun check-behavior-group (group)
+  "Verify that GROUP is a valid behavior group, or nil.
+Return GROUP if so."
+  (or (behavior-group-p group)
+      (error 'invalid-argument "Invalid behavior group" group))
+  group)
+
+(defun* define-behavior (name doc-string &key
+			 group custom-group
+			 (short-doc
+			  (capitalize-string-as-title
+			   (replace-in-string (symbol-name name) "-" " ")))
+			 require enable disable commands
+			 &allow-other-keys)
+  ;; We allow other keys to allow for the possibility of extensions by
+  ;; later versions of XEmacs.  Packages should be able to support those
+  ;; extensions without worrying about causing problems with older versions
+  ;; of XEmacs.
   "Define a behavior named NAME.
 DOC-STRING must be specified, a description of what the behavior does
 when it's enabled and how to further control it (typically through
 custom variables).  Accepted keywords are
 
+:group	    Symbol naming the behavior group this behavior is within.
+:custom-group Symbol naming the custom group containing the options that
+            can be set in association with this behavior.  If not specified,
+            the custom group with the same name as the behavior will be
+            used, if it exists.
 :short-doc  A \"pretty\" version of the name, for use in menus.  If omitted
               a prettified name will be generated.
 :require    A single symbol or a list of such symbols, which need to be
               present at enable time, or will be loaded using `require'.
 :enable     A function of no variables, which turns the behavior on.
 :disable    A function of no variables, which turns the behavior off.
+:commands   A list of interactive commands that can be invoked in
+            conjunction with the behavior.  These will appear in a submenu
+            along with the rest of the items for the behavior.
 
 Behaviors are assumed to be global, and to take effect immediately; if
 the underlying package is per-buffer, it may have to scan all existing
 buffers and frob them.  When a behavior is disabled, it should completely
 go away *everywhere*, as if it were never invoked at all.
 
-The :disable keywords can be missing, although this is considered bad
+The :disable keyword can be missing, although this is considered bad
 practice.  In such a case, attempting to disable the behavior will signal
-an error unless you use the `force' option."
-  (cl-parsing-keywords
-      ((:short-doc (capitalize-string-as-title (replace-in-string
-						(symbol-name name) "-" " ")))
-       :require
-       :enable
-       :disable)
-      t
-    (let ((entry (list :short-doc cl-short-doc :require cl-require
-		       :enable cl-enable :disable cl-disable)))
-      (puthash name entry behavior-hash-table))))
+an error unless you use the `force' option.
+
+The :enable keyword can be missing.  This is useful for behaviors that
+are really a series of related commands without anything semantically
+corresponding to \"turning on\" or \"turning off\" the behavior.
+
+A behavior with no :enable and no :command is possible.  This might be
+used, for example, by a behavior that encapsulates a series of related
+Lisp functions.  Such behaviors may be handled specially, e.g. not
+displayed in the menus or displayed in a separate location, since they
+have no user-invocable behavior."
+  (let ((entry (list :group (check-behavior-group group)
+		     :custom-group custom-group
+		     :short-doc short-doc :require require
+		     :enable enable :disable disable
+		     :commands commands)))
+    (puthash name entry behavior-hash-table))
+  ;; update the children list of the group we're in (maybe nil).
+  (unless (member name (getf (gethash group behavior-group-hash-table)
+			     :children))
+    (push name (getf (gethash group behavior-group-hash-table) :children))))
+
+(defun* override-behavior (name &key
+			   short-doc
+			   group
+			   include
+			   demote-others)
+  "Override the default properties of a behavior group NAME.
+Normally, groups are created and assigned properties by individual packages.
+The resulting hierarchy may not make much sense globally.  This function
+allows the hierarchy and appearance of a group to be specified globally,
+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.
+
+NAME can be a symbol specifying a group name, or a list of
+\(PARENT [...] NAME), where a path from a particular parent is explicitly
+given. (This latter form allows the same name to be assigned to more than one
+group.)
+
+Accepted keywords are
+
+:short-doc  A \"pretty\" version of the name, for use in menus.
+:group      Parent group, if any.  Should not be given if the parents are
+            explicitly specified in NAME.
+:include    A list of behaviors that are specifically included in this
+            group, in addition to those that are included by the behaviors
+            themselves.
+:demote-others If non-nil, exclude all behaviors not specified in the :include
+            list and put them instead (i.e. \"demote\" them) to another group,
+            usually a subgroup."
+  (let ((entry (list :group (check-behavior-group group)
+		     :short-doc short-doc
+		     :include include
+		     :demote-others demote-others)))
+    (puthash name entry behavior-override-hash-table)))
+
+(defun* define-behavior-group (name &key
+			       (short-doc
+				(capitalize-string-as-title
+				 (replace-in-string (symbol-name name) "-"
+						    " ")))
+			       group)
+  "Define a behavior group NAME.
+
+NAME can be a symbol specifying a group name, or a list of
+\(PARENT [...] NAME), where a path from a particular parent is explicitly
+given. (This latter form allows the same name to be assigned to more than one
+group.)
+
+Accepted keywords are
+
+:short-doc  A \"pretty\" version of the name, for use in menus.  If omitted
+              a prettified name will be generated.
+:group      Parent group, if any.  Should not be given if the parents are
+            explicitly specified in NAME."
+  (let ((entry (list :group (check-behavior-group group)
+		     :short-doc short-doc)))
+    (puthash name entry behavior-group-hash-table))
+  ;; update the children list of the parent (maybe nil).
+  (push name (getf (gethash group behavior-group-hash-table) :children)))
 
 (defun read-behavior (prompt &optional must-match initial-contents history
-			     default-value)
+		      default-value)
   "Return a behavior symbol from the minibuffer, prompting with string PROMPT.
 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
  in the minibuffer before reading.
@@ -119,12 +355,10 @@
 				  behavior-hash-table)
 			 (nreverse lis))))
 	    (mapc #'(lambda (aentry)
-		      (setcar aentry (symbol-name
-				      (car aentry))))
+		      (setcar aentry (symbol-name (car aentry))))
 		  table)
 	    table)
-	  nil must-match initial-contents
-	  (or history 'behavior-history)
+	  nil must-match initial-contents (or history 'behavior-history)
 	  default-value)))
     (if (and result (stringp result))
 	(intern result)
@@ -179,6 +413,99 @@
 	(customize-set-variable 'enabled-behavior-list
 				(delq behavior enabled-behavior-list))))))
 
+(defun compute-behavior-group-children (group hash)
+  "Compute the actual children for GROUP and its subgroups.
+This takes into account the override information specified."
+  (let* ((group-plist (gethash group behavior-group-hash-table))
+	 (override (gethash group behavior-override-hash-table))
+	 (children (getf group-plist :children)))
+    )
+  )
+
+(defun behavior-menu-filter-1 (menu group)
+  (submenu-generate-accelerator-spec
+   (let* (
+	  ;;options
+	  ;;help
+	  (enable
+	   (menu-split-long-menu
+	    (menu-sort-menu
+	     (let ((group-plist (gethash group behavior-group-hash-table)))
+	       (loop for behavior in (getf group-plist :children)
+		 nconc (if (behavior-group-p behavior)
+			   (list
+			    (cons (getf
+				   (gethash behavior behavior-group-hash-table)
+				   :short-doc)
+				  (behavior-menu-filter-1 menu behavior)))
+			 (let* ((plist (gethash behavior behavior-hash-table))
+				(commands (getf plist :commands)))
+			   (nconc
+			    (if (getf plist :enable)
+				`([,(format "%s (%s) [toggle]"
+					    (getf plist :short-doc)
+					    behavior)
+				   (if (memq ',behavior
+					     enabled-behavior-list)
+				       (disable-behavior ',behavior)
+				     (enable-behavior ',behavior))
+				   :active ,(if (getf plist :disable) t
+					      (not (memq
+						    ',behavior
+						    enabled-behavior-list)))
+				   :style toggle
+				   :selected (memq ',behavior
+						   enabled-behavior-list)]))
+			    (cond ((null commands) nil)
+				  ((and (eq (length commands) 1)
+					(vectorp (elt commands 0)))
+				   (let ((comm (copy-sequence
+						(elt commands 0))))
+				     (setf (elt comm 0)
+					   (format "%s (%s)"
+						   (elt comm 0) behavior))
+				     (list comm)))
+				  (t (list
+				      (cons (format "%s (%s) Commands"
+						    (getf plist :short-doc)
+						    behavior)
+					    commands)))))))))
+	     ))
+	   )
+	  )
+     enable)
+   '(?p)))
+
+(defun behavior-menu-filter (menu)
+  (append
+   '(("%_Package Utilities"
+       ("%_Set Download Site"
+	("%_Official Releases"
+	 :filter (lambda (&rest junk)
+		   (menu-split-long-menu
+		    (submenu-generate-accelerator-spec
+		     (package-ui-download-menu)))))
+	("%_Pre-Releases"
+	 :filter (lambda (&rest junk)
+		   (menu-split-long-menu
+		    (submenu-generate-accelerator-spec
+		     (package-ui-pre-release-download-menu)))))
+	("%_Site Releases"
+	 :filter (lambda (&rest junk)
+		   (menu-split-long-menu
+		    (submenu-generate-accelerator-spec
+		     (package-ui-site-release-download-menu))))))
+       "--:shadowEtchedIn"
+      ["%_Update Package Index" package-get-update-base]
+      ["%_List and Install" pui-list-packages]
+      ["U%_pdate Installed Packages" package-get-update-all]
+      ["%_Help" (Info-goto-node "(xemacs)Packages")])
+     "----")
+   (behavior-menu-filter-1 menu nil)))
+
+;; Initialize top-level group.
+(puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table)
+
 (provide 'behavior)
 
 ;;; finder-inf.el ends here