Add new cl-struct' and eieio' pcase patterns.

* lisp/emacs-lisp/cl-macs.el (cl-struct): New pcase pattern.
* lisp/emacs-lisp/eieio.el (eieio-pcase-slot-index-table)
(eieio-pcase-slot-index-from-index-table): New functions.
(eieio): New pcase pattern.
* lisp/emacs-lisp/pcase.el (pcase--make-docstring): New function.
(pcase): Use it to build the docstring.
(pcase-defmacro): Make sure the macro is lazy-loaded.
(\`): Move its docstring from `pcase'.

etc/NEWS

@@ -346,7 +346,7 @@ invalid certificates are marked in red.
 transformed into multipart/related messages before sending.
 
 ** pcase
-*** New UPatterns `quote' and `app'.
+*** New UPatterns `quote', `app', `cl-struct', and `eieio'.
 *** New UPatterns can be defined with `pcase-defmacro'.
 +++
 *** New vector QPattern.

lisp/ChangeLog

@@ -1,3 +1,15 @@
+2015-03-23  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	Add new `cl-struct' and `eieio' pcase patterns.
+	* emacs-lisp/cl-macs.el (cl-struct): New pcase pattern.
+	* emacs-lisp/eieio.el (eieio-pcase-slot-index-table)
+	(eieio-pcase-slot-index-from-index-table): New functions.
+	(eieio): New pcase pattern.
+	* emacs-lisp/pcase.el (pcase--make-docstring): New function.
+	(pcase): Use it to build the docstring.
+	(pcase-defmacro): Make sure the macro is lazy-loaded.
+	(\`): Move its docstring from `pcase'.
+
 2015-03-23  Glenn Morris  <rgm@gnu.org>
 
 	* emacs-lisp/authors.el (authors-aliases)

lisp/emacs-lisp/cl-lib.el

@@ -629,7 +629,6 @@ the process stops as soon as KEYS or VALUES run out.
 If ALIST is non-nil, the new pairs are prepended to it."
   (nconc (cl-mapcar 'cons keys values) alist))
 
-
 ;;; Generalized variables.
 
 ;; These used to be in cl-macs.el since all macros that use them (like setf)

lisp/emacs-lisp/cl-macs.el

@@ -2768,6 +2768,28 @@ non-nil value, that slot cannot be set via `setf'.
                            ',print-auto))
        ',name)))
 
+;;; Add cl-struct support to pcase
+
+;;;###autoload
+(pcase-defmacro cl-struct (type &rest fields)
+  "Pcase patterns to match cl-structs.
+Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
+field NAME is matched against UPAT, or they can be of the form NAME which
+is a shorthand for (NAME NAME)."
+  ;; FIXME: This works well for a destructuring pcase-let, but for straight
+  ;; pcase, it suffers seriously from a lack of support for cl-typep in
+  ;; pcase--mutually-exclusive-p.
+  `(and (pred (pcase--swap cl-typep ',type))
+        ,@(mapcar
+           (lambda (field)
+             (let* ((name (if (consp field) (car field) field))
+                    (pat (if (consp field) (cadr field) field)))
+               `(app ,(if (eq (cl-struct-sequence-type type) 'list)
+                          `(nth ,(cl-struct-slot-offset type name))
+                        `(pcase--flip aref ,(cl-struct-slot-offset type name)))
+                     ,pat)))
+           fields)))
+
 (defun cl-struct-sequence-type (struct-type)
   "Return the sequence used to build STRUCT-TYPE.
 STRUCT-TYPE is a symbol naming a struct type.  Return 'vector or

lisp/emacs-lisp/eieio.el

@@ -328,6 +328,44 @@ variable name of the same name as the slot."
                       (list var `(slot-value ,object ',slot))))
                   spec-list)
        ,@body)))
+
+;; Keep it as a non-inlined function, so the internals of object don't get
+;; hard-coded in random .elc files.
+(defun eieio-pcase-slot-index-table (obj)
+  "Return some data structure from which can be extracted the slot offset."
+  (eieio--class-index-table
+   (symbol-value (eieio--object-class-tag obj))))
+
+(defun eieio-pcase-slot-index-from-index-table (index-table slot)
+  "Find the index to pass to `aref' to access SLOT."
+  (let ((index (gethash slot index-table)))
+    (if index (+ (eval-when-compile
+                   (length (cl-struct-slot-info 'eieio--object)))
+                 index))))
+
+(pcase-defmacro eieio (&rest fields)
+  "Pcase patterns to match EIEIO objects.
+Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
+field NAME is matched against UPAT, or they can be of the form NAME which
+is a shorthand for (NAME NAME)."
+  (let ((is (make-symbol "table")))
+    ;; FIXME: This generates a horrendous mess of redundant let bindings.
+    ;; `pcase' needs to be improved somehow to introduce let-bindings more
+    ;; sparingly, or the byte-compiler needs to be taught to optimize
+    ;; them away.
+    ;; FIXME: `pcase' does not do a good job here of sharing tests&code among
+    ;; various branches.
+    `(and (pred eieio-object-p)
+          (app eieio-pcase-slot-index-table ,is)
+          ,@(mapcar (lambda (field)
+                      (let* ((name (if (consp field) (car field) field))
+                             (pat (if (consp field) (cadr field) field))
+                             (i (make-symbol "index")))
+                        `(and (let (and ,i (pred natnump))
+                                (eieio-pcase-slot-index-from-index-table
+                                 ,is ',name))
+                              (app (pcase--flip aref ,i) ,pat))))
+                    fields))))
 
 ;;; Simple generators, and query functions.  None of these would do
 ;;  well embedded into an object.

lisp/emacs-lisp/pcase.el

@@ -103,7 +103,6 @@ UPatterns can take the following forms:
   (or UPAT...)	matches if any of the patterns matches.
   (and UPAT...)	matches if all the patterns match.
   'VAL		matches if the object is `equal' to VAL
-  `QPAT		matches if the QPattern QPAT matches.
   (pred FUN)	matches if FUN applied to the object returns non-nil.
   (guard BOOLEXP)	matches if BOOLEXP evaluates to non-nil.
   (let UPAT EXP)	matches if EXP matches UPAT.
@@ -111,14 +110,6 @@ UPatterns can take the following forms:
 If a SYMBOL is used twice in the same pattern (i.e. the pattern is
 \"non-linear\"), then the second occurrence is turned into an `eq'uality test.
 
-QPatterns can take the following forms:
-  (QPAT1 . QPAT2)       matches if QPAT1 matches the car and QPAT2 the cdr.
-  [QPAT1 QPAT2..QPATn]  matches a vector of length n and QPAT1..QPATn match
-                           its 0..(n-1)th elements, respectively.
-  ,UPAT                 matches if the UPattern UPAT matches.
-  STRING                matches if the object is `equal' to STRING.
-  ATOM                  matches if the object is `eq' to ATOM.
-
 FUN can take the form
   SYMBOL or (lambda ARGS BODY)  in which case it's called with one argument.
   (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
@@ -129,7 +120,10 @@ FUN is assumed to be pure, i.e. it can be dropped if its result is not used,
 and two identical calls can be merged into one.
 E.g. you can match pairs where the cdr is larger than the car with a pattern
 like `(,a . ,(pred (< a))) or, with more checks:
-`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
+`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))
+
+Additional patterns can be defined via `pcase-defmacro'.
+Currently, the following patterns are provided this way:"
   (declare (indent 1) (debug (form &rest (pcase-UPAT body))))
   ;; We want to use a weak hash table as a cache, but the key will unavoidably
   ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
@@ -154,6 +148,26 @@ like `(,a . ,(pred (< a))) or, with more checks:
         ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
         expansion))))
 
+;; FIXME: Obviously, this will collide with nadvice's use of
+;; function-documentation if we happen to advise `pcase'.
+(put 'pcase 'function-documentation '(pcase--make-docstring))
+(defun pcase--make-docstring ()
+  (let* ((main (documentation (symbol-function 'pcase) 'raw))
+         (ud (help-split-fundoc main 'pcase)))
+    (with-temp-buffer
+      (insert (or (cdr ud) main))
+      (mapatoms
+       (lambda (symbol)
+         (let ((me (get symbol 'pcase-macroexpander)))
+           (when me
+             (insert "\n\n-- ")
+             (let* ((doc (documentation me 'raw)))
+               (setq doc (help-fns--signature symbol doc me
+                                              (indirect-function me)))
+               (insert "\n" (or doc "Not documented.")))))))
+      (let ((combined-doc (buffer-string)))
+        (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
+
 ;;;###autoload
 (defmacro pcase-exhaustive (exp &rest cases)
   "The exhaustive version of `pcase' (which see)."
@@ -347,9 +361,13 @@ of the form (UPAT EXP)."
 ;;;###autoload
 (defmacro pcase-defmacro (name args &rest body)
   "Define a pcase UPattern macro."
-  (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3))
-  `(put ',name 'pcase-macroexpander
-        (lambda ,args ,@body)))
+  (declare (indent 2) (debug defun) (doc-string 3))
+  (let ((fsym (intern (format "%s--pcase-macroexpander" name))))
+    ;; Add the function via `fsym', so that an autoload cookie placed
+    ;;  on a pcase-defmacro will cause the macro to be loaded on demand.
+    `(progn
+       (defun ,fsym ,args ,@body)
+       (put ',name 'pcase-macroexpander #',fsym))))
 
 (defun pcase--match (val upat)
   "Build a MATCH structure, hoisting all `or's and `and's outside."
@@ -810,6 +828,14 @@ Otherwise, it defers to REST which is a list of branches of the form
    (t (error "Incorrect MATCH %S" (car matches)))))
 
 (pcase-defmacro \` (qpat)
+  "Backquote-style pcase patterns.
+QPAT can take the following forms:
+  (QPAT1 . QPAT2)       matches if QPAT1 matches the car and QPAT2 the cdr.
+  [QPAT1 QPAT2..QPATn]  matches a vector of length n and QPAT1..QPATn match
+                           its 0..(n-1)th elements, respectively.
+  ,UPAT                 matches if the UPattern UPAT matches.
+  STRING                matches if the object is `equal' to STRING.
+  ATOM                  matches if the object is `eq' to ATOM."
   (cond
    ((eq (car-safe qpat) '\,) (cadr qpat))
    ((vectorp qpat)