;;!emacs
;; $Id: 
;;
;; FILE:         hargs.el
;; SUMMARY:      Obtains user input through Emacs for Hyperbole
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    31-Oct-91 at 23:17:35
;; LAST-MOD:     14-Dec-92 at 19:52:47 by Bob Weiner
;;
;; This file is part of Hyperbole.
;;
;; Copyright (C) 1991, Brown University and the Free Software Foundation
;; Developed with support from Motorola Inc.
;; Available for use and distribution under the same terms as GNU Emacs.
;;
;; DESCRIPTION:  
;;
;;   This module should be used for any interactive prompting and
;;   argument reading that Hyperbole does through Emacs.
;;
;;   'hargs:iform-read' provides a complete Lisp-based replacement for
;;   interactive argument reading (most of what 'call-interactively' does).
;;   It also supports prompting for new argument values with defaults drawn
;;   from current button arguments.  A few extensions to interactive argument
;;   types are also provided, see 'hargs:iforms' for details.
;;
;; DESCRIP-END.

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

(require 'hpath)
(require 'set)

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

(defvar hargs:reading-p nil
  "t only when Hyperbole is prompting user for input, else nil.")

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

(defun hargs:actype-get (actype &optional modifying)
  "Interactively gets and returns list of arguments for ACTYPE's parameters.
Current button is being modified when MODIFYING is non-nil."
  (hargs:action-get (actype:action actype) modifying))

(defun hargs:at-p (&optional no-default)
  "Returns thing at point as a string, if of interest as an arg now, or default.
If optional argument NO-DEFAULT is non-nil, nil is returned instead of any
default values.

Caller should have checked whether an argument is presently being read
and set 'hargs:reading-p' to an appropriate argument type.
Handles all of the interactive argument types that 'hargs:iform-read' does."
  (cond ((eolp) nil)
	((and (eq hargs:reading-p 'hmenu)
	      (eq (selected-window) (minibuffer-window)))
	 (save-excursion
	   (char-to-string
	    (if (search-backward " " nil t)
		(progn (skip-chars-forward " ")
		       (following-char))
	      0))))
	((equal (buffer-name) " *Completions*")
	 (let ((opoint (point))
	       (obuf (current-buffer)))
	   (if (re-search-backward "^\\|[ \t][ \t]" nil t)
	       (let (entry)
		 (skip-chars-forward " \t")
		 (if (looking-at "[^\t\n]+")
		     (progn (setq entry (buffer-substring (match-beginning 0)
							  (match-end 0)))
			    (select-window (minibuffer-window))
			    (set-buffer (window-buffer (minibuffer-window)))
			    (if (or (eq hargs:reading-p 'file)
				    (eq hargs:reading-p 'directory))
				(let ((str (buffer-string)))
				    (concat 
				     (if (string-match "/[^/]+\\'" str)
					 (substring str 0 (1+ (match-beginning 0)))
				       str)
				     entry))
			      )))
		 (set-buffer obuf) (goto-char opoint)
		 entry))))
	((eq hargs:reading-p 'ebut) (ebut:label-p 'as-label))
	((ebut:label-p) nil)
	((eq hargs:reading-p 'file)
	 (cond ((hpath:at-p nil 'non-exist))
	       ((eq major-mode 'dired-mode)
		(let ((file (dired-get-filename nil t)))
		  (and file (hpath:absolute-to file))))
	       ((eq major-mode 'monkey-mode)
		(let ((file (monkey-filename t)))
		  (and file (hpath:absolute-to file))))
	       ;; Delimited file name.
	       ((hpath:at-p 'file))
	       ;; Unquoted remote file name.
	       ((hpath:is-p (hpath:ange-ftp-p) 'file))
	       (no-default nil)
	       ((buffer-file-name))
	       ))
	((eq hargs:reading-p 'directory)
	 (cond ((hpath:at-p 'directory 'non-exist))
	       ((eq major-mode 'dired-mode)
		(let ((dir (dired-get-filename nil t)))
		  (and dir (setq dir (hpath:absolute-to dir))
		       (file-directory-p dir) dir)))
	       ((eq major-mode 'monkey-mode)
		(let ((dir (monkey-filename t)))
		  (and dir (setq dir (hpath:absolute-to dir))
		       (file-directory-p dir) dir)))
	       ;; Delimited directory name.
	       ((hpath:at-p 'directory))
	       ;; Unquoted remote directory name.
	       ((hpath:is-p (hpath:ange-ftp-p) 'directory))
	       (no-default nil)
	       ((default-directory))
	       ))
	((eq hargs:reading-p 'string)
	 (or (hargs:delimited "\"" "\"") (hargs:delimited "'" "'")
	     (hargs:delimited "`" "'")
	     ))
	((or (eq hargs:reading-p 'actype)
	     (eq hargs:reading-p 'actypes))
	 (let ((name (find-tag-default)))
	   (car (set:member name (htype:names 'actypes)))))
	((or (eq hargs:reading-p 'ibtype)
	     (eq hargs:reading-p 'ibtypes))
	 (let ((name (find-tag-default)))
	   (car (set:member name (htype:names 'ibtypes)))))
	((eq hargs:reading-p 'sexpression) (hargs:sexpression-p))
	((eq hargs:reading-p 'Info-node)
	 (and (eq major-mode 'Info-mode)
	      (let ((file (hpath:relative-to Info-current-file
					     Info-directory)))
		(and (stringp file) (string-match "^\\./" file)
		     (setq file (substring file (match-end 0))))
		(concat "(" file ")" Info-current-node))))
	((eq hargs:reading-p 'mail)
	 (and (hmail:reader-p) buffer-file-name
	      (prin1-to-string (list (rmail:msg-id-get) buffer-file-name))))
	((eq hargs:reading-p 'symbol)
	 (let ((sym (find-tag-default)))
	   (if (or (fboundp sym) (boundp sym)) sym)))
	((eq hargs:reading-p 'buffer)
	 (find-tag-default))
	((eq hargs:reading-p 'character)
	 (following-char))
	((eq hargs:reading-p 'key)
	 (let ((key-seq (hbut:label-p 'as-label "{" "}")))
	   (and key-seq (kbd-key:normalize key-seq))))
	((eq hargs:reading-p 'integer)
	 (save-excursion (skip-chars-backward "-0-9")
			 (if (looking-at "-?[0-9]+")
			     (read (current-buffer)))))
	))

(defun hargs:iform-read (iform &optional modifying)
  "Reads action arguments according to IFORM, a list with car = 'interactive.
Optional MODIFYING non-nil indicates current button is being modified, so
button's current values should be presented as defaults.
See also documentation for 'interactive'."
  ;; This is mostly a translation of 'call-interactively' to Lisp.
  ;;
  ;; Save this now, since use of minibuffer will clobber it.
  (setq prefix-arg current-prefix-arg)
  (if (not (and (listp iform) (eq (car iform) 'interactive)))
      (error
       "(hargs:iform-read): arg must be a list whose car = 'interactive.")
    (setq iform (car (cdr iform)))
    (if (or (null iform) (and (stringp iform) (equal iform "")))
	nil
      (let ((prev-reading-p hargs:reading-p))
	(unwind-protect
	    (progn
	      (setq hargs:reading-p t)
	      (if (not (stringp iform))
		  (let ((defaults (if modifying
				      (hattr:get 'hbut:current 'args))))
		    (eval iform))
		;;
		;; First character '*' of an iform means error if buffer is
		;; read-only.
		;;
		;; Notion of when action cannot be performed due to
		;; read-only buffer is view-specific, so here, we just
		;; ignore a read-only specification since it is checked for
		;; earlier by any ebut edit code.
		;;
		(let ((i 0) (start 0) (end (length iform))
		      (ientry) (results) (val) (default)
		      (defaults (if modifying
				    (hattr:get 'hbut:current 'args))))
		  (if (eq (aref iform i) ?*)
		      (setq i 1 start 1))
		  (while (and (< start end)
			      (string-match "\n\\|\\'" iform start))
		    (setq start (match-end 0)
			  ientry (substring iform i (match-beginning 0))
			  i start
			  default (car defaults)
			  default (if (or (null default) (stringp default))
				      default
				    (prin1-to-string default))
			  val (hargs:get ientry default)
			  defaults (cdr defaults)
			  results (cond ((or (null val) (not (listp val)))
					 (cons val results))
					;; Is a list of args?
					((eq (car val) 'args)
					 (append (nreverse (cdr val)) results))
					(t ;; regular list value
					 (cons val results)))))
		  (nreverse results))))
	  (setq hargs:reading-p prev-reading-p))))))

(defun hargs:read (prompt &optional predicate default err val-type)
  "PROMPTs without completion for a value matching PREDICATE and returns it.
PREDICATE is an optional boolean function of one argument.  Optional DEFAULT
is a string to insert after PROMPT as the default return value.  Optional
ERR is a string to display temporarily when an invalid value is given.
Optional VAL-TYPE is a symbol indicating type of value to be read.  If VAL-TYPE
is not equal to 'sexpression' and is non-nil, value is returned as a string."
  (let ((bad-val) (val) (stringify)
	(prev-reading-p hargs:reading-p) (read-func)
	(owind (selected-window))
	(obuf (current-buffer)))
    (unwind-protect
	(progn
	  (if (or (null val-type) (eq val-type 'sexpression))
	      (setq read-func 'read-minibuffer hargs:reading-p 'sexpression)
	    (setq read-func 'read-string hargs:reading-p val-type
		  stringify t)
	    )
	  (while (progn (and default (not (stringp default))
			     (setq default (prin1-to-string default)))
			(condition-case ()
			    (or bad-val
				(setq val (funcall read-func prompt default)))
			  (error (setq bad-val t)))
			(if bad-val t
			  (and stringify
			       ;; Remove any double quoting of strings.
			       (string-match
				"\\`\"\\([^\"]*\\)\"\\'" val) 
			       (setq val (substring val (match-beginning 1)
						    (match-end 1))))
			  (and predicate (not (funcall predicate val)))))
	    (if bad-val (setq bad-val nil) (setq default val))
	    (beep)
	    (if err (progn (message err) (sit-for 3))))
	  val)
      (setq hargs:reading-p prev-reading-p)
      (select-window owind)
      (switch-to-buffer obuf)
      )))

(defun hargs:read-match (prompt table &optional
				predicate must-match default val-type)
  "PROMPTs with completion for a value in TABLE and returns it.
TABLE is an alist where each element's car is a string, or it may be an
obarray for symbol-name completion.
Optional PREDICATE limits table entries to match against.
Optional MUST-MATCH means value returned must be from TABLE.
Optional DEFAULT is a string inserted after PROMPT as default value.
Optional VAL-TYPE is a symbol indicating type of value to be read."
  (if (and must-match (null table))
      nil
    (let ((prev-reading-p hargs:reading-p)
	  (completion-ignore-case t)
	  (owind (selected-window))
	  (obuf (current-buffer)))
      (unwind-protect
	  (progn
	    (setq hargs:reading-p (or val-type t))
	    (completing-read prompt table predicate must-match default))
	(setq hargs:reading-p prev-reading-p)
	(select-window owind)
	(switch-to-buffer obuf)
	))))

(defun hargs:select-p (&optional value meta)
  "Returns optional VALUE or value selected at point if any, else nil.
If value is the same as the contents of the minibuffer, it is used as
the current minibuffer argument, otherwise, the minibuffer is erased
and value is inserted there.
Optional META non-nil triggers display of Hyperbole menu item help when
appropriate."
    (if (and (> (minibuffer-depth) 0) (or value (setq value (hargs:at-p))))
	(let ((owind (selected-window)) (back-to))
	  (unwind-protect
	      (progn
		(select-window (minibuffer-window))
		(set-buffer (window-buffer (minibuffer-window)))
		(cond
		 ;; Selecting a menu item
		 ((eq hargs:reading-p 'hmenu)
		  (if meta (setq hargs:reading-p 'hmenu-help))
		  (hui:menu-enter value))
		 ;; Use value for parameter.
		 ((string= value (buffer-string))
		  (exit-minibuffer))
		 ;; Clear minibuffer and insert value.
		 (t (setq buffer-read-only nil)
		    (erase-buffer) (insert value)
		    (setq back-to t)))
		value)
	    (if back-to (select-window owind))))))

;;; ************************************************************************
;;; Private functions
;;; ************************************************************************

;;; From tags.el, so don't have to load the whole thing.
(or (fboundp 'find-tag-default)
    (defun find-tag-default ()
      (save-excursion
	(while (looking-at "\\sw\\|\\s_")
	  (forward-char 1))
	(if (re-search-backward "\\sw\\|\\s_" nil t)
	    (progn (forward-char 1)
		   (buffer-substring (point)
				     (progn (forward-sexp -1)
					    (while (looking-at "\\s'")
					      (forward-char 1))
					    (point))))
	  nil))))

(defun hargs:action-get (action modifying)
  "Interactively gets list of arguments for ACTION's parameters.
Current button is being modified when MODIFYING is non-nil.
Returns nil if ACTION is not a list, has no interactive form or takes no
arguments."
  (and (listp action)
       (let ((interactive-form (action:commandp action)))
	 (if interactive-form
	     (action:path-args-rel
	      (hargs:iform-read interactive-form modifying))))))

(defun hargs:delimited (start-delim end-delim)
  "Returns a single line, delimited argument that point is within, or nil.
START-DELIM and END-DELIM are strings that specify the argument delimiters."
  (let ((opoint (point)) eol start end)
    (save-excursion
      (beginning-of-line)
      (while (and (setq start (search-forward start-delim (1+ opoint) t))
		  (search-forward end-delim (1+ opoint) t))
	(setq start nil))
      (if start
	  (progn
	    (setq start (point))
	    (end-of-line) (setq eol (point))
	    (goto-char opoint)
	    (and (search-forward end-delim eol t)
		 (setq end (- (point) (length end-delim)))
		 (buffer-substring start end)
		 ))))))

(defun hargs:get (interactive-entry &optional default)
  "Prompts for an argument, if need be, from INTERACTIVE-ENTRY, a string.
Optional DEFAULT is inserted after prompt.
First character of INTERACTIVE-ENTRY must be a command character from
the list in the documentation for 'interactive'.
May return a single value or a list of values, in which case the first
element of the list is always the symbol 'args."
  (let* ((cmd (if (or (null interactive-entry) (equal interactive-entry ""))
		  0 (aref interactive-entry 0)))
	 (prompt (if (= cmd 0) nil (substring interactive-entry 1)))
	 (func)
	 (val))
    (cond ((= cmd 0) (error "(hargs:get): Empty interactive-entry arg."))
	  ((not (and (< cmd (length hargs:iform-vector))
		     (setq func (aref hargs:iform-vector cmd))
		     (setq val (funcall func prompt default))))
	   (error
	    "(hargs:get): Bad interactive-entry cmd char: '%c'." cmd))
	  (t val))))

(defun hargs:prompt (prompt default &optional default-prompt)
  "Returns string of PROMPT including DEFAULT.
Optional DEFAULT-PROMPT is used to describe default value."
  (if default
      (format "%s(%s%s%s) " prompt (or default-prompt "default")
	      (if (equal default "") "" " ")
	      default)
    prompt))

(defun hargs:sexpression-p (&optional no-recurse)
  "Returns an sexpression at point as a string.
If point follows an sexpression end character, the preceding sexpression
is returned.  If point precedes an sexpression start character, the
following sexpression is returned.  Otherwise, the innermost sexpression
that point is within is returned or nil if none."
  (save-excursion
    (condition-case ()
	(let ((not-quoted
	       '(not (and (= (char-syntax (char-after (- (point) 2))) ?\\)
			  (/= (char-syntax (char-after (- (point) 3))) ?\\)))))
	  (cond ((and (= (char-syntax (preceding-char)) ?\))
		      ;; Ignore quoted end chars.
		      (eval not-quoted))
		 (buffer-substring (point)
				   (progn (forward-sexp -1) (point))))
		((and (= (char-syntax (following-char)) ?\()
		      ;; Ignore quoted begin chars.
		      (eval not-quoted))
		 (buffer-substring (point)
				   (progn (forward-sexp) (point))))
		(no-recurse nil)
		(t (save-excursion (up-list 1) (hargs:sexpression-p t)))))
      (error nil))))

;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(defvar hargs:iforms nil
  "Alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.")
(setq   hargs:iforms
	'(
	  ;; Get function symbol.
	  (?a . (symbol .
		 (intern (completing-read prompt obarray 'fboundp t default))))
	  ;; Get name of existing buffer.
	  (?b . (buffer .
		 (progn
		   (or default (setq default (other-buffer (current-buffer))))
		   (read-buffer prompt default t))))
	  ;; Get name of possibly nonexistent buffer.
	  (?B . (buffer .
		 (progn
		   (or default (setq default (other-buffer (current-buffer))))
		   (read-buffer prompt default nil))))
	  ;; Get character.
	  (?c . (character .
		 (progn (message
			 (if default
			     (hargs:prompt prompt
					   (if (integerp default)
					       (char-to-string default)
					     default)
					   "Curr:")
			   prompt))
			(char-to-string (read-char)))))
	  ;; Get symbol for interactive function, a command.
	  (?C . (symbol .
		 (intern
		  (completing-read prompt obarray 'commandp t default))))
	  ;; Get value of point; does not do I/O.
	  (?d . (integer . (point)))
	  ;; Get directory name.
	  (?D . (directory .
		 (progn
		   (or default (setq default default-directory))
		   (read-file-name prompt default default 'existing))))
	  ;; Get existing file name.
	  (?f . (file .
		 (read-file-name prompt default default
				 (if (eq system-type 'vax-vms)
				     nil 'existing))))
	  ;; Get possibly nonexistent file name.
	  (?F . (file . (read-file-name prompt default default nil)))
	  ;; HYPERBOLE EXTENSION: Get existing Info node name and file.
	  (?I . (Info-node . 
		 (progn
		   (require 'info)
		   (hargs:read prompt
			       '(lambda (node)
				  (and (string-match "^(\\([^\)]+\\))" node)
				       (file-readable-p
					(hpath:absolute-to
					 (substring node (match-beginning 1)
						    (match-end 1))
					 Info-directory))))
			       default
			       "(hargs:read): Use (readable-filename)nodename."
			       'Info-node))))
	  ;; Get key sequence.
	  (?k . (key .
		 (key-description (read-key-sequence
				   (if default
				       (hargs:prompt prompt default "Curr:")
				     prompt)))))
	  ;; Get value of mark.  Does not do I/O.
	  (?m . (integer . (mark)))
	  ;; HYPERBOLE EXTENSION: Get existing mail msg date and file.
	  (?M . (mail . (progn
			  (while (or (not (listp
					   (setq default
						 (read-minibuffer
						  (hargs:prompt
						   prompt ""
						   "list of (date mail-file)")
						  default))))
				     (/= (length default) 2)
				     (not (and (stringp (car (cdr default)))
					       (file-exists-p (car (cdr default))))))
			    (beep))
			  default)))
	  ;; Get numeric prefix argument or a number from the minibuffer.
	  (?N . (integer .
		 (if prefix-arg
		     (prefix-numeric-value prefix-arg)
		   (let ((arg))
		     (while (not (integerp 
				  (setq arg (read-minibuffer prompt default))))
		       (beep))
		     arg))))
	  ;; Get number from minibuffer.
	  (?n . (integer .
		 (let ((arg))
		   (while (not (integerp
				(setq arg (read-minibuffer prompt default))))
		     (beep))
		   arg)))
	  ;; Get numeric prefix argument.  No I/O.
	  (?p . (prefix-arg .
		 (prefix-numeric-value prefix-arg)))
	  ;; Get prefix argument in raw form.  No I/O.
	  (?P . (prefix-arg . prefix-arg))
	  ;; Get region, point and mark as 2 args.  No I/O
	  (?r . (region .
		 (if (mark)
		     (list 'args (min (point) (mark)) (max (point) (mark)))
		   (list 'args nil nil))))
	  ;; Get string.
	  (?s . (string . (read-string prompt default)))
	  ;; Get symbol.
	  (?S . (symbol .
		 (read-from-minibuffer
		  prompt default minibuffer-local-ns-map 'sym)))
	  ;; Get variable name: symbol that is user-variable-p.
	  (?v . (symbol . (read-variable
			   (if default
			       (hargs:prompt prompt default "Curr:")
			     prompt))))
	  ;; Get Lisp expression but don't evaluate.
	  (?x . (sexpression . (read-minibuffer prompt default)))
	  ;; Get Lisp expression and evaluate.
	  (?X . (sexpression . (eval-minibuffer prompt default)))
	  ))

(defvar hargs:iform-vector nil
  "Vector of forms for each interactive command char code.")
(setq   hargs:iform-vector
      ;; Vector needs to have 1 more elts than the highest char code for
      ;; interactive commands.
      (let* ((size (1+ (car (sort (mapcar 'car hargs:iforms) '>))))
	     (vec (make-vector size nil)))
	(mapcar '(lambda (elt)
		   (aset vec (car elt)
			 (list 'lambda '(prompt default)
			       (list 'setq 'hargs:reading-p 
				     (list 'quote (car (cdr elt))))
			       (cdr (cdr elt)))))
		hargs:iforms)
	vec))

(provide 'hargs)