emacs/nxhtml/util/whelp.el

   1 ;; This is a test file for some enhancement to the possibilities to
   2 ;; find out about widgets or buttons at point in a buffer.
   3 ;;
   4 ;; To use this just load the file. Then put point on a widget or
   5 ;; button and do
   6 ;;
   7 ;;    M-x describe-field
   8 ;;
   9 ;; You find a lot of widgets in a Custom buffer. You can find buttons
  10 ;; in for example a help buffer. (Please tell me more places so I can
  11 ;; test!)
  12 ;;
  13 ;; TODO: Add backtrace collecting to some more functions!
  14
  15 ;; For widget-get-backtrace-info
  16 ;;(require 'debug)
  17 (eval-when-compile (require 'cl))  ;; gensym
  18 (require 'help-mode)
  19
  20 ;; Last wins!
  21 (require 'wid-browse)
  22
  23 (intern ":created-in-function")
  24
  25 (define-widget 'widget-browse-link 'item
  26   "Button for creating a link style button.
  27 The :value of the widget shuld be the widget to be browsed."
  28   :format "%[%v%]"
  29   ;;:value-create 'widget-browse-value-create
  30   ;;:action 'widget-browse-action
  31   )
  32
  33 (defun define-button-type (name &rest properties)
  34   "Define a `button type' called NAME.
  35 The remaining arguments form a sequence of PROPERTY VALUE pairs,
  36 specifying properties to use as defaults for buttons with this type
  37 \(a button's type may be set by giving it a `type' property when
  38 creating the button, using the :type keyword argument).
  39
  40 In addition, the keyword argument :supertype may be used to specify a
  41 button-type from which NAME inherits its default property values
  42 \(however, the inheritance happens only when NAME is defined; subsequent
  43 changes to a supertype are not reflected in its subtypes)."
  44   (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
  45         (super-catsym
  46          (button-category-symbol
  47           (or (plist-get properties 'supertype)
  48               (plist-get properties :supertype)
  49               'button))))
  50     ;; Provide a link so that it's easy to find the real symbol.
  51     (put name 'button-category-symbol catsym)
  52     ;; Initialize NAME's properties using the global defaults.
  53     (let ((default-props (symbol-plist super-catsym))
  54           (where-fun (widget-get-backtrace-info 8)))
  55       (setq default-props
  56             (cons :created-in-function
  57                   (cons where-fun
  58                         default-props)))
  59       (while default-props
  60         (put catsym (pop default-props) (pop default-props))))
  61     ;; Add NAME as the `type' property, which will then be returned as
  62     ;; the type property of individual buttons.
  63     (put catsym 'type name)
  64     ;; Add the properties in PROPERTIES to the real symbol.
  65     (while properties
  66       (let ((prop (pop properties)))
  67         (when (eq prop :supertype)
  68           (setq prop 'supertype))
  69         (put catsym prop (pop properties))))
  70     ;; Make sure there's a `supertype' property
  71     (unless (get catsym 'supertype)
  72       (put catsym 'supertype 'button))
  73     name))
  74
  75 (defun define-widget (name class doc &rest args)
  76   "Define a new widget type named NAME from CLASS.
  77
  78 NAME and CLASS should both be symbols, CLASS should be one of the
  79 existing widget types, or nil to create the widget from scratch.
  80
  81 After the new widget has been defined, the following two calls will
  82 create identical widgets:
  83
  84 * (widget-create NAME)
  85
  86 * (apply 'widget-create CLASS ARGS)
  87
  88 The third argument DOC is a documentation string for the widget."
  89   (put name 'widget-type (cons class args))
  90   (put name 'widget-documentation doc)
  91   (put name :created-in-function (widget-get-backtrace-info  8))
  92   name)
  93
  94 (defvar describe-temp-help-buffer nil)
  95 (defun describe-get-temp-help-buffer ()
  96   (setq describe-temp-help-buffer (get-buffer-create "*Copy of *Help* Buffer for Description*")))
  97
  98 (defun describe-field (pos)
  99   "Describe field at marker POS."
 100   (interactive (list (point)))
 101   (unless (markerp pos) (setq pos (copy-marker pos)))
 102   (when (eq (marker-buffer pos) (get-buffer (help-buffer)))
 103     (with-current-buffer (describe-get-temp-help-buffer)
 104       (erase-buffer)
 105       (insert (with-current-buffer (help-buffer)
 106                 (buffer-string)))
 107       (goto-char (marker-position pos))
 108       (setq pos (point-marker))))
 109   (let (field wbutton doc button widget)
 110     (with-current-buffer (marker-buffer pos)
 111       (setq field (get-char-property pos 'field))
 112       (setq wbutton (get-char-property pos 'button))
 113       (setq doc (get-char-property pos 'widget-doc))
 114       (setq button (button-at pos))
 115       (setq widget (or field wbutton doc)))
 116     (cond ((and widget
 117                 (if (symbolp widget)
 118                     (get widget 'widget-type)
 119                   (and (consp widget)
 120                        (get (widget-type widget) 'widget-type))))
 121            (describe-widget pos))
 122           (button
 123            (describe-button pos))
 124           ((and (eq major-mode 'Info-mode)
 125                 (memq (get-text-property pos 'font-lock-face)
 126                       '(info-xref info-xref-visited)))
 127            (message "info link"))
 128           (t
 129            (message "No widget or button at point")))))
 130
 131 (defun describe-insert-header (pos)
 132   (widget-insert
 133    (add-string-property
 134     (concat
 135      (format "Description of the field at position %d in "
 136              (marker-position pos))
 137      (format "\"%s\"" (marker-buffer pos))
 138      ":\n\n")
 139     'face '(italic))))
 140
 141 (defun describe-widget (pos)
 142   ;;(interactive (list (point-marker)))
 143   (unless (markerp pos) (setq pos (copy-marker pos)))
 144   (with-output-to-temp-buffer (help-buffer)
 145     (help-setup-xref (list #'describe-widget pos) (interactive-p))
 146     (with-current-buffer (help-buffer)
 147       (let ((inhibit-read-only t))
 148         (describe-insert-header pos)
 149         (insert-text-button "This field"
 150                             'action (lambda (button)
 151                                       (let* ((m (button-get button 'field-location))
 152                                              (p (marker-position m))
 153                                              (b (marker-buffer m)))
 154                                         (if (not (buffer-live-p b))
 155                                             (message "Sorry the markers buffer is gone")
 156                                           (switch-to-buffer b)
 157                                           (goto-char p))))
 158                             'field-location pos)
 159         (princ " is of type ")
 160         (insert-text-button "widget"
 161                             'action (lambda (button)
 162                                       (info "(widget)")))
 163         (princ ". You can ")
 164         (insert-text-button "browse the widget's properties"
 165                             'action (lambda (button)
 166                                       (widget-browse-at
 167                                        (button-get button 'field-location)))
 168                             'field-location pos))
 169       (princ " to find out more about it.")
 170       (fill-region (point-min) (point-max))
 171       )
 172     (with-no-warnings (print-help-return-message))))
 173
 174 (defun describe-button (pos)
 175   (let ((button (button-at pos)))
 176     (with-output-to-temp-buffer (help-buffer)
 177       (help-setup-xref (list #'describe-button pos) (interactive-p))
 178       (with-current-buffer (help-buffer)
 179         (let ((inhibit-read-only t)
 180               ;;(button-marker (gensym))
 181               )
 182           (describe-insert-header pos)
 183           (insert-text-button "This field"
 184                               'action (lambda (button)
 185                                         (let* ((m (button-get button 'field-location))
 186                                                (p (marker-position m))
 187                                                (b (marker-buffer m)))
 188                                           (switch-to-buffer b)
 189                                           (goto-char p)))
 190                               'field-location pos)
 191           (princ " is of type ")
 192           (insert-text-button "button"
 193                               'action (lambda (button)
 194                                         (info "(elisp) Buttons")))
 195           (princ ". You can ")
 196           ;;(set button-marker pos)
 197           (insert-text-button "browse the button's properties"
 198                               'action `(lambda (button)
 199                                          ;;(button-browse-at (symbol-value ',button-marker)))))
 200                                          (button-browse-at ,pos))))
 201         (princ " to find out more about it.")
 202         (fill-region (point-min) (point-max))
 203         )
 204       (with-no-warnings (print-help-return-message)))))
 205
 206 ;; Obsolete
 207 ;; (defun whelp-describe-symbol (sym)
 208 ;;   (interactive "SSymbol: ")
 209 ;;   (with-output-to-temp-buffer (help-buffer)
 210 ;;     (help-setup-xref (list #'describe-symbol sym) (interactive-p))
 211 ;;     (with-current-buffer (help-buffer)
 212 ;;       (let ((inhibit-read-only t))
 213 ;;         (if (not (symbolp sym))
 214 ;;             (progn
 215 ;;               (princ "Argument does not look like it is a ")
 216 ;;               (insert-text-button "symbol"
 217 ;;                                   'action (lambda (button)
 218 ;;                                             (info "(elisp) Symbols")))
 219 ;;               (princ "."))
 220 ;;           (let ((n 0))
 221 ;;             (when (fboundp sym)        (setq n (1+ n)))
 222 ;;             (when (boundp sym)         (setq n (1+ n)))
 223 ;;             (when (facep sym)          (setq n (1+ n)))
 224 ;;             (when (custom-group-p sym) (setq n (1+ n)))
 225 ;;             (if (= n 0)
 226 ;;                 (progn
 227 ;;                   (princ "Can't determine usage for the ")
 228 ;;                   (insert-text-button "symbol"
 229 ;;                                       'action (lambda (button)
 230 ;;                                                 (info "(elisp) Symbols")))
 231 ;;                   (princ " '")
 232 ;;                   (princ (symbol-name sym))
 233 ;;                   (princ "."))
 234 ;;               (princ "The ")
 235 ;;               (insert-text-button "symbol"
 236 ;;                                   'action (lambda (button)
 237 ;;                                             (info "(elisp) Symbols")))
 238 ;;               (princ " '")
 239 ;;               (princ (symbol-name sym))
 240 ;;               (if (= n 1)
 241 ;;                   (progn
 242 ;;                     (princ " is a ")
 243 ;;                     (cond ((fboundp sym)
 244 ;;                            (princ "function (")
 245 ;;                            (insert-text-button
 246 ;;                             "describe it"
 247 ;;                             'action (lambda (button)
 248 ;;                                       (let ((value (button-get button 'value)))
 249 ;;                                         (describe-function value)))
 250 ;;                             'value sym)
 251 ;;                            (insert ")"))
 252 ;;                           ((boundp sym)
 253 ;;                            (insert "variable (")
 254 ;;                            (insert-text-button
 255 ;;                             "describe it"
 256 ;;                             'action (lambda (button)
 257 ;;                                       (let ((value (button-get button 'value)))
 258 ;;                                         (describe-variable value)))
 259 ;;                             'value sym)
 260 ;;                            (insert ")"))
 261 ;;                           ((facep sym)
 262 ;;                            (insert "face (")
 263 ;;                            (insert-text-button
 264 ;;                             "describe it"
 265 ;;                             'action (lambda (button)
 266 ;;                                       (let ((value (button-get button 'value)))
 267 ;;                                         (describe-face value)))
 268 ;;                             'value sym)
 269 ;;                            (insert ")"))
 270 ;;                           ((custom-group-p sym)
 271 ;;                            (insert "customize group (")
 272 ;;                            (insert-text-button
 273 ;;                             "customize it"
 274 ;;                             'action (lambda (button)
 275 ;;                                       (let ((value (button-get button 'value)))
 276 ;;                                         (customize-group value)))
 277 ;;                             'value sym)
 278 ;;                            (insert ")")))
 279 ;;                     (princ "."))
 280 ;;                 (princ " has several usages currently.")
 281 ;;                 (princ " It can be:\n\n")
 282 ;;                 (when (fboundp sym)
 283 ;;                   (princ "  - A function (")
 284 ;;                   (insert-text-button "describe it"
 285 ;;                                       'action (lambda (button)
 286 ;;                                                 (let ((value (button-get button 'value)))
 287 ;;                                                   (describe-function value)))
 288 ;;                                       'value sym)
 289 ;;                   (princ ")\n"))
 290 ;;                 (when (boundp sym)
 291 ;;                   (princ "  - A variable (")
 292 ;;                   (insert-text-button "describe it"
 293 ;;                                       'action (lambda (button)
 294 ;;                                                     (let ((value (button-get button 'value)))
 295 ;;                                                       (describe-variable value)))
 296 ;;                                       'value sym)
 297 ;;                   (princ ")\n"))
 298 ;;                 (when (facep sym)
 299 ;;                   (princ "  - A face (")
 300 ;;                   (insert-text-button "describe it"
 301 ;;                                       'action (lambda (button)
 302 ;;                                                 (let ((value (button-get button 'value)))
 303 ;;                                                   (describe-face value)))
 304 ;;                                       'value sym)
 305 ;;                   (princ ")\n"))
 306 ;;                 (when (custom-group-p sym)
 307 ;;                   (princ "  - A customization group (")
 308 ;;                   (insert-text-button "customize it"
 309 ;;                                       'action (lambda (button)
 310 ;;                                                 (let ((value (button-get button 'value)))
 311 ;;                                                   (customize-group value)))
 312 ;;                                       'value sym)
 313 ;;                   (princ ")\n"))
 314 ;;                 )))
 315 ;;           (princ "\n\nSymbol's property list:\n\n")
 316 ;;           (let ((pl (symbol-plist sym))
 317 ;;                 key
 318 ;;                 val)
 319 ;;             (princ (format "  %25s   %s\n" "Key" "Value"))
 320 ;;             (princ (format "  %25s   %s\n" "---" "-----"))
 321 ;;             (while pl
 322 ;;               (setq key (car pl))
 323 ;;               (setq pl (cdr pl))
 324 ;;                 (setq val (car pl))
 325 ;;                 (setq pl (cdr pl))
 326 ;;                 (let ((first (point-marker))
 327 ;;                       last)
 328 ;;                   (princ (format "  %25s - %s" key val))
 329 ;;                   (setq last (point-marker))
 330 ;;                   (let ((adaptive-fill-function
 331 ;;                          (lambda ()
 332 ;;                            (format "  %25s - " key))))
 333 ;;                     (fill-region first last)
 334 ;;                     ))
 335 ;;                 (princ "\n")
 336 ;;                 )))
 337 ;;         (with-no-warnings (print-help-return-message))))))
 338
 339
 340
 341 (defun widget-browse-sexp (widget key value)
 342   "Insert description of WIDGET's KEY VALUE.
 343 Nothing is assumed about value."
 344   (let ((pp (condition-case signal
 345                 (pp-to-string value)
 346               (error (prin1-to-string signal)))))
 347     (when (string-match "\n\\'" pp)
 348       (setq pp (substring pp 0 (1- (length pp)))))
 349     (if (cond ((string-match "\n" pp)
 350                nil)
 351               ((> (length pp) (- (window-width) (current-column)))
 352                nil)
 353               (t t))
 354         (cond
 355          (  (and value
 356                  (symbolp value)
 357                  (or (fboundp value)
 358                      (boundp value)
 359                      (facep value)))
 360             (widget-create 'push-button
 361                            :tag pp
 362                            :value value
 363                            :action '(lambda (widget &optional event)
 364                                       (let ((value (widget-get widget :value))
 365                                             (n 0))
 366                                         (when (fboundp value) (setq n (1+ n)))
 367                                         (when (boundp value) (setq n (1+ n)))
 368                                         (when (facep value) (setq n (1+ n)))
 369                                         (if (= n 1)
 370                                             (cond ((fboundp value)
 371                                                    (describe-function value))
 372                                                   ((boundp value)
 373                                                    (describe-variable value))
 374                                                   ((facep value)
 375                                                    (describe-face value)))
 376                                           (describe-symbol value))))))
 377          (  (markerp value)
 378             (widget-create 'push-button
 379                            :tag pp
 380                            :value (list (marker-position value) (marker-buffer value))
 381                            :action '(lambda (widget &optional event)
 382                                       (let ((value (widget-get widget :value)))
 383                                         (let ((pos (car value))
 384                                               (buf (cadr value)))
 385                                           (switch-to-buffer-other-window buf)
 386                                           (goto-char pos))))))
 387          (  (overlayp value)
 388             (widget-create 'push-button
 389                            :tag pp
 390                            :value (list (overlay-start value) (overlay-buffer value))
 391                            :action '(lambda (widget &optional event)
 392                                       (let ((value (widget-get widget :value)))
 393                                         (let ((pos (car value))
 394                                               (buf (cadr value)))
 395                                           (switch-to-buffer-other-window buf)
 396                                           (goto-char pos))))))
 397          (  t
 398             (widget-insert pp)))
 399
 400       (widget-create 'push-button
 401                      :tag "show"
 402                      :action (lambda (widget &optional event)
 403                                (with-output-to-temp-buffer
 404                                    "*Pp Eval Output*"
 405                                  (princ (widget-get widget :value))))
 406                      pp))))
 407
 408
 409 (defvar widget-get-backtrace-active t
 410   "Whether to collect backtrace info for widgets and buttons.
 411 Turn this on only for debugging purposes.
 412
 413 Note: This must be t when Emacs is loading to collect the needed
 414 information.")
 415
 416 (defun widget-get-backtrace-info (n)
 417   (if widget-get-backtrace-active
 418       (let ((frame-n t)
 419             fun)
 420         (while (and frame-n
 421                     (not fun))
 422           (setq frame-n (backtrace-frame n))
 423           (when frame-n
 424             ;;(message "**BT %s:  %s" n (cadr frame-n))
 425             (when (car frame-n)
 426               (setq fun (cadr frame-n))
 427               (when (or (listp fun)
 428                         (member fun
 429                                 '(
 430                                   backtrace-frame
 431                                   widget-get-backtrace-info
 432
 433                                   eval
 434                                   eval-expression
 435                                   call-interactively
 436                                   apply
 437                                   funcall
 438                                   ;;lambda
 439
 440                                   if
 441                                   when
 442                                   cond
 443                                   condition
 444                                   mapc
 445                                   mapcar
 446                                   while
 447
 448                                   let
 449                                   let*
 450                                   set
 451                                   setq
 452                                   set-variable
 453                                   set-default
 454
 455                                   widget-create
 456                                   widget-create-child-and-convert
 457                                   widget-create-child
 458                                   widget-create-child-value
 459                                   define-button-type
 460                                   define-widget
 461                                   make-text-button
 462                                   insert-text-button
 463                                   make-button
 464                                   insert-button
 465                                   )))
 466                 (setq fun)))
 467             (setq n (1+ n))))
 468         ;;(message "---------- fun=%s" fun)
 469         fun)
 470     "Set widget-get-backtrace-info to show this"))
 471
 472 (defun widget-create (type &rest args)
 473   "Create widget of TYPE.
 474 The optional ARGS are additional keyword arguments."
 475   (unless (keywordp :created-in-function) (error ":wcw not interned"))
 476   (let ((where-fun (widget-get-backtrace-info 8))
 477         yargs)
 478     (setq args
 479           (cons :created-in-function
 480                 (cons where-fun
 481                       args)))
 482     (let ((widget (apply 'widget-convert type args)))
 483       (widget-apply widget :create)
 484       widget)))
 485
 486
 487 (defun widget-create-child-and-convert (parent type &rest args)
 488   "As part of the widget PARENT, create a child widget TYPE.
 489 The child is converted, using the keyword arguments ARGS."
 490   (let ((widget (apply 'widget-convert type args)))
 491     (widget-put widget :parent parent)
 492     (widget-put widget :created-in-function (widget-get-backtrace-info  15))
 493     (unless (widget-get widget :indent)
 494       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 495                                     (or (widget-get widget :extra-offset) 0)
 496                                     (widget-get parent :offset))))
 497     (widget-apply widget :create)
 498     widget))
 499
 500 (defun widget-create-child (parent type)
 501   "Create widget of TYPE."
 502   (let ((widget (widget-copy type)))
 503     (widget-put widget :parent parent)
 504     (widget-put widget :created-in-function (widget-get-backtrace-info  15))
 505     (unless (widget-get widget :indent)
 506       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 507                                     (or (widget-get widget :extra-offset) 0)
 508                                     (widget-get parent :offset))))
 509     (widget-apply widget :create)
 510     widget))
 511
 512 (defun widget-create-child-value (parent type value)
 513   "Create widget of TYPE with value VALUE."
 514   (let ((widget (widget-copy type)))
 515     (widget-put widget :value (widget-apply widget :value-to-internal value))
 516     (widget-put widget :parent parent)
 517     (widget-put widget :created-in-function (widget-get-backtrace-info  15))
 518     (unless (widget-get widget :indent)
 519       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 520                                     (or (widget-get widget :extra-offset) 0)
 521                                     (widget-get parent :offset))))
 522     (widget-apply widget :create)
 523     widget))
 524
 525 (defvar widget-browse-fb-history nil
 526   "Forward/backward history.")
 527 (setq widget-browse-fb-history nil)
 528
 529 (defun widget-fb-button-action (widget &ignore)
 530   (let* ((num (widget-get widget :history-number))
 531          (rec (nth num widget-browse-fb-history))
 532          (fun (nth 0 rec))
 533          (val (nth 1 rec))
 534          (loc (nth 2 rec)))
 535     ;;(message "fun=%s, val=%s, loc=%s" fun val loc)(sit-for 4)
 536     (funcall fun num)))
 537
 538 (defun widget-insert-fb-buttons (current-number)
 539   ;;(message "current-number=%s" current-number)(sit-for 2)
 540   (if (<= 0 (1- current-number))
 541       (widget-create 'push-button
 542                      :action 'widget-fb-button-action
 543                      :history-number (1- current-number)
 544                      :format "%[%v%]"
 545                      "back")
 546     (widget-insert (add-string-property "[back]"
 547                                         'face 'shadow)))
 548   (widget-insert " ")
 549   (if (< (1+ current-number) (length widget-browse-fb-history))
 550       (widget-create 'push-button
 551                      :action 'widget-fb-button-action
 552                      :history-number (1+ current-number)
 553                      :format "%[%v%]"
 554                      "forward")
 555     (widget-insert (add-string-property "[forward]"
 556                                         'face 'shadow)))
 557   (widget-insert "\n"))
 558
 559 (defun widget-add-fb-history (elt)
 560   (let ((last (car widget-browse-fb-history)))
 561     (unless (equal elt last)
 562       (setq widget-browse-fb-history
 563             (reverse (cons elt
 564                            (reverse widget-browse-fb-history)))))))
 565
 566 (defun widget-browse (widget &optional location)
 567   "Create a widget browser for WIDGET."
 568   (interactive (list (completing-read "Widget: "
 569                                       obarray
 570                                       (lambda (symbol)
 571                                         (get symbol 'widget-type))
 572                                       t nil 'widget-browse-history)))
 573   (let (history-number)
 574     (if (integerp widget)
 575         (progn
 576           ;;(message "was integer=%s" widget)(sit-for 2)
 577           (setq history-number widget)
 578           (setq widget (nth 1 (nth widget widget-browse-fb-history))))
 579       ;;(message "was NOT integer=%s" widget)(sit-for 2)
 580       (widget-add-fb-history (list 'widget-browse widget location))
 581       (setq history-number (1- (length widget-browse-fb-history))))
 582     ;;(message "history-number=%s" history-number)(sit-for 2)
 583
 584     (if (stringp widget)
 585         (setq widget (intern widget)))
 586     (unless (if (symbolp widget)
 587                 (get widget 'widget-type)
 588               (and (consp widget)
 589                    (get (widget-type widget) 'widget-type)))
 590       (error "Not a widget"))
 591
 592     ;; Create the buffer.
 593     (if (symbolp widget)
 594         (let ((buffer (format "*Browse %s Widget*" widget)))
 595           (kill-buffer (get-buffer-create buffer))
 596           (switch-to-buffer (get-buffer-create buffer)))
 597       (kill-buffer (get-buffer-create "*Browse Widget*"))
 598       (switch-to-buffer (get-buffer-create "*Browse Widget*")))
 599     (widget-browse-mode)
 600
 601     (make-local-variable 'widget-button-face)
 602     (setq widget-button-face 'link)
 603     (set (make-local-variable 'widget-push-button-prefix) "")
 604     (set (make-local-variable 'widget-push-button-suffix) "")
 605     (set (make-local-variable 'widget-link-prefix) "")
 606     (set (make-local-variable 'widget-link-suffix) "")
 607
 608     ;; Top text indicating whether it is a class or object browser.
 609     (widget-insert-fb-buttons history-number)
 610     (widget-insert "----------------\n")
 611     (if (listp widget)
 612         (progn
 613           (widget-insert (add-string-property
 614                           "Widget object browser"
 615                           'face 'widget-browse-h1))
 616           (widget-insert "\n\n")
 617           (when location
 618             (let ((b (marker-buffer location))
 619                   (p (marker-position location)))
 620               (widget-insert (add-string-property "Location: "
 621                                                   'face 'italic))
 622               (widget-create 'push-button
 623                              :tag (format "position %s in buffer %s" p b)
 624                              :value (list p b)
 625                              :action '(lambda (widget &optional event)
 626                                         (let ((value (widget-get widget :value)))
 627                                           (let ((pos (car value))
 628                                                 (buf (cadr value)))
 629                                             (switch-to-buffer-other-window buf)
 630                                             (goto-char pos)))))
 631               (widget-insert "\n\n")))
 632           (widget-insert (add-string-property "Class: "
 633                                               'face 'italic)))
 634       (widget-insert (add-string-property "Widget class browser"
 635                                           'face 'widget-browse-h1))
 636       (widget-insert ".\n\n")
 637       (widget-insert (add-string-property "Class: " 'face 'italic))
 638       (widget-insert (add-string-property (format "%s\n" widget)
 639                                           'face '(bold)))
 640       (widget-insert (format "%s" (get widget 'widget-documentation)))
 641       (unless (eq (preceding-char) ?\n) (widget-insert "\n"))
 642       (widget-insert (add-string-property "\nSuper: " 'face 'italic))
 643       (setq widget (get widget 'widget-type))
 644       )
 645
 646     ;(widget-insert (format "%s\n" widget))
 647
 648     ;; Now show the attributes.
 649     (let ((name (car widget))
 650           (items (cdr widget))
 651           key value printer)
 652       (if (not name)
 653           (widget-insert "none\n")
 654         (let ((ancestors (list name))
 655               a
 656               (i1 7)
 657               i
 658               )
 659           (setq i i1)
 660           (while name
 661             (setq a (intern-soft name))
 662             (if a
 663                 (progn
 664                   (setq a (get a 'widget-type))
 665                   (setq name (car a))
 666                   (when (intern-soft name)
 667                     (push name ancestors)))
 668               (setq name)))
 669           ;;(widget-insert (format "ancestors=%s\n" ancestors))
 670           (mapc (lambda (w)
 671                   (widget-insert (make-string (if (= i i1) 0 i) ? ))
 672                   (widget-create 'widget-browse
 673                                  :format "%[%v%]"
 674                                  w)
 675                   (widget-insert "\n")
 676                   (setq i (+ i 2)))
 677                 ancestors)))
 678       (while items
 679         (setq key (nth 0 items)
 680               value (nth 1 items)
 681               printer (or (get key 'widget-keyword-printer)
 682                           'widget-browse-sexp)
 683               items (cdr (cdr items)))
 684         (widget-insert "\n"
 685                        (add-string-property (symbol-name key)
 686                                             'face 'italic))
 687         (when (widget-browse-explained key)
 688           (widget-insert " (")
 689           (widget-create
 690            ;;'push-button
 691            ;;:tag "explain"
 692            ;;:format "%[%v%]"
 693            ;;:button-prefix ""
 694            ;;:button-suffix ""
 695            'widget-browse-link
 696            :value key
 697            :tag "explain"
 698            :format "%[%t%]"
 699            :action '(lambda (widget &optional event)
 700                       (widget-browse-explain
 701                        ;;(widget-get widget :value)
 702                        (widget-value widget)
 703                        ))
 704            )
 705           (widget-insert ")"))
 706         (widget-insert "\n\t")
 707         (funcall printer widget key value)
 708         (widget-insert "\n")))
 709
 710     (widget-insert "\n-----------\n")
 711     (widget-insert-fb-buttons history-number)
 712
 713     (widget-setup)
 714     (goto-char (point-min))
 715 ;;     (when wid-to-history
 716 ;;       (setq widget-browse-fb-history
 717 ;;             (reverse (cons (list 'widget-browse wid-to-history location)
 718 ;;                            (reverse widget-browse-fb-history)))))
 719     ))
 720
 721 (defun widget-browse-at (pos)
 722   "Browse the widget under point."
 723   (interactive "d")
 724   (let ((mp pos)
 725         (b (if (markerp pos) (marker-buffer pos)
 726              (current-buffer))))
 727     (if (not (buffer-live-p b))
 728         (message "Sorry the markers buffer is gone")
 729       (with-current-buffer b
 730         (when (markerp pos)
 731           (setq pos (marker-position pos)))
 732         (let* ((field (get-char-property pos 'field))
 733                (button (get-char-property pos 'button))
 734                (doc (get-char-property pos 'widget-doc))
 735                (text (cond (field "This is an editable text area.")
 736                            (button "This is an active area.")
 737                            (doc "This is documentation text.")
 738                            (t "This is unidentified text.")))
 739                (widget (or field button doc)))
 740           (when widget
 741             (widget-browse widget mp))
 742           (message text))))))
 743
 744 (defun button-at (pos)
 745   "Return the button at marker or position POS, or nil.
 746 If not a marker use the current buffer."
 747   (with-current-buffer (if (markerp pos) (marker-buffer pos)
 748                          (current-buffer))
 749     (when (markerp pos)
 750       (setq pos (marker-position pos)))
 751     (let ((button (get-char-property pos 'button)))
 752       (if (or (overlayp button) (null button))
 753           button
 754         ;; Must be a text-property button; return a marker pointing to it.
 755         (copy-marker pos t)))))
 756
 757 (defun button-browse-at (pos)
 758   (interactive "d")
 759   (let ((b (if (markerp pos) (marker-buffer pos)
 760              (current-buffer))))
 761     (if (not (buffer-live-p b))
 762         (message "Sorry the button's buffer is gone")
 763       (button-browse (button-at pos)))))
 764
 765 (defun button-browse (button)
 766   "Create a widget browser for WIDGET."
 767   (interactive (list (completing-read "Button: "
 768                                       obarray
 769                                       (lambda (symbol)
 770                                         (or (get symbol 'button-category-symbol)
 771                                             (get symbol 'supertype)))
 772                                       t nil 'button-browse-history)))
 773   (let (history-number)
 774     (if (integerp button)
 775         (progn
 776           (setq history-number button)
 777           (setq button (nth 1 (nth button widget-browse-fb-history))))
 778       (widget-add-fb-history (list 'button-browse button))
 779       (setq history-number (1- (length widget-browse-fb-history))))
 780
 781     (when (stringp button)
 782       (setq button (intern-soft button)))
 783     (when (symbolp button)
 784       (unless (and button
 785                    (or (eq button 'default-button)
 786                        (get button 'supertype)
 787                        (get button 'button-category-symbol)
 788                        (save-match-data
 789                          (string-match "-button$" (symbol-name button)))))
 790         (error "Not a button")))
 791     ;; Create the buffer.
 792     (kill-buffer (get-buffer-create "*Browse Button*"))
 793     (switch-to-buffer (get-buffer-create "*Browse Button*"))
 794     (widget-browse-mode)
 795
 796     (make-local-variable 'widget-button-face)
 797     (setq widget-button-face 'link)
 798
 799     (widget-insert-fb-buttons history-number)
 800     (widget-insert "----------------\n")
 801
 802     ;; Top text indicating whether it is a class or object browser.
 803     (if (or (overlayp button)
 804             (markerp button))
 805         (progn
 806           (widget-insert (add-string-property "Button object browser"
 807                                               'face 'widget-browse-h1))
 808           (widget-insert "\n\n")
 809           (let ((b (if (markerp button)
 810                        (marker-buffer button)
 811                      (overlay-buffer button)))
 812                 (p (if (markerp button)
 813                        (marker-position button)
 814                      (overlay-start button))))
 815             (widget-insert (add-string-property "Location: "
 816                                                 'face 'italic))
 817             (widget-create 'push-button
 818                            :tag (format "position %s in buffer %s" p b)
 819                            :value (list p b)
 820                            :action '(lambda (widget &optional event)
 821                                       (let ((value (widget-get widget :value)))
 822                                         (let ((pos (car value))
 823                                               (buf (cadr value)))
 824                                           (switch-to-buffer-other-window buf)
 825                                           (goto-char pos)))))
 826             (widget-insert "\n\n")))
 827       (widget-insert (add-string-property "Button class browser"
 828                                           'face 'widget-browse-h1))
 829       (widget-insert "\n\n")
 830       (widget-insert (add-string-property "Type: "
 831                                           'face 'italic))
 832       (widget-insert (add-string-property (symbol-name button)
 833                                           'face 'bold))
 834       (widget-insert "\n"))
 835
 836     ;; Now show the attributes.
 837     (let (
 838           (items
 839            (if (symbolp button)
 840                (if (get button 'button-category-symbol)
 841                    (symbol-plist (get button 'button-category-symbol))
 842                  (symbol-plist button))
 843              (if (markerp button)
 844                  (let ((pos (marker-position button))
 845                        (buf (marker-buffer button)))
 846                    (text-properties-at pos buf))
 847                (overlay-properties button))))
 848           rest-items
 849           name
 850           key value printer)
 851       ;;(insert (format "\n%s\n\n" items))
 852       (let ((copied-items (copy-seq items)))
 853         (while copied-items
 854           (setq key   (nth 0 copied-items)
 855                 value (nth 1 copied-items)
 856                 copied-items (cdr (cdr copied-items)))
 857           (if (eq key 'category)
 858               (setq name value)
 859             (if (eq key 'supertype)
 860                 (setq name (make-symbol (concat (symbol-name value) "-button")))
 861               (push value rest-items)
 862               (push key   rest-items)))))
 863       ;;(insert "\nname=" (symbol-name value) "\n\n")
 864       (when name
 865         (widget-insert (add-string-property
 866                         (if (symbolp button)
 867                             (if (get button 'supertype)
 868                                 "Supertype: "
 869                               "")
 870                           "Category:  ")
 871                         'face 'italic))
 872         (let* (a
 873                (ancestors
 874                 (list name))
 875                (i1 11)
 876                (i i1))
 877           (while name
 878             (setq a (or (get name 'supertype)
 879                         (get name :supertype)))
 880             ;;(message "name=%s, a=%s\n    name plist=%s" name a (symbol-plist name));(sit-for 4)
 881             (if (or (not a)
 882                     (eq a 'default-button))
 883                 (setq name)
 884               (setq name (make-symbol (concat (symbol-name a) "-button")))
 885               (setq ancestors (cons name ancestors))))
 886           ;;(message "ancestors=%s" ancestors)(sit-for 2)
 887           (mapc (lambda (w)
 888                   (widget-insert (make-string (if (= i i1) 0 i) ? ))
 889                   (widget-create 'button-browse
 890                                  :format "%[%v%]"
 891                                  w)
 892                   (widget-insert "\n")
 893                   (setq i (+ i 2)))
 894                 ancestors)))
 895       (while rest-items
 896         (setq key   (nth 0 rest-items)
 897               value (nth 1 rest-items)
 898               printer (or (get key 'widget-keyword-printer)
 899                           'widget-browse-sexp)
 900               rest-items (cdr (cdr rest-items)))
 901         (widget-insert "\n"
 902                        (add-string-property (symbol-name key)
 903                                             'face 'italic))
 904         (when (widget-browse-explained key)
 905           (widget-insert " (")
 906           (widget-create 'push-button
 907                          :tag "explain"
 908                          :value key
 909                          :action '(lambda (widget &optional event)
 910                                     (widget-browse-explain
 911                                      (widget-get widget :value))))
 912           (widget-insert ")"))
 913         (widget-insert "\n\t")
 914         (funcall printer button key value)
 915         (widget-insert "\n")))
 916     (widget-setup)
 917     (goto-char (point-min))
 918
 919 ;;     (when button-to-history
 920 ;;       (setq widget-browse-fb-history
 921 ;;             (reverse (cons (list 'button-browse button-to-history)
 922 ;;                            (reverse widget-browse-fb-history)))))
 923     ))
 924
 925
 926 ;;;###autoload
 927 (defgroup whelp nil
 928   "Customization group for whelp."
 929   :group 'emacs)
 930
 931 (defface widget-browse-h1
 932   '((t (:weight bold :height 1.5)))
 933   "Face for top header in widget/button browse buffers."
 934   :group 'whelp)
 935
 936 (defun add-string-property (str prop val)
 937   (let ((s (copy-seq str)))
 938     (put-text-property 0 (length s)
 939                        prop val
 940                        s)
 941     s))
 942
 943 ;;; The `button-browse' Widget.
 944
 945 (define-widget 'button-browse 'push-button
 946   "Widget button for creating a button browser.
 947 The :value of the widget shuld be the button to be browsed."
 948   :format "%[[%v]%]"
 949   :value-create 'widget-browse-button-value-create
 950   :action 'widget-browse-button-action)
 951
 952 (defun widget-browse-button-action (widget &optional event)
 953   ;; Create widget browser for WIDGET's :value.
 954   (button-browse (widget-get widget :value)))
 955
 956 (defun widget-browse-button-value-create (widget)
 957   ;; Insert type name.
 958   (let ((value (widget-get widget :value)))
 959     (cond ((symbolp value)
 960            (insert (symbol-name value)))
 961           ((consp value)
 962            (insert (symbol-name (widget-type value))))
 963           (t
 964            (insert "strange")))))
 965
 966
 967 (defun widget-browse-explained (property)
 968   (memq property
 969         '(
 970           :created-in-function
 971         )))
 972
 973 (defun widget-browse-explain (property)
 974   (with-output-to-temp-buffer (help-buffer)
 975     (help-setup-xref (list #'widget-browse-explain property) (interactive-p))
 976     (with-current-buffer (help-buffer)
 977       (let ((inhibit-read-only t))
 978         (cond
 979          ( (eq property :created-in-function)
 980            (princ "Property :created-in-function tells where a field object or class is created.")
 981            )
 982          ( t
 983            (princ (format "No explanation found for %s" property))
 984            )
 985          )
 986         (with-no-warnings (print-help-return-message))))))
 987
 988 (provide 'whelp)