;;	$Id: debind.el,v 1.11 2007/12/30 09:25:14 minh Exp $

;; Copyright (c) 2007 Nhat Minh Lê. All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above
;;    copyright notice, this list of conditions and the following
;;    disclaimer in the documentation and/or other materials provided
;;    with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:

;; Simple pattern matching for Emacs Lisp.

;; Example: See `debind-zip'.

;; nil: quasiquote, t: pattern, 'eval: quasipattern, 'free: none
(defun debind-quasimatch (subject pat &optional freematch)
  (cond
   ((and freematch (symbolp pat))
    (if (or (eq freematch 'eval) (eq pat nil) (eq pat t))
	(equal subject (symbol-value pat))
      (set pat subject)
      t))
   ((consp pat)
    (cond
     ((and (not freematch)
	   (or (eq (car pat) 'unquote) (eq (car pat) '\,)))
      (debind-match subject (cadr pat)))
     ((eq freematch 'free)
      (let ((op (car pat)))
	(cond
	 ((eq op 'pattern) (debind-quasimatch subject (cadr pat) t))
	 ((eq op 'quasipattern) (debind-quasimatch subject (cadr pat) 'eval))
	 ((eq op 'requisite) (funcall pat subject))
	 ((eq op 'and)
	  (while (progn (setq pat (cdr pat))
			(and pat (debind-match subject (car pat)))))
	  (null pat))
	 ((eq op 'or)
	  (while (progn (setq pat (cdr pat))
			(and pat (not (debind-match subject (car pat))))))
	  pat)
	 ((eq op 'quote) (equal subject (cadr pat)))
	 ((or (eq op 'quasiquote) (eq op '\`))
	  (debind-quasimatch subject (cadr pat)))
	 (t (and (consp subject)
		 (debind-match (car subject) (car pat))
		 (debind-match (cdr subject) (cdr pat)))))))
     (t (and (consp subject)
	     (debind-quasimatch (car subject) (car pat) freematch)
	     (debind-quasimatch (cdr subject) (cdr pat) freematch)))))
   ((vectorp pat)
    (let (slen (plen (length pat)))
      (and (vectorp subject)
	   (= plen (setq slen (length subject)))
	   (let ((i 0))
	     (while (and (< i plen)
			 (debind-quasimatch (elt subject i)
					    (elt pat i)
					    freematch))
	       (setq i (1+ i)))
	     (= i plen)))))
   (t (equal subject pat))))

(defun debind-match (subject pat)
  (debind-quasimatch subject pat 'free))

(defun debind-quasicompute-free-variables (pat &optional freematch)
  (cond
   ((and freematch (symbolp pat) (not (eq pat nil)) (not (eq pat t)))
    (list pat))
   ((consp pat)
    (cond
     ((or (eq (car pat) 'unquote) (eq (car pat) '\,))
      (debind-compute-free-variables (cadr pat)))
     ((eq freematch 'free)
      (let ((op (car pat)))
        (cond
         ((eq op 'pattern) (debind-compute-free-variables (cadr pat) t))
         ((or (eq op 'and) (eq op 'or))
	  (apply 'nconc (mapcar (lambda (c)
				  (debind-compute-free-variables c))
				(cdr pat))))
         ((or (eq op 'quasiquote) (eq op '\`))
	  (debind-quasicompute-free-variables (cadr pat)))
	 ((or (eq op 'quote) (eq op 'quasipattern) (eq op 'requisite)) nil)
         (t (nconc (debind-compute-free-variables (car pat))
		   (debind-compute-free-variables (cdr pat)))))))
     (t (nconc (debind-quasicompute-free-variables (car pat) freematch)
	       (debind-quasicompute-free-variables (cdr pat) freematch)))))
   ((vectorp pat)
    (apply 'nconc
	   (mapcar (lambda (x)
		     (debind-quasicompute-free-variables x freematch))
		   pat)))
   (t nil)))

(defun debind-compute-free-variables (pat)
  (debind-quasicompute-free-variables pat 'free))

(defmacro debind (subject &rest cases)
  "Match SUBJECT against each case.

Each case has the form:
	(PATTERN BODY...)

The syntax of patterns is as follows:

SYMBOL			Matches anything, binds SYMBOL locally.

\(and PATTERN...)	Matches all patterns in the list.

\(or PATTERN...)	Matches any pattern in the list.

\(quote LITERAL)	Matches LITERAL, exactly.

\(quasiquote PATTERN)
`PATTERN
			Matches literally except when unquoted.

