;;!emacs
;; $Id:
;;
;; FILE:         hact.el
;; SUMMARY:      Hyperbole button action handling.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    18-Sep-91 at 02:57:09
;; LAST-MOD:     17-May-93 at 18:50:39 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; 
;; Copyright (C) 1991, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; 
;; Permission to use, modify and redistribute this software and its
;; documentation for any purpose other than its incorporation into a
;; commercial product is hereby granted without fee.  A distribution fee
;; may be charged with any redistribution.  Any distribution requires
;; that the above copyright notice appear in all copies, that both that
;; copyright notice and this permission notice appear in supporting
;; documentation, and that neither the name of Brown University nor the
;; author's name be used in advertising or publicity pertaining to
;; distribution of the software without specific, written prior permission.
;; 
;; Brown University makes no representations about the suitability of this
;; software for any purpose.  It is provided "as is" without express or
;; implied warranty.
;;
;;
;; DESCRIPTION:  
;; DESCRIP-END.

;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************


(require 'hhist)

;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

(defvar hrule:action 'actype:act
  "Value is a function of any number of arguments that executes actions.
Variable is used to vary actual effect of evaluating a Hyperbole action,
e.g. to inhibit actions.")

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

;;; ========================================================================
;;; action class
;;; ========================================================================

(fset 'action:commandp 'commandp)
(defun action:create (param-list body)
  "Create an action defined by PARAM-LIST and BODY, a list of Lisp forms."
  (if (symbolp body)
      body
    (cons 'lambda (cons param-list body))))

(defun action:act (hbut action &optional same-window)
  "DON'T CALL THIS FUNCTION.  USE actype:act INSTEAD.
USED ONLY BY VERSION 1 HYPERBOLE BUTTONS.
Performs HBUT's ACTION.
An action may be a symbol, key sequence string, or any Lisp form.
Call 'action:kbd-macro' to create an action which executes a keyboard macro.
Optional SAME-WINDOW (only used by version 1 buttons) means output from
action should appear in same window.
Runs 'action:act-hook' before performing ACTION."
  (let ((prefix-arg current-prefix-arg)
	(args (hattr:get hbut 'args))
	(act '(apply action args)))
    (if (null action)
	nil
      (let ((hist-elt (hhist:element)))
	(run-hooks 'action:act-hook)
	(cond ((symbolp action)
	       (let ((sym-name (symbol-name action))
		     action-name)
		 ;; Hyperbole Version 1 compatibility
		 (if (= (length sym-name) 2)
		     (hyperb:action-v1)
		   (if (boundp action)
		       (eval act)
		     (error "(action:act): Action not defined: '%s'"
			    (symbol-name action))))))
	      ((listp action)
	       (eval act))
	      ((and (stringp action)
		    (setq action (key-binding action))
		    (not (integerp action)))
	       (eval act))
	      (t (eval action)))
	(hhist:add hist-elt)
	))))

(defun action:kbd-macro (macro &optional repeat-count)
  "Returns Hyperbole action that executes a keyboard MACRO REPEAT-COUNT times."
  (list 'execute-kbd-macro macro repeat-count))

(defun action:params (action)
  "Returns unmodified ACTION parameter list."
  (setq action (cond ((listp action) action)
		     ((symbolp action)
		      (and (fboundp action) (symbol-function action)))))
  (car (cdr action)))

(defun action:param-list (action)
  "Returns list of actual ACTION parameters (removes '&' special forms)."
  (delq nil (mapcar
	      (function
		(lambda (param)
		  (if (= (aref (symbol-name param)
			       0) ?&)
		      nil param)))
	      (action:params action))))

(defun action:path-args-abs (args-list &optional default-dirs)
  "Return any paths in ARGS-LIST made absolute.
Uses optional DEFAULT-DIRS or 'default-directory'.
Other arguments are returned unchanged."
  (mapcar (function (lambda (arg) (hpath:absolute-to arg default-dirs)))
	  args-list))


(defun action:path-args-rel (args-list)
  "Return any paths in ARGS-LIST below current directory made relative.
Other paths are simply expanded.  Non-path arguments are returned unchanged."
  (let ((dir (hattr:get 'hbut:current 'dir)))
    (mapcar (function (lambda (arg) (hpath:relative-to arg dir)))
	    args-list)))


;;; ========================================================================
;;; actype class
;;; ========================================================================

(defmacro hact (&rest args)
  "Performs action formed from rest of ARGS.
First arg may be a symbol or symbol name for either an action type or a
function.  Runs 'action:act-hook' before performing action."
  (eval (` (cons hrule:action (quote (, args))))))

(defun    actype:act (actype &rest args)
  "Performs action formed from ACTYPE and rest of ARGS and returns value.
If value is nil, however, t is returned instead, to ensure that implicit button
types register the performance of the action.  ACTYPE may be a symbol or symbol
name for either an action type or a function.  Runs 'action:act-hook' before
performing ACTION."
  ;; Needed so relative paths are expanded properly.
  (setq args (action:path-args-abs args))
  (let ((prefix-arg current-prefix-arg)
	(action (actype:action actype))
	(act '(apply action args)))
    (if (null action)
	(error "(actype:act): Null action for: '%s'" actype)
      (let ((hist-elt (hhist:element)))
	(run-hooks 'action:act-hook)
	(prog1 (or (cond ((or (symbolp action) (listp action))
			  (eval act))
			 ((and (stringp action)
			       (let ((func (key-binding action)))
				 (if (not (integerp action))
				     (setq action func))))
			  (eval act))
			 (t (eval action)))
		   t)
	  (hhist:add hist-elt))
	))))

(defun    actype:action (actype)
  "Returns action part of ACTYPE (a symbol or symbol name).
ACTYPE may be a Hyperbole actype or Emacs Lisp function."
  (let (actname)
    (if (stringp actype)
	(setq actname actype
	      actype (intern actype))
      (setq actname (symbol-name actype)))
    (cond ((hattr:get (if (string-match "::" actname)
			  actype
			(intern-soft (concat "actypes::" actname)))
		      'action))
	  ((fboundp actype) actype)
	  )))

(defmacro actype:create (type params doc &rest default-action)
  "Creates an action TYPE (an unquoted symbol) with PARAMS, described by DOC.
The type uses PARAMS to perform DEFAULT-ACTION (list of the rest of the
arguments).  A call to this function is syntactically the same as for
'defun',  but a doc string is required.

Returns symbol created when successful, else nil."
  (setq default-action (action:create params default-action))
  (let ((plist (list 'action default-action)))
    (list 'htype:create type 'actypes doc plist)))

(fset    'defact 'actype:create)
(put     'actype:create 'lisp-indent-hook 'defun)


(defun    actype:delete (type)
  "Deletes an action TYPE (a symbol).  Returns TYPE's symbol if it existed."
  (htype:delete type 'actypes))

(defun    actype:doc (hbut &optional full)
  "Returns first line of act doc for HBUT (a Hyperbole button symbol).
With optional FULL, returns full documentation string.
Returns nil when no documentation."
  (let* ((act (and (hbut:is-p hbut) (or (hattr:get hbut 'action)
					(hattr:get hbut 'actype))))
	 (sym-p (and act (symbolp act)))
	 (end-line) (doc))
    (if (and sym-p (setq doc (htype:doc act)))
	(progn
	  (setq doc (substitute-command-keys doc))
	  (or full (setq end-line (string-match "[\n]" doc)
			 doc (substring doc 0 end-line)))))
    doc))


(defun    actype:identity (&rest args)
  "Returns list of ARGS unchanged or if no ARGS, returns t.
Used as the setting of 'hrule:action' to inhibit action evaluation."
  (or args t))

(defun    actype:interact (actype)
  "Interactively calls default action for ACTYPE.
ACTYPE is a symbol that was previously defined with 'defact'.
Returns nil only when no action is found or the action has no interactive
calling form." 
  (let ((action (hattr:get
		 (intern-soft (concat "actypes::" (symbol-name actype)))
		 'action)))
    (and action (action:commandp action) (or (call-interactively action) t))))

(defun    actype:params (actype)
  "Returns list of ACTYPE's parameters."
  (action:params (actype:action actype)))

(provide 'hact)