lisp/wid-browse.el

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