\(unquote PATTERN)
,PATTERN
			Matches PATTERN, inside a quasi-pattern.

\(pattern PATTERN)	Matches PATTERN ignoring all operators.
			Operators are treated as symbols.

\(quasipattern PATTERN)	Matches PATTERN ignoring all operators.
			Symbols (including operators) are treated
			as variables.

\(requisite PREDICATE)	Matches anything for which PREDICATE is true.

ANYTHING		Anything else matches itself.

All symbols present in any of the patterns of a single match form
will be shadowed locally, whether or not they are bound by the
matching patterns.

There is one ambiguous case due to the old backquote syntax still
present in Emacs. If you have to input a parenthesis followed by
a backquote, use ((and `X) Y...) instead of (`X Y...); the latter
will not work."
  (declare (indent 1)
	   (debug (form &rest (sexp &rest form))))
  (let ((subject-symbol (make-symbol "subject")))
    `(let ((,subject-symbol ,subject))
       (let ,(apply 'nconc (mapcar (lambda (c)
				     (debind-compute-free-variables (car c)))
				   cases))
	 (cond
	  ,@(mapcar (lambda (x)
		      (let ((pat (car x)) (body (cdr x)))
			(cons `(debind-match ,subject-symbol (quote ,pat))
			      body)))
		    cases))))))

(defmacro debind-lambda (&rest cases)
  "Return a lambda expression that does pattern matching on its
  arguments.

CASES should be a list of cases as in `debind'. The subject is
the argument list.

Please note that patterns such as vectors and such, although
perfectly possible will never match."
  (declare (indent 1)
	   (debug (&rest (sexp &rest form))))
  (let ((args-symbol (make-symbol "args")))
  `(lambda (&rest ,args-symbol)
     (debind ,args-symbol . ,cases))))

(defmacro debind-defun (name &rest cases)
  "Define a function that does pattern matching on its arguments.

CASES should be a list of cases as in `debind'. The subject is
the argument list.

Please note that patterns such as vectors and such, although
perfectly possible will never match."
  (declare (indent 1)
	   (debug (&define name &rest (sexp def-body))))
  (let ((args-symbol (make-symbol "args")))
  `(defun ,name (&rest ,args-symbol)
     (debind ,args-symbol . ,cases))))

(debind-defun debind-zip
  ((f (x . r) (y . s))
   (cons (funcall f x y) (debind-zip f r s)))
  ((and) nil))

(defmacro debind-let-common (slet-symbol let-symbol bindings body)
  (declare (debug ((&rest (sexp form)) &rest form)))
  (let ((svar-symbols (mapcar (lambda (x) (make-symbol "s")) bindings)))
    `(,slet-symbol
      ,(debind-zip (lambda (s b) (list s (cadr b)))
		   svar-symbols bindings)
      (,let-symbol ,(apply 'nconc
			   (mapcar (lambda (c)
				     (debind-compute-free-variables (cadr c)))
				   bindings))
	,@(debind-zip
	   (lambda (s b)
	     (let ((pat (car b)))
	       `(debind-match ,s (quote ,pat))))
	   svar-symbols bindings)
	. ,body))))

(defmacro debind-let (bindings &rest body)
  "Bind patterns to values."
  (declare (indent 1) (debug debind-let-common))
  `(debind-let-common let let ,bindings ,body))

(defmacro debind-let* (bindings &rest body)
  "Bind patterns to values sequentially."
  (declare (indent 1) (debug debind-let-common))
  `(debind-let-common let* let ,bindings ,body))

(defalias 'match 'debind)
(put 'match 'lisp-indent-function 1)
(def-edebug-spec match debind)

(defalias 'match-lambda 'debind-lambda)
(put 'match-lambda 'lisp-indent-function 1)
(def-edebug-spec match-lambda debind-lambda)

(defalias 'match-defun 'debind-defun)
(put 'match-defun 'lisp-indent-function 1)
(def-edebug-spec match-defun debind-defun)

(defalias 'match-let 'debind-let)
(put 'match-let 'lisp-indent-function 1)
(def-edebug-spec match-let debind-let)

(defalias 'match-let* 'debind-let*)
(put 'match-let* 'lisp-indent-function 1)
(def-edebug-spec match-let* debind-let*)

(provide 'debind)