Add support for quote' and app'.

* lisp/emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
New optimization functions.
(pcase--u1): Add support for `quote' and `app'.
(pcase): Document them in the docstring.

etc/NEWS

@@ -102,6 +102,9 @@ performance improvements when pasting large amounts of text.
 
 * Changes in Specialized Modes and Packages in Emacs 24.5
 
+** pcase
+*** New UPatterns `quote' and `app'.
+
 ** Lisp mode
 *** Strings after `:documentation' are highlighted as docstrings.
 

lisp/ChangeLog

@@ -1,3 +1,11 @@
+2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	Add support for `quote' and `app'.
+	* emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
+	New optimization functions.
+	(pcase--u1): Add support for `quote' and `app'.
+	(pcase): Document them in the docstring.
+
 2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
 	Use lexical-bindin in Ibuffer.

lisp/emacs-lisp/pcase.el

@@ -102,13 +102,19 @@ UPatterns can take the following forms:
   SYMBOL	matches anything and binds it to SYMBOL.
   (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 PRED)	matches if PRED applied to the object returns non-nil.
   (guard BOOLEXP)	matches if BOOLEXP evaluates to non-nil.
   (let UPAT EXP)	matches if EXP matches UPAT.
+  (app FUN UPAT)	matches if FUN applied to the object matches UPAT.
 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.
 
+FUN can be either of the form (lambda ARGS BODY) or a symbol.
+It has to obey the rule that if (FUN X) returns V then calling it again will
+return the same V again (so that multiple (FUN X) can be consolidated).
+
 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
@@ -119,7 +125,7 @@ QPatterns can take the following forms:
 
 PRED can take the form
   FUNCTION	     in which case it gets called with one argument.
-  (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument
+  (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
                         which is the value being matched.
 A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
 PRED patterns can refer to variables bound earlier in the pattern.
@@ -157,6 +163,7 @@ like `(,a . ,(pred (< a))) or, with more checks:
   (let* ((x (make-symbol "x"))
          (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
     (pcase--expand
+     ;; FIXME: Could we add the FILE:LINE data in the error message?
      exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
 
 (defun pcase--let* (bindings body)
@@ -569,6 +576,27 @@ MATCH is the pattern that needs to be matched, of the form:
 (defun pcase--self-quoting-p (upat)
   (or (keywordp upat) (numberp upat) (stringp upat)))
 
+(defun pcase--app-subst-match (match sym fun nsym)
+  (cond
+   ((eq (car match) 'match)
+    (if (and (eq sym (cadr match))
+             (eq 'app (car-safe (cddr match)))
+             (equal fun (nth 1 (cddr match))))
+        `(match ,nsym ,@(nth 2 (cddr match)))
+      match))
+   ((memq (car match) '(or and))
+    `(,(car match)
+      ,@(mapcar (lambda (match)
+                  (pcase--app-subst-match match sym fun nsym))
+                (cdr match))))
+   (t (error "Uknown MATCH %s" match))))
+
+(defun pcase--app-subst-rest (rest sym fun nsym)
+  (mapcar (lambda (branch)
+            `(,(pcase--app-subst-match (car branch) sym fun nsym)
+              ,@(cdr branch)))
+          rest))
+
 (defsubst pcase--mark-used (sym)
   ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
   (if (symbolp sym) (put sym 'pcase-used t)))
@@ -695,9 +723,40 @@ Otherwise, it defers to REST which is a list of branches of the form
                   (if env (macroexp-let* env exp) exp))))
           (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
                      code vars rest)))
+       ((eq (car-safe upat) 'app)
+        ;; A upat of the form (app FUN UPAT)
+        (pcase--mark-used sym)
+        (let* ((fun (nth 1 upat)))
+          (macroexp-let2
+              macroexp-copyable-p nsym
+              (if (symbolp fun)
+                  `(,fun ,sym)
+                (let* ((vs (pcase--fgrep (mapcar #'car vars) fun))
+                       (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
+                                    vs))
+                       (call `(funcall #',fun ,sym)))
+                  (if env (macroexp-let* env call) call)))
+            ;; We don't change `matches' to reuse the newly computed value,
+            ;; because we assume there shouldn't be such redundancy in there.
+            (pcase--u1 (cons `(match ,nsym ,@(nth 2 upat)) matches)
+                       code vars
+                       (pcase--app-subst-rest rest sym fun nsym)))))
        ((eq (car-safe upat) '\`)
         (pcase--mark-used sym)
         (pcase--q1 sym (cadr upat) matches code vars rest))
+       ((eq (car-safe upat) 'quote)
+        (let* ((val (cadr upat))
+               (splitrest (pcase--split-rest
+                           sym (lambda (pat) (pcase--split-equal val pat)) rest))
+               (then-rest (car splitrest))
+               (else-rest (cdr splitrest)))
+          (pcase--if (cond
+                      ((null val) `(null ,sym))
+                      ((or (integerp val) (symbolp val))
+                       `(equal ,sym ,val))
+                      (t `(equal ,sym ',val)))
+                     (pcase--u1 matches code vars then-rest)
+                     (pcase--u else-rest))))
        ((eq (car-safe upat) 'or)
         (let ((all (> (length (cdr upat)) 1))
               (memq-fine t))

test/automated/pcase-tests.el

@@ -0,0 +1,34 @@
+;;; pcase-tests.el --- Test suite for pcase macro.
+
+;; Copyright (C) 2012-2014 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest pcase-tests-behavior ()
+  "Test pcase code."
+  (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5)))
+
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
+
+;;; pcase-tests.el ends here.