cgit.sxemacs.org Git - sxemacs/blob - lisp/wid-browse.el

   1 ;;; wid-browse.el --- Functions for browsing widgets.
   2 ;;
   3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: extensions
   7 ;; Version: 1.9960
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;; This file is part of SXEmacs.
  11
  12 ;; SXEmacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; SXEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26 ;;
  27 ;; Widget browser.  See `widget.el'.
  28
  29 ;;; Code:
  30
  31 (require 'easymenu)
  32 (require 'custom)
  33 (require 'cus-edit)
  34 (require 'wid-edit)
  35 (eval-when-compile (require 'cl))
  36
  37 (defgroup widget-browse nil
  38   "Customization support for browsing widgets."
  39   :group 'widgets)
  40
  41 ;;; The Mode.
  42
  43 (defvar widget-browse-mode-map nil
  44   "Keymap for `widget-browse-mode'.")
  45
  46 (unless widget-browse-mode-map
  47   (setq widget-browse-mode-map (make-sparse-keymap))
  48   (set-keymap-parent widget-browse-mode-map widget-keymap)
  49   (define-key widget-browse-mode-map "q" 'bury-buffer))
  50
  51 (easy-menu-define widget-browse-mode-customize-menu
  52     widget-browse-mode-map
  53   "Menu used in widget browser buffers."
  54   (customize-menu-create 'widgets))
  55
  56 (easy-menu-define widget-browse-mode-menu
  57     widget-browse-mode-map
  58   "Menu used in widget browser buffers."
  59   '("Widget"
  60     ["Browse" widget-browse t]
  61     ["Browse At" widget-browse-at t]))
  62
  63 (defcustom widget-browse-mode-hook nil
  64   "Hook called when entering widget-browse-mode."
  65   :type 'hook
  66   :group 'widget-browse)
  67
  68 (defun widget-browse-mode ()
  69   "Major mode for widget browser buffers.
  70
  71 The following commands are available:
  72
  73 \\[widget-forward]              Move to next button or editable field.
  74 \\[widget-backward]             Move to previous button or editable field.
  75 \\[widget-button-click]         Activate button under the mouse pointer.
  76 \\[widget-button-press]         Activate button under point.
  77
  78 Entry to this mode calls the value of `widget-browse-mode-hook'
  79 if that value is non-nil."
  80   (kill-all-local-variables)
  81   (setq major-mode 'widget-browse-mode
  82         mode-name "Widget")
  83   (use-local-map widget-browse-mode-map)
  84   (easy-menu-add widget-browse-mode-customize-menu)
  85   (easy-menu-add widget-browse-mode-menu)
  86   (run-hooks 'widget-browse-mode-hook))
  87
  88 ;;; Commands.
  89
  90 ;;;###autoload
  91 (defun widget-browse-at (pos)
  92   "Browse the widget under point."
  93   (interactive "d")
  94   (let* ((field (get-char-property pos 'field))
  95          (button (get-char-property pos 'button))
  96          (doc (get-char-property pos 'widget-doc))
  97          (text (cond (field "This is an editable text area.")
  98                      (button "This is an active area.")
  99                      (doc "This is documentation text.")
 100                      (t "This is unidentified text.")))
 101          (widget (or field button doc)))
 102     (when widget
 103       (widget-browse widget))
 104     (message text)))
 105
 106 (defvar widget-browse-history nil)
 107
 108 ;;;###autoload
 109 (defun widget-browse (widget)
 110   "Create a widget browser for WIDGET."
 111   (interactive (list (completing-read "Widget: "
 112                                       obarray
 113                                       (lambda (symbol)
 114                                         (get symbol 'widget-type))
 115                                       t nil 'widget-browse-history)))
 116   (if (stringp widget)
 117       (setq widget (intern widget)))
 118   (unless (if (symbolp widget)
 119               (get widget 'widget-type)
 120             (and (consp widget)
 121                  (get (widget-type widget) 'widget-type)))
 122     (error "Not a widget."))
 123   ;; Create the buffer.
 124   (if (symbolp widget)
 125       (let ((buffer (format "*Browse %s Widget*" widget)))
 126         (kill-buffer (get-buffer-create buffer))
 127         (switch-to-buffer (get-buffer-create buffer)))
 128     (kill-buffer (get-buffer-create "*Browse Widget*"))
 129     (switch-to-buffer (get-buffer-create "*Browse Widget*")))
 130   (widget-browse-mode)
 131
 132   ;; Quick way to get out.
 133 ;;  (widget-create 'push-button
 134 ;;               :action (lambda (widget &optional event)
 135 ;;                         (bury-buffer))
 136 ;;               "Quit")
 137 ;;  (widget-insert "\n")
 138
 139   ;; Top text indicating whether it is a class or object browser.
 140   (if (listp widget)
 141       (widget-insert "Widget object browser.\n\nClass: ")
 142     (widget-insert "Widget class browser.\n\n")
 143     (widget-create 'widget-browse
 144                    :format "%[%v%]\n%d"
 145                    :doc (get widget 'widget-documentation)
 146                    widget)
 147     (unless (eq (preceding-char) ?\n)
 148       (widget-insert "\n"))
 149     (widget-insert "\nSuper: ")
 150     (setq widget (get widget 'widget-type)))
 151
 152   ;; Now show the attributes.
 153   (let ((name (car widget))
 154         (items (cdr widget))
 155         key value printer)
 156     (widget-create 'widget-browse
 157                    :format "%[%v%]"
 158                    name)
 159     (widget-insert "\n")
 160     (while items
 161       (setq key (nth 0 items)
 162             value (nth 1 items)
 163             printer (or (get key 'widget-keyword-printer)
 164                         'widget-browse-sexp)
 165             items (cdr (cdr items)))
 166       (widget-insert "\n" (symbol-name key) "\n\t")
 167       (funcall printer widget key value)
 168       (widget-insert "\n")))
 169   (widget-setup)
 170   (goto-char (point-min)))
 171
 172 ;;;###autoload
 173 (defun widget-browse-other-window (&optional widget)
 174   "Show widget browser for WIDGET in other window."
 175   (interactive)
 176   (let ((window (selected-window)))
 177     (switch-to-buffer-other-window "*Browse Widget*")
 178     (if widget
 179         (widget-browse widget)
 180       (call-interactively 'widget-browse))
 181     (select-window window)))
 182
 183
 184 ;;; The `widget-browse' Widget.
 185
 186 (define-widget 'widget-browse 'push-button
 187   "Button for creating a widget browser.
 188 The :value of the widget shuld be the widget to be browsed."
 189   :format "%[[%v]%]"
 190   :value-create 'widget-browse-value-create
 191   :action 'widget-browse-action)
 192
 193 (defun widget-browse-action (widget &optional event)
 194   ;; Create widget browser for WIDGET's :value.
 195   (widget-browse (widget-get widget :value)))
 196
 197 (defun widget-browse-value-create (widget)
 198   ;; Insert type name.
 199   (let ((value (widget-get widget :value)))
 200     (cond ((symbolp value)
 201            (insert (symbol-name value)))
 202           ((consp value)
 203            (insert (symbol-name (widget-type value))))
 204           (t
 205            (insert "strange")))))
 206
 207 ;;; Keyword Printer Functions.
 208
 209 (defun widget-browse-widget (widget key value)
 210   "Insert description of WIDGET's KEY VALUE.
 211 VALUE is assumed to be a widget."
 212   (widget-create 'widget-browse value))
 213
 214 (defun widget-browse-widgets (widget key value)
 215   "Insert description of WIDGET's KEY VALUE.
 216 VALUE is assumed to be a list of widgets."
 217   (while value
 218     (widget-create 'widget-browse
 219                    (car value))
 220     (setq value (cdr value))
 221     (when value
 222       (widget-insert " "))))
 223
 224 (defun widget-browse-sexp (widget key value)
 225   "Insert description of WIDGET's KEY VALUE.
 226 Nothing is assumed about value."
 227   (let ((pp (condition-case signal
 228                 (declare-fboundp (pp-to-string value))
 229               (error (prin1-to-string signal)))))
 230     (when (string-match "\n\\'" pp)
 231       (setq pp (substring pp 0 (1- (length pp)))))
 232     (if (cond ((string-match "\n" pp)
 233                nil)
 234               ((> (length pp) (- (window-width) (current-column)))
 235                nil)
 236               (t t))
 237         (widget-insert pp)
 238       (widget-create 'push-button
 239                      :tag "show"
 240                      :action (lambda (widget &optional event)
 241                                (with-output-to-temp-buffer
 242                                    "*Pp Eval Output*"
 243                                  (princ (widget-get widget :value))))
 244                      pp))))
 245
 246 (defun widget-browse-sexps (widget key value)
 247   "Insert description of WIDGET's KEY VALUE.
 248 VALUE is assumed to be a list of widgets."
 249   (let ((target (current-column)))
 250     (while value
 251       (widget-browse-sexp widget key (car value))
 252       (setq value (cdr value))
 253       (when value
 254         (widget-insert "\n" (make-string target ?\ ))))))
 255
 256 ;;; Keyword Printers.
 257
 258 (put :parent 'widget-keyword-printer 'widget-browse-widget)
 259 (put :children 'widget-keyword-printer 'widget-browse-widgets)
 260 (put :buttons 'widget-keyword-printer 'widget-browse-widgets)
 261 (put :button 'widget-keyword-printer 'widget-browse-widget)
 262 (put :args 'widget-keyword-printer 'widget-browse-sexps)
 263
 264 ;;; Widget Minor Mode.
 265
 266 (defvar widget-minor-mode nil
 267   "I non-nil, we are in Widget Minor Mode.")
 268   (make-variable-buffer-local 'widget-minor-mode)
 269
 270 (defvar widget-minor-mode-map nil
 271   "Keymap used in Widget Minor Mode.")
 272
 273 (unless widget-minor-mode-map
 274   (setq widget-minor-mode-map (make-sparse-keymap))
 275   (set-keymap-parent widget-minor-mode-map widget-keymap))
 276
 277 ;;;###autoload
 278 (defun widget-minor-mode (&optional arg)
 279   "Togle minor mode for traversing widgets.
 280 With arg, turn widget mode on if and only if arg is positive."
 281   (interactive "P")
 282   (cond ((null arg)
 283          (setq widget-minor-mode (not widget-minor-mode)))
 284         ((<= arg 0)
 285          (setq widget-minor-mode nil))
 286         (t
 287          (setq widget-minor-mode t)))
 288   (force-mode-line-update))
 289
 290 (add-to-list 'minor-mode-alist '(widget-minor-mode " Widget"))
 291
 292 (add-to-list 'minor-mode-map-alist
 293              (cons 'widget-minor-mode widget-minor-mode-map))
 294
 295 ;;; The End:
 296
 297 (provide 'wid-browse)
 298
 299 ;; wid-browse.el ends here