From 13b1840d23f1f214bec11a3c6823d675cbd82f28 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 22 Sep 2014 10:30:47 -0400 Subject: [PATCH] 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 | 3 +++ lisp/ChangeLog | 8 ++++++ lisp/emacs-lisp/pcase.el | 61 ++++++++++++++++++++++++++++++++++++++++++- test/automated/pcase-tests.el | 34 ++++++++++++++++++++++++ 4 files changed, 105 insertions(+), 1 deletion(-) create mode 100644 test/automated/pcase-tests.el diff --git a/etc/NEWS b/etc/NEWS index 398a39ea9f8..cbad7c5b54b 100644 --- a/etc/NEWS +++ b/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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3fa8ca5a749..1aad2004d6a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,13 @@ 2014-09-22 Stefan Monnier + 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 + Use lexical-bindin in Ibuffer. * ibuffer.el (ibuffer-do-toggle-read-only): `arg' is unused. (ibuffer-compile-format): Simplify. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 94aedd4339a..fbe241b6fc8 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/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)) diff --git a/test/automated/pcase-tests.el b/test/automated/pcase-tests.el new file mode 100644 index 00000000000..c51cf8d9573 --- /dev/null +++ b/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 . + +;;; 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. -- 2.11.4.GIT