Stefan Reichör <xsteve@riic.at> writes:

> Hi!
> 
> I am currently working on xtla.el (the arch interface for emacs).
> 
> In my mode the user is often asked some questions in the
> minibuffer. Sometimes the questions need some more
> explanations. So I decided to put the needed help in the
> function's docstring.

Here's a function called `question' which may be of use.

It allows the responses to an interactive question to be defined,
including a help response and associated help string.  The patch
includes a change to `shell-command' to use `question', in the way
suggested for the `compile' command by Dan Jacobson (in the attached
mail).  This allows `shell-command' to start concurrent asynchronous
shell commands.

The function `may-y-or-n-p' may also be useful.

Note that `question' will need dialog popup additions to be better
analogous to yes-or-no-p.

===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/simple.el,v
retrieving revision 1.634
diff -u -r1.634 simple.el
--- lisp/simple.el	25 Mar 2004 16:01:37 -0000	1.634
+++ lisp/simple.el	15 Apr 2004 11:14:47 -0000
@@ -1227,6 +1227,62 @@
 	     '(0 . 0)))
     '(0 . 0)))
 
+(defvar question-history nil)
+
+(defun question (prompt &optional responses help-response)
+"Prompt with PROMPT for a response from RESPONSES.
+
+RESPONSES is an alist associating responses with returns.  Each
+member of RESPONSES is of the form (\"response\" . return).  For
+example '((\"yes\" . t) (\"no\" . n)).  The return can be
+anything except nil, which is used when searching the list.
+
+HELP-RESPONSE is a cons cell with a response as its car and a
+help string as its cdr.  If the help response is entered the
+string is displayed in the other buffer and prompting continues.
+
+If only PROMPT is given `yes-or-no-p' is called with PROMPT as
+its argument."
+  (if responses
+      (let ((options))
+	;; add alternatives to prompt
+	(let (rest (answers (if help-response
+				(append responses (list help-response))
+	
+		      responses)))
+	  (while answers
+	    (setq options
+		  (concat options
+			  (if (prog1 rest (setq rest t))
+			      (if (cdr answers)
+				  (concat ", "
+					  (car (car answers)))
+				(concat " or "
+					(car (car answers))))
+			    (car (car answers)))))
+	    (setq answers (cdr answers))))
+	(setq prompt (concat prompt "(" options ") "))
+	;; return the value associated with a prompted response
+	(cdr (let (ret rsp)
+		 (while (not
+			 (setq ret (assoc (setq rsp (read-from-minibuffer
+						     prompt nil nil nil
+						     question-history nil
+						     nil))
+					  responses)))
+		   (if (and help-response
+			    (equal rsp (car help-response)))
+		       (with-output-to-temp-buffer "*Help*"
+			 (princ (cdr help-response))
+			 (with-current-buffer standard-output
+			   (help-mode)))
+		     (ding)
+		     (discard-input)
+		     (message "Please answer %s." options)
+		     (sleep-for 2 nil)))
+		   ret)))
+    (yes-or-no-p prompt)))
+
 (defvar shell-command-history nil
   "History list for some commands that read shell commands.")
 
@@ -1356,9 +1412,23 @@
 		;; If will kill a process, query first.
 		(setq proc (get-buffer-process buffer))
 		(if proc
-		    (if (yes-or-no-p "A command is running.  Kill it? ")
-			(kill-process proc)
-		      (error "Shell command in progress")))
+		    (let ((res (question
+				"A command is running.  Kill it? "
+				'(("yes" . t) ("no" . no) ("r" . run))
+				'("?" . "An asynchronous command is already running in the \"*Async Shell Command*\" buffer.
+Enter
+  \"yes\"  to kill the running command, replacing it with the new one,
+  \"no\"   to quit, leaving the current command running, or
+  \"r\"    to run the new command in parallel in a uniquely-named buffer."))))
+		      (cond
+		       ((eq res 'run)
+			(setq buffer (get-buffer-create
+				      (generate-new-buffer-name
+				       (buffer-name buffer)))))
+		       ((eq res t) (kill-process proc))
+		       ((eq res 'no) (error "Shell command in progress"))
+		       ;; question-p prevents this case
+		       (t (error "Error processing response")))))
 		(with-current-buffer buffer
 		  (setq buffer-read-only nil)
 		  (erase-buffer)