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 ;; Package: emacs
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs 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 ;; GNU Emacs 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 GNU Emacs.  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 'wid-edit)
  34 (eval-when-compile (require 'cl))
  35
  36 (defgroup widget-browse nil
  37   "Customization support for browsing widgets."
  38   :group 'widgets)
  39
  40 ;;; The Mode.
  41
  42 (defvar widget-browse-mode-map
  43   (let ((map (make-sparse-keymap)))
  44     (set-keymap-parent map widget-keymap)
  45     (define-key map "q" 'bury-buffer)
  46     map)
  47   "Keymap for `widget-browse-mode'.")
  48
  49 (easy-menu-define widget-browse-mode-customize-menu
  50     widget-browse-mode-map
  51   "Menu used in widget browser buffers."
  52   (customize-menu-create 'widgets))
  53
  54 (easy-menu-define widget-browse-mode-menu
  55     widget-browse-mode-map
  56   "Menu used in widget browser buffers."
  57   '("Widget"
  58     ["Browse" widget-browse t]
  59     ["Browse At" widget-browse-at t]))
  60
  61 (defcustom widget-browse-mode-hook nil
  62   "Hook called when entering widget-browse-mode."
  63   :type 'hook
  64   :group 'widget-browse)
  65
  66 (defun widget-browse-mode ()
  67   "Major mode for widget browser buffers.
  68
  69 The following commands are available:
  70
  71 \\[widget-forward]              Move to next button or editable field.
  72 \\[widget-backward]             Move to previous button or editable field.
  73 \\[widget-button-click]         Activate button under the mouse pointer.
  74 \\[widget-button-press]         Activate button under point.
  75
  76 Entry to this mode calls the value of `widget-browse-mode-hook'
  77 if that value is non-nil."
  78   (kill-all-local-variables)
  79   (setq major-mode 'widget-browse-mode
  80         mode-name "Widget")
  81   (use-local-map widget-browse-mode-map)
  82   (easy-menu-add widget-browse-mode-customize-menu)
  83   (easy-menu-add widget-browse-mode-menu)
  84   (run-mode-hooks 'widget-browse-mode-hook))
  85
  86 (put 'widget-browse-mode 'mode-class 'special)
  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                 (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-map
 267   (let ((map (make-sparse-keymap)))
 268     (set-keymap-parent map widget-keymap)
 269     map)
 270   "Keymap used in Widget Minor Mode.")
 271
 272 ;;;###autoload
 273 (define-minor-mode widget-minor-mode
 274   "Togle minor mode for traversing widgets.
 275 With arg, turn widget mode on if and only if arg is positive."
 276   :lighter " Widget")
 277
 278 ;;; The End:
 279
 280 (provide 'wid-browse)
 281
 282 ;; arch-tag: d5ffb18f-8984-4735-8502-edf70456db21
 283 ;;; wid-browse.el ends here