;;; alternative.el -- manage competing packages
;; Copyright (C) 1998 Free Software Foundation, Inc.

;; Version: 0.01
;; Author: Jan Vroonhof <vroonhof@math.ethz.ch>,
;; Keywords: custom, packages

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;; This package is designed for the XEmacs package system to do deal
;; with competing packages implementing the same functionality. For
;; example vc and pcl-cvs both implement a version control interface.
;; However it is worthwile that when at least one of them is present
;; the user gets version control support enabled by default[1].
;; For simplicity the user is presented with an exclusive choice.
;;
;; Other design features
;;    - User can decide to have none of the package enabled
;;    - Site/Sumo/XEmacs maintainer can choose the default
;;         [like VC for backwards compatability]
;;    - To cater for obnoxious packages like VC the packages are not
;;      actually activated till after reading of custom-file, .emacs
;;      etc.
;;    - The above also allows (setq.. ) style setting in .emacs.
;;    - Customizing does the right thing.
;;    - If all packages provide a sensible installedp function, then it 
;;      possible to not overide any hand-made settings the user has
;;      from the old days.
;;
;; [1] Especially since VC even disappears from the menus!
;; 
;; Interface
;;
;; Each such alternative is given its own symbol, using
;; defalternative. Then each possible choice is defined using
;; defoption. I suggests this happens in the packages themselves using
;; autoload cookies.
;;
;; A simple example
;;
;; [in both a.el and b.el or somewhere global]
;;
;; (defvar aorb nil)
;;
;; (defalternative alt-aorb "Do we want A or B?"
;;   :tag "A or B")
;;
;; [in package A, say A.el]
;; 
;; (defoption alt-aorb opt-a "We do A"
;;   :tag "A"
;;   :install-function (lambda nil (setq-default aorb 'A))
;;   :uninstall-function (lambda nil (if (eq aorb 'A) (setq-default aorb nil)))
;;   :installed-p-function (lambda nil (eq aorb 'A)))
;;
;; [in package B, say B.el]
;;
;; (defoption alt-aorb opt-b "B is no B"
;;   :tag "B"
;;   :install-function (lambda nil (setq-default aorb 'B))
;;   :uninstall-function (lambda nil (if (eq aorb 'B) (setq-default aorb nil)))
;;   :installed-p-function (lambda nil (eq aorb 'B)))

;;  A maintainer can decide that normally A should be prefered if
;;  available, like this:
;;
;;  (defun prefer-a ()
;;   (when (memq 'opt-a (alternative-get-options 'alt-aorb))
;;     (alternative-set-default 'alt-aorb 'opt-a)))
;;
;;  (add-hook 'alternative-before-init-hook 'prefer-a)
;;
;;
;;  See also vc-alt.el for a more realistic example.
;;
;; Todo:  * Complete docstrings of functions
;;        * Add handling for doc arguments in alternative widget


;;; Code:
(defgroup alternatives nil
  "Alternatives"
  :group 'emacs)

(defvar alternative-alternatives nil
  "List of known alternatives. Do not add to this list directly.
Use defalternative")

(defvar alternative-before-init-hook nil
  "Functions to be called before initializing the alterantives.
   Use this for example to force a certain default.")


(define-widget 'alternative 'radio
  "A list of alternatives"
  :convert-widget 'alternative-alternative-convert-widget
  :match 'widget-choice-match
  :match-inline 'widget-choice-match-inline
  :tag "Alternatives")

(defun alternative-convert-options (option)
  (let ((tag (get option :tag)))
    (if tag `(const :tag ,tag ,option)
      `(const ,option))))

(defsubst alternative-get-options (alternative)
  (append (get alternative 'custom-options) nil))

(defsubst alternative-set-default (alternative default)
  (put alternative 'standard-setting `(list (quote ,default))))
  	    
(defun alternative-alternative-convert-widget (widget)
  (let* ((options (widget-get widget :options))
	 (args (append (mapcar 'alternative-convert-options options)
		      '((const :tag "None" )))))
    (widget-put widget :args args)
    widget))
	  

(defun alternative-define-alternative (alternative doc group tag)
  "Like defalternative but does not quote arguments"
  (unless (memq alternative alternative-alternatives)
    (custom-declare-variable alternative '(quote unspecified) doc
			     :type 'sexp
			     :type 'alternative
			     :tag tag
			     :initialize 'custom-initialize-default
			     :set 'alternative-set
			     :group group)
    (put alternative 'alternative-initialized nil)
;;    (put alternative 'custom-options '(nil))
    (push alternative alternative-alternatives)))


(defmacro* defalternative (alternative doc &key tag (group 'alternatives))
  "Define an package-alternative named by symbol ALTERNATIVE. A
  textual name can be given using the optional :tag argument. The
  optional :group argument puts the widget in that Custom group. The
  default is 'alternatives'"
  `(alternative-define-alternative (quote ,alternative) ,doc (quote ,group) ,tag))

(defun alternative-define-option (alternative option doc tag install-function
                      uninstall-function installed-p-function make-default)
  (unless (memq alternative alternative-alternatives)
    (error "Unkown alternative %s." alteranive))
  (unless (symbolp option)
    (error "Option must be symbol"))
  (put option :doc doc)
  (put option :tag tag)
  (put option :install-function install-function)
  (put option :uninstall-function uninstall-function)
  (put option :installed-p-function installed-p-function)
  (custom-add-option alternative option)
  (when (and make-default (eq (eval (car (get alternative 'standard-value)))
			      'unspecified))
    (put alternative 'standard-value (list `(quote ,option)))))

(defmacro* defoption (alternative option &optional doc
				  &key tag install-function
                      uninstall-function installed-p-function
		      ((:default make-default) t))
  "Define an possible package OPTION for alternative ALTERNATIVE. Both 
are unquoted symbols.  To (de-)activate the package the following
functions can be supplied.  All functions should be idempotent (f.e.
installing twice should not give errors or unexpected results).  All
functions are called with no arguments.

:install-function     Function to be called to enable the package for
                      this session.
:uninstall-function   Function to be called to disable the package for
                      this session. Must not fail when package is not
                      installed.
:installed-p-function Function must return non-NIL when it fairly sure 
                      the package is activated in this session.

Further arguments

:default              When this option is non-nil (default) then this
                      package is enabled by default when no other
                      packages have been previously defined for this
                      option. "
  `(alternative-define-option (quote ,alternative) (quote ,option)
			      ,doc ,tag ,install-function
			      ,uninstall-function ,installed-p-function
			      ,make-default))


(defun alternative-set (alternative option)
  "Change the alternative, calling the appropriate functions
   if the alternative-initialize property is not set."
  (let ((old (default-value alternative)))
;    silently ignore setting to unknown options, reverting to none
    (setq option
	  (if (memq option (get alternative 'custom-options))
	      option))	    
    (when (and (get alternative 'alternative-initialized)
	       (not (eq old option)))
      (unless 
	  (or (memq old '(unspecified nil))
	      (not (get old :uninstall-function)))
	(funcall (get old :uninstall-function)))
      (when (get option :install-function)
	(funcall (get option :install-function))))
    (set-default alternative option)))

(defun alternative-installed-p (alternative option &optional sure)
  (when (memq option (get alternative 'custom-options))
    (if (get option :installed-p-function)
	(funcall (get option :installed-p-function))
      (not sure))))

(defun alternative-initialize (alternative)
  "Activate ALTERNATIVE, guess if still unspecifed"
  (unless (get alternative 'alternative-initialized)
    (put alternative 'alternative-initialized t)
    (let ((current (default-value alternative))
	  (options (get alternative 'custom-options)))
      ;; The true standard value is 'None' = nil
      (when (eq (eval (car (get alternative 'standard-value)))
		'unspecified)
	(put alternative 'standard-value (list nil)))
      (when (eq current 'unspecified)
	;; may be the user has set it "by hand"
	;; so try to be backwards compatibible
	(setq current nil)
	(while (and (null current) options)
	  (if (alternative-installed-p alternative (car options) t)
	      (setq current (car options)))
	  (setq options (cdr options)))
	;; If we did not find any plausible options, use the default
	(unless current
	  (setq current (eval (car (get alternative 'standard-value))))))
      (alternative-set alternative current))))

(defun alternative-initialize-alternatives ()
  (run-hooks 'alternative-before-init-hook)
  (mapc 'alternative-initialize alternative-alternatives))
       
(add-hook 'after-init-hook 'alternative-initialize-alternatives)


(provide 'alternative)