help-macro+.el - extensions to GNU `help-macro.el'

[Drew Adams]

;;; help-macro+.el --- Extensions to `help-macro.el'.
;; 
;; Emacs Lisp Archive Entry
;; Filename: help-macro+.el
;; Description: Extensions to `help-macro.el'.
;; Author: Drew Adams
;; Maintainer: Drew Adams
;; Copyright (C) 1999-2001, Drew Adams, all rights reserved.
;; Created: Tue Aug 24 15:36:18 1999
;; Version: $Id: help-macro+.el,v 1.3 2001/01/08 23:07:07 dadams Exp $
;; Last-Updated: Mon Jan  8 15:07:00 2001
;;           By: dadams
;;     Update #: 53
;; Keywords: help
;; Compatibility: GNU Emacs 20.x
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Commentary: 
;;
;;    Extensions to `help-macro.el'.
;;
;;
;;  ***** NOTE: The following macro defined in `help-macro.el' has
;;              been REDEFINED HERE:
;;
;;  `make-help-screen'
;; 
;;
;;
;; 
;;-> ***********************  Example of use *********************************
;;-> 
;;->(make-help-screen help-for-empire-redistribute-map
;;->              "c:civ m:mil p:population f:food ?"
;;->              "You have discovered the GEET redistribution commands
;;->   From here, you can use the following options:
;;->
;;->c   Redistribute civs from overfull sectors into connected underfull ones
;;->      The functions typically named by empire-ideal-civ-fcn control
;;->          based in part on empire-sector-civ-threshold  
;;->m   Redistribute military using levels given by empire-ideal-mil-fcn
;;->p   Redistribute excess population to highways for max pop growth
;;->      Excess is any sector so full babies will not be born.
;;->f   Even out food on highways to highway min and leave levels
;;->      This is good to pump max food to all warehouses/dist pts
;;->
;;->
;;->Use \\[help-for-empire-redistribute-map] for help on redistribution.
;;->Use \\[help-for-empire-extract-map] for help on data extraction.
;;->Please use \\[describe-key] to find out more about any of the other keys."
;;->              empire-shell-redistribute-map)
;;-> 
;;->  (define-key c-mp "\C-h" 'help-for-empire-redistribute-map)
;;->  (define-key c-mp help-character 'help-for-empire-redistribute-map)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Change log:
;; 
;; RCS $Log: help-macro+.el,v $
;; RCS Revision 1.3  2001/01/08 23:07:07  dadams
;; RCS Adapted file header for Emacs Lisp Archive.
;; RCS
;; RCS Revision 1.2  2001/01/03 00:39:32  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.1  2000/09/14 17:20:22  dadams
;; RCS Initial revision
;; RCS
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;; This program 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.

;; This program 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 this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Code:


(require 'cl) ;; when
(require 'help-macro)

(provide 'help-macro+)
(require 'backquote)

;;;;;;;;;;;;;;;;;;;;


;; REPLACES ORIGINAL in `help-macro.el':
;; Does not iconify *Help* frame.
(defmacro make-help-screen (fname help-line help-text helped-map)
  "Construct help-menu function name FNAME.
When invoked, FNAME shows HELP-LINE and reads a command using HELPED-MAP.
If the command is the help character, FNAME displays HELP-TEXT
and continues trying to read a command using HELPED-MAP.
If HELP-TEXT contains the sequence `%THIS-KEY%', that is replaced
with the key sequence that invoked FNAME.
When FNAME finally does get a command, it executes that command
and then returns."
  (let ((doc-fn (intern (concat (symbol-name fname) "-doc"))))
    `(progn
       (defun ,doc-fn () ,help-text)
       (defun ,fname ()
         "Help command."
         (interactive)
         (let ((line-prompt
                (substitute-command-keys ,help-line)))
           (if three-step-help
               (message "%s" line-prompt))
           (let* ((help-screen (documentation (quote ,doc-fn)))
                  ;; We bind overriding-local-map for very small
                  ;; sections, *excluding* where we switch buffers
                  ;; and where we execute the chosen help command.
                  (local-map (make-sparse-keymap))
                  (minor-mode-map-alist nil)
                  (prev-frame (selected-frame))
                  config new-frame key char)
             (if (string-match "%THIS-KEY%" help-screen)
                 (setq help-screen
                       (replace-match (key-description (substring 
(this-command-keys) 0 -1))
                                      t t help-screen)))
             (unwind-protect
                 (progn
                   (setcdr local-map ,helped-map)
                   (define-key local-map [t] 'undefined)
                   ;; Make the scroll bar keep working normally.
                   (define-key local-map [vertical-scroll-bar]
                     (lookup-key global-map [vertical-scroll-bar]))
                   (if three-step-help
                       (progn
                         (setq key (let ((overriding-local-map local-map))
                                     (read-key-sequence nil)))
                         ;; Make the HELP key translate to C-h.
                         (if (lookup-key function-key-map key)
                             (setq key (lookup-key function-key-map key)))
                         (setq char (aref key 0)))
                     (setq char ??))
                   (if (or (eq char ??) (eq char help-char)
                           (memq char help-event-list))
                       (progn
                         (setq config (current-window-configuration))
                         (switch-to-buffer-other-window "*Help*")
                         (and (fboundp 'make-frame)
                              (not (eq (window-frame (selected-window))
                                       prev-frame))
                              (setq new-frame (window-frame (selected-window))
                                    config nil))
                         (setq buffer-read-only nil)
                         (erase-buffer)
                         (insert help-screen)
                         (help-mode)
                         (goto-char (point-min))
                         (while (or (memq char
                                          (append help-event-list
                                                  (cons help-char
                                                        '(?? ?\C-v ?\ ?\177
                                                             delete backspace
                                                             vertical-scroll-bar
                                                             ?\M-v))))
                                    (eq (car-safe char) 'switch-frame)
                                    (equal key "\M-v"))
                           (condition-case nil
                               (progn
                                 (if (eq (car-safe char) 'switch-frame)
                                     (handle-switch-frame char))
                                 (if (memq char '(?\C-v ?\ ))
                                     (scroll-up))
                                 (if (or (memq char '(?\177 ?\M-v
                                                            delete backspace))
                                         (equal key "\M-v"))
                                     (scroll-down)))
                             (error nil))
                           (let ((cursor-in-echo-area t)
                                 (overriding-local-map local-map))
                             (setq key (read-key-sequence
                                        (format "Type one of the options 
listed%s: "
                                                (if (pos-visible-in-window-p
                                                     (point-max))
                                                    "" ", or SPACE or DEL to 
scroll")))
                                   char (aref key 0)))

                   ;; If this is a scroll bar command, just run it.
                   (when (eq char 'vertical-scroll-bar)
                     (command-execute (lookup-key local-map key) nil key)))))
           ;; We don't need the prompt any more.
           (message "")
           ;; Mouse clicks are not part of the help feature,
           ;; so reexecute them in the standard environment.
           (if (listp char)
               (setq unread-command-events
                     (cons char unread-command-events)
                     config nil)
             (let ((defn (lookup-key local-map key)))
               (if defn
                   (progn
                     (if config
                         (progn
                           (set-window-configuration config)
                           (setq config nil)))
                  ;; Took this out because when in own frame via
                  ;; `special-display-popup-frame', C-h w iconifies before
                  ;; user can enter function name.
                  ;; (if new-frame
                  ;;     (progn (iconify-frame new-frame)
                  ;;            (setq new-frame nil)))
                     (call-interactively defn))
                 (ding)))))
               ;; See note above regarding `special-display-popup-frame'.
               ;; (if new-frame (iconify-frame new-frame))
               (if config
                   (set-window-configuration config)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; `help-macro+.el' ends here