scratch/oclosure a7a19617fb 2/2: oclosure.el: Add docstrings and interactive forms

[Stefan Monnier]

branch: scratch/oclosure
commit a7a19617fbd8947c28660f71296dd362fb1e435c
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    oclosure.el: Add docstrings and interactive forms
    
    Use anonymous classes to add support for docstrings
    and interactive forms to OClosures.
    
    * lisp/simple.el (function-docstring, interactive-form): New methods
    for `oclosure-documented` and `oclosure-command`.
    
    * lisp/emacs-lisp/oclosure.el (oclosure-lambda): Convert docstrings and
    interactive specs in the body into OClosure slots of `oclosure-documented`
    and `oclosure-command`.
    (oclosure-documented, oclosure-command): New types.
    
    * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-anonymous):
    Add tests.
---
 lisp/emacs-lisp/oclosure.el            | 30 ++++++++++++++++++++++++++----
 lisp/simple.el                         |  7 +++++++
 test/lisp/emacs-lisp/oclosure-tests.el | 17 +++++++++++++++--
 3 files changed, 48 insertions(+), 6 deletions(-)

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 1efaf207bb..861afbec15 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -32,14 +32,11 @@
 ;; - OClosure accessor functions, where the type-dispatch is used to
 ;;   dynamically compute the docstring, and also to pretty them.
 ;; Here are other cases of "callable objects" where OClosures could be used:
+;; - Use the type to distinguish macros from functions.
 ;; - iterators (generator.el), thunks (thunk.el), streams (stream.el).
 ;; - PEG rules: they're currently just functions, but they should carry
 ;;   their original (macro-expanded) definition (and should be printed
 ;;   differently from functions)!
-;; - documented functions: this could be a subtype of normal functions, which
-;;   simply has an additional `docstring' slot.
-;; - commands: this could be a subtype of documented functions, which simply
-;;   has an additional `interactive-form' slot.
 ;; - auto-generate docstrings for cl-defstruct slot accessors instead of
 ;;   storing them in the accessor itself?
 ;; - SRFI-17's `setter'.
@@ -115,6 +112,7 @@
 ;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'?
 ;; - Use accessor in cl-defstruct.
 ;; - Add pcase patterns for OClosures.
+;; - anonymous OClosure types.
 ;; - copiers for mixins
 ;; - class-allocated slots?
 ;; - code-allocated slots?
@@ -476,6 +474,21 @@ ARGS and BODY are the same as for `lambda'."
                 (if (listp (car fields))
                     (nreverse types)
                   (loop (cons (pop fields) types)))))
+       (_ (when (or (and (stringp (car-safe body)) (cdr body))
+                    (eq :documentation (car-safe (car-safe body))))
+            (let ((doc (pop body)))
+              (if (eq :documentation (car-safe doc))
+                  (setq doc (cadr doc)))
+              (setq types (nconc types (list 'oclosure-documented)))
+              (setq fields (append fields `((docstring ,doc)))))))
+       (_ (when (assq 'interactive body)
+            (let ((spec (assq 'interactive body)))
+              (setq body (remq spec body))
+              (setq types (nconc types (list 'oclosure-command)))
+              (setq fields (append fields `((interactive-form
+                                             ,(if (cddr spec)
+                                                  (vconcat (cdr spec))
+                                                (cadr spec)))))))))
        (type-exp (if (null (cdr types))
                      `',(car types)
                    `(oclosure--anonymous-define
@@ -651,5 +664,14 @@ ARGS and BODY are the same as for `lambda'."
     (oclosure--set val oclosure
                    (oclosure--mixin-slot-index oclosure slot))))
 
+;; These need to come after we define the mixin accessors.
+(oclosure-define (oclosure-documented (:mixin t)) docstring)
+(oclosure-define (oclosure-command
+                  (:mixin t)
+                  ;; Not indispensable, but since by convention all
+                  ;; commands should be documented, we might as well.
+                  (:parent oclosure-documented))
+  interactive-form)
+
 (provide 'oclosure)
 ;;; oclosure.el ends here
diff --git a/lisp/simple.el b/lisp/simple.el
index 70ac5620b5..d44f90adcb 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2352,6 +2352,10 @@ FUNCTION is expected to be a function value rather than, 
say, a mere symbol."
   ;; FIXME: η-reduce!
   (oclosure--accessor-docstring function))
 
+(cl-defmethod function-docstring ((function oclosure-documented))
+  ;; FIXME: η-reduce!
+  (oclosure-documented--docstring function))
+
 (cl-defgeneric interactive-form (cmd &optional original-name)
   "Return the interactive form of CMD or nil if none.
 If CMD is not a command, the return value is nil.
@@ -2384,6 +2388,9 @@ ORIGINAL-NAME is used internally only."
          spec)))
     (_ (internal--interactive-form cmd))))
 
+(cl-defmethod interactive-form ((cmd oclosure-command) &optional 
_original-name)
+  (list 'interactive (oclosure-command--interactive-form cmd)))
+
 (defun command-execute (cmd &optional record-flag keys special)
   ;; BEWARE: Called directly from the C code.
   "Execute CMD as an editor command.
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el 
b/test/lisp/emacs-lisp/oclosure-tests.el
index 243921a734..95ad76ffb7 100644
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -189,7 +189,12 @@
                                 (fst 'fst) (snd 'snd)
                                 (a 'a))
                   (x)
-                (list x fst))))
+                (list x fst)))
+        (ocl2 (oclosure-lambda (oclosure-test (fst 'fst) (snd 'snd))
+                  (x)
+                "Doc"
+                (interactive "P")
+                (list x snd))))
 
     (should (equal (oclosure-test-mixin1--a ocl1)
                    'a))
@@ -198,6 +203,14 @@
     (should (equal (funcall ocl1 'x) '(x fst)))
     (should (cl-typep ocl1 'oclosure-test))
     (should (cl-typep ocl1 'oclosure-test-mixin1))
-    (should (cl-typep ocl1 '(and oclosure-test oclosure-test-mixin1)))))
+    (should (cl-typep ocl1 '(and oclosure-test oclosure-test-mixin1)))
+
+    (should (cl-typep ocl2 '(and oclosure-command oclosure-documented)))
+    (should (equal (interactive-form ocl2) '(interactive "P")))
+    (should (commandp ocl2))
+    (should (equal (let ((current-prefix-arg 'pfx))
+                     (call-interactively ocl2))
+                   '(pfx snd)))
+    (should (equal "Doc" (documentation ocl2)))))
 
 ;;; oclosure-tests.el ends here.