lisp/wid-browse.el

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