Re: Feature freeze

[David Engster <deng@randomsample.de>]

[-- Attachment #1: Type: text/plain, Size: 811 bytes --]

Stefan Monnier writes:
>> I got sidetracked at that time, but I'm currently working it. The
>> essential functionality won't change, though: the main work is done in
>> eieio.el and eieio-opt.el. The only things that get's added to
>> help-fns.el is the new `help-fns-describe-function-functions' hook.
>> Would it be OK to apply it in the coming days?
>
> I remember discussions around that, yes.  Send us the patch and we'll
> see if that can be installed.

Much to my surprise I didn't get much done over the holidays, but
anyway, here it is.

The patch looks large, but as you can see, most of the stuff is just for
displaying the class/constructor/slot descriptions. The real core of the
patch is, as I've written above, the new hook in help-fns.el.

Is it OK to install, or will it have to wait?

-David


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: eieio-help-fns-patch.diff --]
[-- Type: text/x-diff, Size: 16935 bytes --]

=== modified file 'lisp/emacs-lisp/eieio-opt.el'
--- lisp/emacs-lisp/eieio-opt.el	2014-01-01 07:43:34 +0000
+++ lisp/emacs-lisp/eieio-opt.el	2014-01-06 21:32:16 +0000
@@ -77,101 +77,76 @@
 ;;;###autoload(defalias 'describe-class 'eieio-describe-class)
 
 ;;;###autoload
-(defun eieio-describe-class (class &optional headerfcn)
+(defun eieio-describe-class (class)
   "Describe a CLASS defined by a string or symbol.
-If CLASS is actually an object, then also display current values of that object.
-Optional HEADERFCN should be called to insert a few bits of info first."
-  (interactive (list (eieio-read-class "Class: ")))
-  (with-output-to-temp-buffer (help-buffer) ;"*Help*"
-    (help-setup-xref (list #'eieio-describe-class class headerfcn)
-		     (called-interactively-p 'interactive))
-
-    (when headerfcn (funcall headerfcn))
-    (prin1 class)
-    (princ " is a")
-    (if (class-option class :abstract)
-	(princ "n abstract"))
-    (princ " class")
-    ;; Print file location
-    (when (get class 'class-location)
-      (princ " in `")
-      (princ (file-name-nondirectory (get class 'class-location)))
-      (princ "'"))
-    (terpri)
-    ;; Inheritance tree information
-    (let ((pl (eieio-class-parents class)))
-      (when pl
-	(princ " Inherits from ")
-	(while pl
-	  (princ "`") (prin1 (car pl)) (princ "'")
-	  (setq pl (cdr pl))
-	  (if pl (princ ", ")))
-	(terpri)))
-    (let ((ch (eieio-class-children class)))
-      (when ch
-	(princ " Children ")
-	(while ch
-	  (princ "`") (prin1 (car ch)) (princ "'")
-	  (setq ch (cdr ch))
-	  (if ch (princ ", ")))
-	(terpri)))
-    (terpri)
-    ;; System documentation
-    (let ((doc (documentation-property class 'variable-documentation)))
-      (when doc
-	(princ "Documentation:")
-	(terpri)
-	(princ doc)
-	(terpri)
-	(terpri)))
-    ;; Describe all the slots in this class
-    (eieio-describe-class-slots class)
-    ;; Describe all the methods specific to this class.
-    (let ((methods (eieio-all-generic-functions class))
-	  (doc nil))
-      (if (not methods) nil
-	(princ "Specialized Methods:")
-	(terpri)
-	(terpri)
-	(while methods
-	  (setq doc (eieio-method-documentation (car methods) class))
-	  (princ "`")
-	  (prin1 (car methods))
-	  (princ "'")
-	  (if (not doc)
-	      (princ "  Undocumented")
-	    (if (car doc)
-		(progn
-		  (princ "  :STATIC ")
-		  (prin1 (car (car doc)))
-		  (terpri)
-		  (princ (cdr (car doc)))))
-	    (setq doc (cdr doc))
-	    (if (car doc)
-		(progn
-		  (princ "  :BEFORE ")
-		  (prin1 (car (car doc)))
-		  (terpri)
-		  (princ (cdr (car doc)))))
-	    (setq doc (cdr doc))
-	    (if (car doc)
-		(progn
-		  (princ "  :PRIMARY ")
-		  (prin1 (car (car doc)))
-		  (terpri)
-		  (princ (cdr (car doc)))))
-	    (setq doc (cdr doc))
-	    (if (car doc)
-		(progn
-		  (princ "  :AFTER ")
-		  (prin1 (car (car doc)))
-		  (terpri)
-		  (princ (cdr (car doc)))))
-	    (terpri)
-	    (terpri))
-	  (setq methods (cdr methods))))))
-  (with-current-buffer (help-buffer)
-    (buffer-string)))
+If CLASS is actually an object, then also display current values of that object."
+  ;; Header line
+  (prin1 class)
+  (insert " is a"
+	  (if (class-option class :abstract)
+	      "n abstract"
+	    "")
+	  " class")
+  (let ((location (get class 'class-location)))
+    (when location
+      (insert " in `")
+      (help-insert-xref-button
+       (file-name-nondirectory location)
+       'eieio-class-def class location)
+      (insert "'")))
+  (insert ".\n")
+  ;; Parents
+  (let ((pl (eieio-class-parents class))
+	cur)
+    (when pl
+      (insert " Inherits from ")
+      (while (setq cur (pop pl))
+	(insert "`")
+	(help-insert-xref-button (symbol-name cur)
+				 'help-function cur)
+	(insert (if pl "', " "'")))
+      (insert ".\n")))
+  ;; Children
+  (let ((ch (eieio-class-children class))
+	cur)
+    (when ch
+      (insert " Children ")
+      (while (setq cur (pop ch))
+	(insert "`")
+	(help-insert-xref-button (symbol-name cur)
+				 'help-function cur)
+	(insert (if ch "', " "'")))
+      (insert ".\n")))
+  ;; System documentation
+  (let ((doc (documentation-property class 'variable-documentation)))
+    (when doc
+      (insert "\n" doc "\n\n")))
+  ;; Describe all the slots in this class
+  (eieio-describe-class-slots class)
+  ;; Describe all the methods specific to this class.
+  (let ((methods (eieio-all-generic-functions class))
+	(type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"])
+	counter doc argshl dochl)
+    (when methods
+      (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
+      (while methods
+	(setq doc (eieio-method-documentation (car methods) class))
+	(insert "`")
+	(help-insert-xref-button (symbol-name (car methods))
+				 'help-function (car methods))
+	(insert "'")
+	(if (not doc)
+	    (insert "  Undocumented")
+	  (setq counter 0)
+	  (dolist (cur doc)
+	    (when cur
+	      (insert " " (aref type counter) " "
+		      (prin1-to-string (car cur) (current-buffer))
+		      "\n"
+		      (cdr cur)))
+	    (setq counter (1+ counter))))
+	(insert "\n\n")
+	(setq methods (cdr methods))))))
 
 (defun eieio-describe-class-slots (class)
   "Describe the slots in CLASS.
@@ -185,28 +160,27 @@
 	 (i      0)
 	 (prot   (eieio--class-protection cv))
 	 )
-    (princ "Instance Allocated Slots:")
-    (terpri)
-    (terpri)
+    (insert (propertize "Instance Allocated Slots:\n\n"
+			'face 'bold))
     (while names
-      (if (car prot) (princ "Private "))
-      (princ "Slot: ")
-      (prin1 (car names))
-      (when (not (eq (aref types i) t))
-	(princ "    type = ")
-	(prin1 (aref types i)))
-      (unless (eq (car deflt) eieio-unbound)
-	(princ "    default = ")
-	(prin1 (car deflt)))
-      (when (car publp)
-	(princ "    printer = ")
-	(prin1 (car publp)))
-      (when (car docs)
-	(terpri)
-	(princ "  ")
-	(princ (car docs))
-	(terpri))
-      (terpri)
+      (insert
+       (concat
+	(when (car prot)
+	  (propertize "Private " 'face 'bold))
+	(propertize "Slot: " 'face 'bold)
+	(prin1-to-string (car names))
+	(unless (eq (aref types i) t)
+	  (concat "    type = "
+		  (prin1-to-string (aref types i))))
+	(unless (eq (car deflt) eieio-unbound)
+	  (concat "    default = "
+		  (prin1-to-string (car deflt))))
+	(when (car publp)
+	  (concat "    printer = "
+		  (prin1-to-string (car publp))))
+	(when (car docs)
+	  (concat "\n  " (car docs) "\n"))
+	"\n"))
       (setq names (cdr names)
 	    docs (cdr docs)
 	    deflt (cdr deflt)
@@ -219,61 +193,30 @@
 	  i     0
 	  prot  (eieio--class-class-allocation-protection cv))
     (when names
-	(terpri)
-	(princ "Class Allocated Slots:"))
-	(terpri)
-	(terpri)
+      (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
     (while names
-      (when (car prot)
-	(princ "Private "))
-      (princ "Slot: ")
-      (prin1 (car names))
-      (unless (eq (aref types i) t)
-	(princ "    type = ")
-	(prin1 (aref types i)))
-      (condition-case nil
-	  (let ((value (eieio-oref class (car names))))
-	    (princ "   value = ")
-	    (prin1 value))
+      (insert
+       (concat
+	(when (car prot)
+	  "Private ")
+	"Slot: "
+	(prin1-to-string (car names))
+	(unless (eq (aref types i) t)
+	  (concat "    type = "
+		  (prin1-to-string (aref types i))))
+	(condition-case nil
+	    (let ((value (eieio-oref class (car names))))
+	      (concat "   value = "
+		      (prin1-to-string value)))
 	  (error nil))
-      (when (car docs)
-	(terpri)
-	(princ "  ")
-	(princ (car docs))
-	(terpri))
-      (terpri)
+	(when (car docs)
+	  (concat "\n\n " (car docs) "\n"))
+	"\n"))
       (setq names (cdr names)
 	    docs (cdr docs)
 	    prot (cdr prot)
 	    i (1+ i)))))
 
-;;;###autoload
-(defun eieio-describe-constructor (fcn)
-  "Describe the constructor function FCN.
-Uses `eieio-describe-class' to describe the class being constructed."
-  (interactive
-   ;; Use eieio-read-class since all constructors have the same name as
-   ;; the class they create.
-   (list (eieio-read-class "Class: ")))
-  (eieio-describe-class
-   fcn (lambda ()
-	 ;; Describe the constructor part.
-	 (prin1 fcn)
-	 (princ " is an object constructor function")
-	 ;; Print file location
-	 (when (get fcn 'class-location)
-	   (princ " in `")
-	   (princ (file-name-nondirectory (get fcn 'class-location)))
-	   (princ "'"))
-	 (terpri)
-	 (princ "Creates an object of class ")
-	 (prin1 fcn)
-	 (princ ".")
-	 (terpri)
-	 (terpri)
-	 ))
-  )
-
 (defun eieio-build-class-list (class)
   "Return a list of all classes that inherit from CLASS."
   (if (class-p class)
@@ -330,87 +273,99 @@
 ;;;###autoload(defalias 'describe-generic 'eieio-describe-generic)
 (defalias 'eieio-describe-method 'eieio-describe-generic)
 
-;;;###autoload
-(defun eieio-describe-generic (generic)
-  "Describe the generic function GENERIC.
-Also extracts information about all methods specific to this generic."
-  (interactive (list (eieio-read-generic "Generic Method: ")))
-  (eieio--check-type generic-p generic)
-  (with-output-to-temp-buffer (help-buffer) ; "*Help*"
-    (help-setup-xref (list #'eieio-describe-generic generic)
-		     (called-interactively-p 'interactive))
-
-    (prin1 generic)
-    (princ " is a generic function")
-    (when (generic-primary-only-p generic)
-      (princ " with only ")
-      (when (generic-primary-only-one-p generic)
-	(princ "one "))
-      (princ "primary method")
-      (when (not (generic-primary-only-one-p generic))
-	(princ "s"))
-      )
-    (princ ".")
-    (terpri)
-    (terpri)
-    (let ((d (documentation generic)))
-      (if (not d)
-	  (princ "The generic is not documented.\n")
-	(princ "Documentation:")
-	(terpri)
-	(princ d)
-	(terpri)
-	(terpri)))
-    (princ "Implementations:")
-    (terpri)
-    (terpri)
-    (let ((i 4)
-	  (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
-      ;; Loop over fanciful generics
-      (while (< i 7)
-	(let ((gm (aref (get generic 'eieio-method-tree) i)))
-	  (when gm
-	    (princ "Generic ")
-	    (princ (aref prefix (- i 3)))
-	    (terpri)
-	    (princ (or (nth 2 gm) "Undocumented"))
-	    (terpri)
-	    (terpri)))
-	(setq i (1+ i)))
-      (setq i 0)
-      ;; Loop over defined class-specific methods
-      (while (< i 4)
-	(let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
-	      location)
-	  (while gm
-	    (princ "`")
-	    (prin1 (car (car gm)))
-	    (princ "'")
-	    ;; prefix type
-	    (princ " ")
-	    (princ (aref prefix i))
-	    (princ " ")
-	    ;; argument list
-	    (let* ((func (cdr (car gm)))
-		   (arglst (eieio-lambda-arglist func)))
-	      (prin1 arglst))
-	    (terpri)
-	    ;; 3 because of cdr
-	    (princ (or (documentation (cdr (car gm)))
-		       "Undocumented"))
-	    ;; Print file location if available
-	    (when (and (setq location (get generic 'method-locations))
-		       (setq location (assoc (caar gm) location)))
-	      (setq location (cadr location))
-	      (princ "\n\nDefined in `")
-	      (princ (file-name-nondirectory location))
-	      (princ "'\n"))
-	    (setq gm (cdr gm))
-	    (terpri)
-	    (terpri)))
-	(setq i (1+ i)))))
-  (with-current-buffer (help-buffer)
-    (buffer-string)))
+(define-button-type 'eieio-method-def
+  :supertype 'help-xref
+  'help-function (lambda (class method file)
+		   (eieio-help-find-method-definition class method file))
+  'help-echo (purecopy "mouse-2, RET: find method's definition"))
+
+(define-button-type 'eieio-class-def
+  :supertype 'help-xref
+  'help-function (lambda (class file)
+		   (eieio-help-find-class-definition class file))
+  'help-echo (purecopy "mouse-2, RET: find class definition"))
+
+;;;###autoload
+(defun eieio-help-constructor (ctr)
+  "Describe CTR if it is a class constructor."
+  (when (class-p ctr)
+    (let ((location (get ctr 'class-location)))
+      (goto-char (point-min))
+      (delete-region (point) (point-at-eol))
+      (prin1 ctr)
+      (insert " is an object constructor function in `")
+      (help-insert-xref-button
+       (file-name-nondirectory location)
+       'eieio-class-def ctr location)
+      (insert "'.\nCreates an object of class " (symbol-name ctr) ".")
+      (goto-char (point-max))
+      (save-excursion
+	(insert (propertize "\n\nClass description:\n" 'face 'bold))
+	(eieio-describe-class ctr))
+      )))
+
+
+;;;###autoload
+(defun eieio-help-generic (generic)
+  "Describe GENERIC if it is a generic function."
+  (when (generic-p generic)
+    (save-excursion
+      (goto-char (point-min))
+      (when (re-search-forward " in `.+'.$" nil t)
+	(replace-match ".")))
+    (save-excursion
+      (insert "\n\nThis is a generic function"
+	      (cond
+	       ((and (generic-primary-only-p generic)
+		     (generic-primary-only-one-p generic))
+		" with only one primary method")
+	       ((generic-primary-only-p generic)
+		" with only primary methods")
+	       (t ""))
+	      ".\n\n")
+      (insert (propertize "Implementations:\n\n" 'face 'bold))
+      (let ((i 4)
+	    (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
+	;; Loop over fanciful generics
+	(while (< i 7)
+	  (let ((gm (aref (get generic 'eieio-method-tree) i)))
+	    (when gm
+	      (insert "Generic "
+		      (aref prefix (- i 3))
+		      "\n"
+		      (or (nth 2 gm) "Undocumented")
+		      "\n\n")))
+	  (setq i (1+ i)))
+	(setq i 0)
+	;; Loop over defined class-specific methods
+	(while (< i 4)
+	  (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
+		 cname location)
+	    (while gm
+	      (setq cname (caar gm))
+	      (insert "`")
+	      (help-insert-xref-button (symbol-name cname)
+				       'help-variable cname)
+	      (insert "' " (aref prefix i) " ")
+	      ;; argument list
+	      (let* ((func (cdr (car gm)))
+		     (arglst (eieio-lambda-arglist func)))
+		(prin1 arglst (current-buffer)))
+	      (insert "\n"
+		      (or (documentation (cdr (car gm)))
+			  "Undocumented"))
+	      ;; Print file location if available
+	      (when (and (setq location (get generic 'method-locations))
+			 (setq location (assoc cname location)))
+		(setq location (cadr location))
+		(insert "\n\nDefined in `")
+		(help-insert-xref-button
+		 (file-name-nondirectory location)
+		 'eieio-method-def cname generic location)
+		(insert "'\n"))
+	      (setq gm (cdr gm))
+	      (insert "\n")))
+	  (setq i (1+ i)))))))
 
 (defun eieio-lambda-arglist (func)
   "Return the argument list of FUNC, a function body."
@@ -584,21 +539,13 @@
 
 ;;; HELP AUGMENTATION
 ;;
-(define-button-type 'eieio-method-def
-  :supertype 'help-xref
-  'help-function (lambda (class method file)
-		   (eieio-help-find-method-definition class method file))
-  'help-echo (purecopy "mouse-2, RET: find method's definition"))
-
-(define-button-type 'eieio-class-def
-  :supertype 'help-xref
-  'help-function (lambda (class file)
-		   (eieio-help-find-class-definition class file))
-  'help-echo (purecopy "mouse-2, RET: find class definition"))
-
 (defun eieio-help-find-method-definition (class method file)
   (let ((filename (find-library-name file))
 	location buf)
+    (when (symbolp class)
+      (setq class (symbol-name class)))
+    (when (symbolp method)
+      (setq method (symbol-name method)))
     (when (null filename)
       (error "Cannot find library %s" file))
     (setq buf (find-file-noselect filename))
@@ -622,6 +569,8 @@
       (beginning-of-line))))
 
 (defun eieio-help-find-class-definition (class file)
+  (when (symbolp class)
+    (setq class (symbol-name class)))
   (let ((filename (find-library-name file))
 	location buf)
     (when (null filename)

=== modified file 'lisp/emacs-lisp/eieio.el'
--- lisp/emacs-lisp/eieio.el	2014-01-01 07:43:34 +0000
+++ lisp/emacs-lisp/eieio.el	2014-01-04 09:04:08 +0000
@@ -865,6 +865,10 @@
 of `eq'."
   (error "EIEIO: `change-class' is unimplemented"))
 
+;; Hook ourselves into help system for describing classes and methods.
+(add-hook 'help-fns-describe-function-functions 'eieio-help-generic)
+(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor)
+
 ;;; Interfacing with edebug
 ;;
 (defun eieio-edebug-prin1-to-string (object &optional noescape)

=== modified file 'lisp/help-fns.el'
--- lisp/help-fns.el	2014-01-01 07:43:34 +0000
+++ lisp/help-fns.el	2014-01-04 09:04:08 +0000
@@ -32,6 +32,12 @@
 
 ;;; Code:
 
+(defvar help-fns-describe-function-functions nil
+  "List of functions to run in help buffer in `describe-function'.
+Those functions will be run after the header line and argument
+list was inserted, and before the documentation will be inserted.
+The functions will receive the function name as argument.")
+
 ;; Functions
 
 ;;;###autoload
@@ -653,7 +659,7 @@
           (help-fns--compiler-macro function)
           (help-fns--parent-mode function)
           (help-fns--obsolete function)
-
+	  (run-hook-with-args 'help-fns-describe-function-functions function)
           (insert "\n"
                   (or doc "Not documented.")))))))