From 0d342f0aee3f2f800e486c0051dabe718a7b2841 Mon Sep 17 00:00:00 2001 From: Tom Willemsen Date: Wed, 23 Mar 2011 11:14:27 +0100 Subject: I don't like nxhtml --- emacs.d/nxhtml/util/whelp.el | 988 ------------------------------------------- 1 file changed, 988 deletions(-) delete mode 100644 emacs.d/nxhtml/util/whelp.el (limited to 'emacs.d/nxhtml/util/whelp.el') diff --git a/emacs.d/nxhtml/util/whelp.el b/emacs.d/nxhtml/util/whelp.el deleted file mode 100644 index 77b8149..0000000 --- a/emacs.d/nxhtml/util/whelp.el +++ /dev/null @@ -1,988 +0,0 @@ -;; This is a test file for some enhancement to the possibilities to -;; find out about widgets or buttons at point in a buffer. -;; -;; To use this just load the file. Then put point on a widget or -;; button and do -;; -;; M-x describe-field -;; -;; You find a lot of widgets in a Custom buffer. You can find buttons -;; in for example a help buffer. (Please tell me more places so I can -;; test!) -;; -;; TODO: Add backtrace collecting to some more functions! - -;; For widget-get-backtrace-info -;;(require 'debug) -(eval-when-compile (require 'cl)) ;; gensym -(require 'help-mode) - -;; Last wins! -(require 'wid-browse) - -(intern ":created-in-function") - -(define-widget 'widget-browse-link 'item - "Button for creating a link style button. -The :value of the widget shuld be the widget to be browsed." - :format "%[%v%]" - ;;:value-create 'widget-browse-value-create - ;;:action 'widget-browse-action - ) - -(defun define-button-type (name &rest properties) - "Define a `button type' called NAME. -The remaining arguments form a sequence of PROPERTY VALUE pairs, -specifying properties to use as defaults for buttons with this type -\(a button's type may be set by giving it a `type' property when -creating the button, using the :type keyword argument). - -In addition, the keyword argument :supertype may be used to specify a -button-type from which NAME inherits its default property values -\(however, the inheritance happens only when NAME is defined; subsequent -changes to a supertype are not reflected in its subtypes)." - (let ((catsym (make-symbol (concat (symbol-name name) "-button"))) - (super-catsym - (button-category-symbol - (or (plist-get properties 'supertype) - (plist-get properties :supertype) - 'button)))) - ;; Provide a link so that it's easy to find the real symbol. - (put name 'button-category-symbol catsym) - ;; Initialize NAME's properties using the global defaults. - (let ((default-props (symbol-plist super-catsym)) - (where-fun (widget-get-backtrace-info 8))) - (setq default-props - (cons :created-in-function - (cons where-fun - default-props))) - (while default-props - (put catsym (pop default-props) (pop default-props)))) - ;; Add NAME as the `type' property, which will then be returned as - ;; the type property of individual buttons. - (put catsym 'type name) - ;; Add the properties in PROPERTIES to the real symbol. - (while properties - (let ((prop (pop properties))) - (when (eq prop :supertype) - (setq prop 'supertype)) - (put catsym prop (pop properties)))) - ;; Make sure there's a `supertype' property - (unless (get catsym 'supertype) - (put catsym 'supertype 'button)) - name)) - -(defun define-widget (name class doc &rest args) - "Define a new widget type named NAME from CLASS. - -NAME and CLASS should both be symbols, CLASS should be one of the -existing widget types, or nil to create the widget from scratch. - -After the new widget has been defined, the following two calls will -create identical widgets: - -* (widget-create NAME) - -* (apply 'widget-create CLASS ARGS) - -The third argument DOC is a documentation string for the widget." - (put name 'widget-type (cons class args)) - (put name 'widget-documentation doc) - (put name :created-in-function (widget-get-backtrace-info 8)) - name) - -(defvar describe-temp-help-buffer nil) -(defun describe-get-temp-help-buffer () - (setq describe-temp-help-buffer (get-buffer-create "*Copy of *Help* Buffer for Description*"))) - -(defun describe-field (pos) - "Describe field at marker POS." - (interactive (list (point))) - (unless (markerp pos) (setq pos (copy-marker pos))) - (when (eq (marker-buffer pos) (get-buffer (help-buffer))) - (with-current-buffer (describe-get-temp-help-buffer) - (erase-buffer) - (insert (with-current-buffer (help-buffer) - (buffer-string))) - (goto-char (marker-position pos)) - (setq pos (point-marker)))) - (let (field wbutton doc button widget) - (with-current-buffer (marker-buffer pos) - (setq field (get-char-property pos 'field)) - (setq wbutton (get-char-property pos 'button)) - (setq doc (get-char-property pos 'widget-doc)) - (setq button (button-at pos)) - (setq widget (or field wbutton doc))) - (cond ((and widget - (if (symbolp widget) - (get widget 'widget-type) - (and (consp widget) - (get (widget-type widget) 'widget-type)))) - (describe-widget pos)) - (button - (describe-button pos)) - ((and (eq major-mode 'Info-mode) - (memq (get-text-property pos 'font-lock-face) - '(info-xref info-xref-visited))) - (message "info link")) - (t - (message "No widget or button at point"))))) - -(defun describe-insert-header (pos) - (widget-insert - (add-string-property - (concat - (format "Description of the field at position %d in " - (marker-position pos)) - (format "\"%s\"" (marker-buffer pos)) - ":\n\n") - 'face '(italic)))) - -(defun describe-widget (pos) - ;;(interactive (list (point-marker))) - (unless (markerp pos) (setq pos (copy-marker pos))) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-widget pos) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((inhibit-read-only t)) - (describe-insert-header pos) - (insert-text-button "This field" - 'action (lambda (button) - (let* ((m (button-get button 'field-location)) - (p (marker-position m)) - (b (marker-buffer m))) - (if (not (buffer-live-p b)) - (message "Sorry the markers buffer is gone") - (switch-to-buffer b) - (goto-char p)))) - 'field-location pos) - (princ " is of type ") - (insert-text-button "widget" - 'action (lambda (button) - (info "(widget)"))) - (princ ". You can ") - (insert-text-button "browse the widget's properties" - 'action (lambda (button) - (widget-browse-at - (button-get button 'field-location))) - 'field-location pos)) - (princ " to find out more about it.") - (fill-region (point-min) (point-max)) - ) - (with-no-warnings (print-help-return-message)))) - -(defun describe-button (pos) - (let ((button (button-at pos))) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-button pos) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((inhibit-read-only t) - ;;(button-marker (gensym)) - ) - (describe-insert-header pos) - (insert-text-button "This field" - 'action (lambda (button) - (let* ((m (button-get button 'field-location)) - (p (marker-position m)) - (b (marker-buffer m))) - (switch-to-buffer b) - (goto-char p))) - 'field-location pos) - (princ " is of type ") - (insert-text-button "button" - 'action (lambda (button) - (info "(elisp) Buttons"))) - (princ ". You can ") - ;;(set button-marker pos) - (insert-text-button "browse the button's properties" - 'action `(lambda (button) - ;;(button-browse-at (symbol-value ',button-marker))))) - (button-browse-at ,pos)))) - (princ " to find out more about it.") - (fill-region (point-min) (point-max)) - ) - (with-no-warnings (print-help-return-message))))) - -;; Obsolete -;; (defun whelp-describe-symbol (sym) -;; (interactive "SSymbol: ") -;; (with-output-to-temp-buffer (help-buffer) -;; (help-setup-xref (list #'describe-symbol sym) (interactive-p)) -;; (with-current-buffer (help-buffer) -;; (let ((inhibit-read-only t)) -;; (if (not (symbolp sym)) -;; (progn -;; (princ "Argument does not look like it is a ") -;; (insert-text-button "symbol" -;; 'action (lambda (button) -;; (info "(elisp) Symbols"))) -;; (princ ".")) -;; (let ((n 0)) -;; (when (fboundp sym) (setq n (1+ n))) -;; (when (boundp sym) (setq n (1+ n))) -;; (when (facep sym) (setq n (1+ n))) -;; (when (custom-group-p sym) (setq n (1+ n))) -;; (if (= n 0) -;; (progn -;; (princ "Can't determine usage for the ") -;; (insert-text-button "symbol" -;; 'action (lambda (button) -;; (info "(elisp) Symbols"))) -;; (princ " '") -;; (princ (symbol-name sym)) -;; (princ ".")) -;; (princ "The ") -;; (insert-text-button "symbol" -;; 'action (lambda (button) -;; (info "(elisp) Symbols"))) -;; (princ " '") -;; (princ (symbol-name sym)) -;; (if (= n 1) -;; (progn -;; (princ " is a ") -;; (cond ((fboundp sym) -;; (princ "function (") -;; (insert-text-button -;; "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-function value))) -;; 'value sym) -;; (insert ")")) -;; ((boundp sym) -;; (insert "variable (") -;; (insert-text-button -;; "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-variable value))) -;; 'value sym) -;; (insert ")")) -;; ((facep sym) -;; (insert "face (") -;; (insert-text-button -;; "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-face value))) -;; 'value sym) -;; (insert ")")) -;; ((custom-group-p sym) -;; (insert "customize group (") -;; (insert-text-button -;; "customize it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (customize-group value))) -;; 'value sym) -;; (insert ")"))) -;; (princ ".")) -;; (princ " has several usages currently.") -;; (princ " It can be:\n\n") -;; (when (fboundp sym) -;; (princ " - A function (") -;; (insert-text-button "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-function value))) -;; 'value sym) -;; (princ ")\n")) -;; (when (boundp sym) -;; (princ " - A variable (") -;; (insert-text-button "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-variable value))) -;; 'value sym) -;; (princ ")\n")) -;; (when (facep sym) -;; (princ " - A face (") -;; (insert-text-button "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-face value))) -;; 'value sym) -;; (princ ")\n")) -;; (when (custom-group-p sym) -;; (princ " - A customization group (") -;; (insert-text-button "customize it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (customize-group value))) -;; 'value sym) -;; (princ ")\n")) -;; ))) -;; (princ "\n\nSymbol's property list:\n\n") -;; (let ((pl (symbol-plist sym)) -;; key -;; val) -;; (princ (format " %25s %s\n" "Key" "Value")) -;; (princ (format " %25s %s\n" "---" "-----")) -;; (while pl -;; (setq key (car pl)) -;; (setq pl (cdr pl)) -;; (setq val (car pl)) -;; (setq pl (cdr pl)) -;; (let ((first (point-marker)) -;; last) -;; (princ (format " %25s - %s" key val)) -;; (setq last (point-marker)) -;; (let ((adaptive-fill-function -;; (lambda () -;; (format " %25s - " key)))) -;; (fill-region first last) -;; )) -;; (princ "\n") -;; ))) -;; (with-no-warnings (print-help-return-message)))))) - - - -(defun widget-browse-sexp (widget key value) - "Insert description of WIDGET's KEY VALUE. -Nothing is assumed about value." - (let ((pp (condition-case signal - (pp-to-string value) - (error (prin1-to-string signal))))) - (when (string-match "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - (if (cond ((string-match "\n" pp) - nil) - ((> (length pp) (- (window-width) (current-column))) - nil) - (t t)) - (cond - ( (and value - (symbolp value) - (or (fboundp value) - (boundp value) - (facep value))) - (widget-create 'push-button - :tag pp - :value value - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value)) - (n 0)) - (when (fboundp value) (setq n (1+ n))) - (when (boundp value) (setq n (1+ n))) - (when (facep value) (setq n (1+ n))) - (if (= n 1) - (cond ((fboundp value) - (describe-function value)) - ((boundp value) - (describe-variable value)) - ((facep value) - (describe-face value))) - (describe-symbol value)))))) - ( (markerp value) - (widget-create 'push-button - :tag pp - :value (list (marker-position value) (marker-buffer value)) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos)))))) - ( (overlayp value) - (widget-create 'push-button - :tag pp - :value (list (overlay-start value) (overlay-buffer value)) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos)))))) - ( t - (widget-insert pp))) - - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) - - -(defvar widget-get-backtrace-active t - "Whether to collect backtrace info for widgets and buttons. -Turn this on only for debugging purposes. - -Note: This must be t when Emacs is loading to collect the needed -information.") - -(defun widget-get-backtrace-info (n) - (if widget-get-backtrace-active - (let ((frame-n t) - fun) - (while (and frame-n - (not fun)) - (setq frame-n (backtrace-frame n)) - (when frame-n - ;;(message "**BT %s: %s" n (cadr frame-n)) - (when (car frame-n) - (setq fun (cadr frame-n)) - (when (or (listp fun) - (member fun - '( - backtrace-frame - widget-get-backtrace-info - - eval - eval-expression - call-interactively - apply - funcall - ;;lambda - - if - when - cond - condition - mapc - mapcar - while - - let - let* - set - setq - set-variable - set-default - - widget-create - widget-create-child-and-convert - widget-create-child - widget-create-child-value - define-button-type - define-widget - make-text-button - insert-text-button - make-button - insert-button - ))) - (setq fun))) - (setq n (1+ n)))) - ;;(message "---------- fun=%s" fun) - fun) - "Set widget-get-backtrace-info to show this")) - -(defun widget-create (type &rest args) - "Create widget of TYPE. -The optional ARGS are additional keyword arguments." - (unless (keywordp :created-in-function) (error ":wcw not interned")) - (let ((where-fun (widget-get-backtrace-info 8)) - yargs) - (setq args - (cons :created-in-function - (cons where-fun - args))) - (let ((widget (apply 'widget-convert type args))) - (widget-apply widget :create) - widget))) - - -(defun widget-create-child-and-convert (parent type &rest args) - "As part of the widget PARENT, create a child widget TYPE. -The child is converted, using the keyword arguments ARGS." - (let ((widget (apply 'widget-convert type args))) - (widget-put widget :parent parent) - (widget-put widget :created-in-function (widget-get-backtrace-info 15)) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child (parent type) - "Create widget of TYPE." - (let ((widget (widget-copy type))) - (widget-put widget :parent parent) - (widget-put widget :created-in-function (widget-get-backtrace-info 15)) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child-value (parent type value) - "Create widget of TYPE with value VALUE." - (let ((widget (widget-copy type))) - (widget-put widget :value (widget-apply widget :value-to-internal value)) - (widget-put widget :parent parent) - (widget-put widget :created-in-function (widget-get-backtrace-info 15)) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defvar widget-browse-fb-history nil - "Forward/backward history.") -(setq widget-browse-fb-history nil) - -(defun widget-fb-button-action (widget &ignore) - (let* ((num (widget-get widget :history-number)) - (rec (nth num widget-browse-fb-history)) - (fun (nth 0 rec)) - (val (nth 1 rec)) - (loc (nth 2 rec))) - ;;(message "fun=%s, val=%s, loc=%s" fun val loc)(sit-for 4) - (funcall fun num))) - -(defun widget-insert-fb-buttons (current-number) - ;;(message "current-number=%s" current-number)(sit-for 2) - (if (<= 0 (1- current-number)) - (widget-create 'push-button - :action 'widget-fb-button-action - :history-number (1- current-number) - :format "%[%v%]" - "back") - (widget-insert (add-string-property "[back]" - 'face 'shadow))) - (widget-insert " ") - (if (< (1+ current-number) (length widget-browse-fb-history)) - (widget-create 'push-button - :action 'widget-fb-button-action - :history-number (1+ current-number) - :format "%[%v%]" - "forward") - (widget-insert (add-string-property "[forward]" - 'face 'shadow))) - (widget-insert "\n")) - -(defun widget-add-fb-history (elt) - (let ((last (car widget-browse-fb-history))) - (unless (equal elt last) - (setq widget-browse-fb-history - (reverse (cons elt - (reverse widget-browse-fb-history))))))) - -(defun widget-browse (widget &optional location) - "Create a widget browser for WIDGET." - (interactive (list (completing-read "Widget: " - obarray - (lambda (symbol) - (get symbol 'widget-type)) - t nil 'widget-browse-history))) - (let (history-number) - (if (integerp widget) - (progn - ;;(message "was integer=%s" widget)(sit-for 2) - (setq history-number widget) - (setq widget (nth 1 (nth widget widget-browse-fb-history)))) - ;;(message "was NOT integer=%s" widget)(sit-for 2) - (widget-add-fb-history (list 'widget-browse widget location)) - (setq history-number (1- (length widget-browse-fb-history)))) - ;;(message "history-number=%s" history-number)(sit-for 2) - - (if (stringp widget) - (setq widget (intern widget))) - (unless (if (symbolp widget) - (get widget 'widget-type) - (and (consp widget) - (get (widget-type widget) 'widget-type))) - (error "Not a widget")) - - ;; Create the buffer. - (if (symbolp widget) - (let ((buffer (format "*Browse %s Widget*" widget))) - (kill-buffer (get-buffer-create buffer)) - (switch-to-buffer (get-buffer-create buffer))) - (kill-buffer (get-buffer-create "*Browse Widget*")) - (switch-to-buffer (get-buffer-create "*Browse Widget*"))) - (widget-browse-mode) - - (make-local-variable 'widget-button-face) - (setq widget-button-face 'link) - (set (make-local-variable 'widget-push-button-prefix) "") - (set (make-local-variable 'widget-push-button-suffix) "") - (set (make-local-variable 'widget-link-prefix) "") - (set (make-local-variable 'widget-link-suffix) "") - - ;; Top text indicating whether it is a class or object browser. - (widget-insert-fb-buttons history-number) - (widget-insert "----------------\n") - (if (listp widget) - (progn - (widget-insert (add-string-property - "Widget object browser" - 'face 'widget-browse-h1)) - (widget-insert "\n\n") - (when location - (let ((b (marker-buffer location)) - (p (marker-position location))) - (widget-insert (add-string-property "Location: " - 'face 'italic)) - (widget-create 'push-button - :tag (format "position %s in buffer %s" p b) - :value (list p b) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos))))) - (widget-insert "\n\n"))) - (widget-insert (add-string-property "Class: " - 'face 'italic))) - (widget-insert (add-string-property "Widget class browser" - 'face 'widget-browse-h1)) - (widget-insert ".\n\n") - (widget-insert (add-string-property "Class: " 'face 'italic)) - (widget-insert (add-string-property (format "%s\n" widget) - 'face '(bold))) - (widget-insert (format "%s" (get widget 'widget-documentation))) - (unless (eq (preceding-char) ?\n) (widget-insert "\n")) - (widget-insert (add-string-property "\nSuper: " 'face 'italic)) - (setq widget (get widget 'widget-type)) - ) - - ;(widget-insert (format "%s\n" widget)) - - ;; Now show the attributes. - (let ((name (car widget)) - (items (cdr widget)) - key value printer) - (if (not name) - (widget-insert "none\n") - (let ((ancestors (list name)) - a - (i1 7) - i - ) - (setq i i1) - (while name - (setq a (intern-soft name)) - (if a - (progn - (setq a (get a 'widget-type)) - (setq name (car a)) - (when (intern-soft name) - (push name ancestors))) - (setq name))) - ;;(widget-insert (format "ancestors=%s\n" ancestors)) - (mapc (lambda (w) - (widget-insert (make-string (if (= i i1) 0 i) ? )) - (widget-create 'widget-browse - :format "%[%v%]" - w) - (widget-insert "\n") - (setq i (+ i 2))) - ancestors))) - (while items - (setq key (nth 0 items) - value (nth 1 items) - printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) - items (cdr (cdr items))) - (widget-insert "\n" - (add-string-property (symbol-name key) - 'face 'italic)) - (when (widget-browse-explained key) - (widget-insert " (") - (widget-create - ;;'push-button - ;;:tag "explain" - ;;:format "%[%v%]" - ;;:button-prefix "" - ;;:button-suffix "" - 'widget-browse-link - :value key - :tag "explain" - :format "%[%t%]" - :action '(lambda (widget &optional event) - (widget-browse-explain - ;;(widget-get widget :value) - (widget-value widget) - )) - ) - (widget-insert ")")) - (widget-insert "\n\t") - (funcall printer widget key value) - (widget-insert "\n"))) - - (widget-insert "\n-----------\n") - (widget-insert-fb-buttons history-number) - - (widget-setup) - (goto-char (point-min)) -;; (when wid-to-history -;; (setq widget-browse-fb-history -;; (reverse (cons (list 'widget-browse wid-to-history location) -;; (reverse widget-browse-fb-history))))) - )) - -(defun widget-browse-at (pos) - "Browse the widget under point." - (interactive "d") - (let ((mp pos) - (b (if (markerp pos) (marker-buffer pos) - (current-buffer)))) - (if (not (buffer-live-p b)) - (message "Sorry the markers buffer is gone") - (with-current-buffer b - (when (markerp pos) - (setq pos (marker-position pos))) - (let* ((field (get-char-property pos 'field)) - (button (get-char-property pos 'button)) - (doc (get-char-property pos 'widget-doc)) - (text (cond (field "This is an editable text area.") - (button "This is an active area.") - (doc "This is documentation text.") - (t "This is unidentified text."))) - (widget (or field button doc))) - (when widget - (widget-browse widget mp)) - (message text)))))) - -(defun button-at (pos) - "Return the button at marker or position POS, or nil. -If not a marker use the current buffer." - (with-current-buffer (if (markerp pos) (marker-buffer pos) - (current-buffer)) - (when (markerp pos) - (setq pos (marker-position pos))) - (let ((button (get-char-property pos 'button))) - (if (or (overlayp button) (null button)) - button - ;; Must be a text-property button; return a marker pointing to it. - (copy-marker pos t))))) - -(defun button-browse-at (pos) - (interactive "d") - (let ((b (if (markerp pos) (marker-buffer pos) - (current-buffer)))) - (if (not (buffer-live-p b)) - (message "Sorry the button's buffer is gone") - (button-browse (button-at pos))))) - -(defun button-browse (button) - "Create a widget browser for WIDGET." - (interactive (list (completing-read "Button: " - obarray - (lambda (symbol) - (or (get symbol 'button-category-symbol) - (get symbol 'supertype))) - t nil 'button-browse-history))) - (let (history-number) - (if (integerp button) - (progn - (setq history-number button) - (setq button (nth 1 (nth button widget-browse-fb-history)))) - (widget-add-fb-history (list 'button-browse button)) - (setq history-number (1- (length widget-browse-fb-history)))) - - (when (stringp button) - (setq button (intern-soft button))) - (when (symbolp button) - (unless (and button - (or (eq button 'default-button) - (get button 'supertype) - (get button 'button-category-symbol) - (save-match-data - (string-match "-button$" (symbol-name button))))) - (error "Not a button"))) - ;; Create the buffer. - (kill-buffer (get-buffer-create "*Browse Button*")) - (switch-to-buffer (get-buffer-create "*Browse Button*")) - (widget-browse-mode) - - (make-local-variable 'widget-button-face) - (setq widget-button-face 'link) - - (widget-insert-fb-buttons history-number) - (widget-insert "----------------\n") - - ;; Top text indicating whether it is a class or object browser. - (if (or (overlayp button) - (markerp button)) - (progn - (widget-insert (add-string-property "Button object browser" - 'face 'widget-browse-h1)) - (widget-insert "\n\n") - (let ((b (if (markerp button) - (marker-buffer button) - (overlay-buffer button))) - (p (if (markerp button) - (marker-position button) - (overlay-start button)))) - (widget-insert (add-string-property "Location: " - 'face 'italic)) - (widget-create 'push-button - :tag (format "position %s in buffer %s" p b) - :value (list p b) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos))))) - (widget-insert "\n\n"))) - (widget-insert (add-string-property "Button class browser" - 'face 'widget-browse-h1)) - (widget-insert "\n\n") - (widget-insert (add-string-property "Type: " - 'face 'italic)) - (widget-insert (add-string-property (symbol-name button) - 'face 'bold)) - (widget-insert "\n")) - - ;; Now show the attributes. - (let ( - (items - (if (symbolp button) - (if (get button 'button-category-symbol) - (symbol-plist (get button 'button-category-symbol)) - (symbol-plist button)) - (if (markerp button) - (let ((pos (marker-position button)) - (buf (marker-buffer button))) - (text-properties-at pos buf)) - (overlay-properties button)))) - rest-items - name - key value printer) - ;;(insert (format "\n%s\n\n" items)) - (let ((copied-items (copy-seq items))) - (while copied-items - (setq key (nth 0 copied-items) - value (nth 1 copied-items) - copied-items (cdr (cdr copied-items))) - (if (eq key 'category) - (setq name value) - (if (eq key 'supertype) - (setq name (make-symbol (concat (symbol-name value) "-button"))) - (push value rest-items) - (push key rest-items))))) - ;;(insert "\nname=" (symbol-name value) "\n\n") - (when name - (widget-insert (add-string-property - (if (symbolp button) - (if (get button 'supertype) - "Supertype: " - "") - "Category: ") - 'face 'italic)) - (let* (a - (ancestors - (list name)) - (i1 11) - (i i1)) - (while name - (setq a (or (get name 'supertype) - (get name :supertype))) - ;;(message "name=%s, a=%s\n name plist=%s" name a (symbol-plist name));(sit-for 4) - (if (or (not a) - (eq a 'default-button)) - (setq name) - (setq name (make-symbol (concat (symbol-name a) "-button"))) - (setq ancestors (cons name ancestors)))) - ;;(message "ancestors=%s" ancestors)(sit-for 2) - (mapc (lambda (w) - (widget-insert (make-string (if (= i i1) 0 i) ? )) - (widget-create 'button-browse - :format "%[%v%]" - w) - (widget-insert "\n") - (setq i (+ i 2))) - ancestors))) - (while rest-items - (setq key (nth 0 rest-items) - value (nth 1 rest-items) - printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) - rest-items (cdr (cdr rest-items))) - (widget-insert "\n" - (add-string-property (symbol-name key) - 'face 'italic)) - (when (widget-browse-explained key) - (widget-insert " (") - (widget-create 'push-button - :tag "explain" - :value key - :action '(lambda (widget &optional event) - (widget-browse-explain - (widget-get widget :value)))) - (widget-insert ")")) - (widget-insert "\n\t") - (funcall printer button key value) - (widget-insert "\n"))) - (widget-setup) - (goto-char (point-min)) - -;; (when button-to-history -;; (setq widget-browse-fb-history -;; (reverse (cons (list 'button-browse button-to-history) -;; (reverse widget-browse-fb-history))))) - )) - - -;;;###autoload -(defgroup whelp nil - "Customization group for whelp." - :group 'emacs) - -(defface widget-browse-h1 - '((t (:weight bold :height 1.5))) - "Face for top header in widget/button browse buffers." - :group 'whelp) - -(defun add-string-property (str prop val) - (let ((s (copy-seq str))) - (put-text-property 0 (length s) - prop val - s) - s)) - -;;; The `button-browse' Widget. - -(define-widget 'button-browse 'push-button - "Widget button for creating a button browser. -The :value of the widget shuld be the button to be browsed." - :format "%[[%v]%]" - :value-create 'widget-browse-button-value-create - :action 'widget-browse-button-action) - -(defun widget-browse-button-action (widget &optional event) - ;; Create widget browser for WIDGET's :value. - (button-browse (widget-get widget :value))) - -(defun widget-browse-button-value-create (widget) - ;; Insert type name. - (let ((value (widget-get widget :value))) - (cond ((symbolp value) - (insert (symbol-name value))) - ((consp value) - (insert (symbol-name (widget-type value)))) - (t - (insert "strange"))))) - - -(defun widget-browse-explained (property) - (memq property - '( - :created-in-function - ))) - -(defun widget-browse-explain (property) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'widget-browse-explain property) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((inhibit-read-only t)) - (cond - ( (eq property :created-in-function) - (princ "Property :created-in-function tells where a field object or class is created.") - ) - ( t - (princ (format "No explanation found for %s" property)) - ) - ) - (with-no-warnings (print-help-return-message)))))) - -(provide 'whelp) -- cgit v1.2.3-54-g00ecf