From 94d2fc1815a919734353c942f224db1de4b4fcb8 Mon Sep 17 00:00:00 2001 From: Tom Willemsen Date: Mon, 7 Mar 2011 09:04:49 +0100 Subject: Django, org * Added nxhtml, mostly for django support. * Changed some org settings. --- emacs.d/nxhtml/util/whelp.el | 988 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 988 insertions(+) create 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 new file mode 100644 index 0000000..77b8149 --- /dev/null +++ b/emacs.d/nxhtml/util/whelp.el @@ -0,0 +1,988 @@ +;; 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