(eval-when-compile (require 'cl))
(put 'mcase 'lisp-indent-function 1)
(put 'pmatch 'lisp-indent-function 2)
(put 'mlet 'lisp-indent-function 2)
(defmacro mcase (object &rest clauses)
"Pattern-matching case expression.
The syntax is like the normal `case':
(mcase EXPR
(PATTERN . BODY)
...)
The body of the first matching pattern is executed, with pattern
variables bound to their matching values. If no patterns match, an
error is signaled.
See `mlet' for a description of pattern syntax."
`(mcase* ,object ,(mcase-parse-clauses clauses)))
(eval-and-compile
(defun mcase-parse-clauses (clauses)
`(list ,@(mapcar #'(lambda (clause)
`(list ',(car clause)
(lambda () ,@(cdr clause))))
clauses))))
(defmacro pmatch (&rest args)
"Deprecated; see `mlet'."
`(mlet ,@args))
(defmacro mlet (pattern object &rest body)
"Match PATTERN with OBJECT, and execute BODY with all bindings.
The pattern syntax is:
Trivial: t, nil, 42
Testing with `equal'
Pattern variable: x, my-variable
Variable that the pattern should bind. If the same variable
appears several times in a pattern, then all of its bindings must
match.
Within the body of a successful pattern match, lisp variables are
bound for all pattern variables.
Constant: 'symbol, '(1 2 3), ...
Quoted constant, matched with `equal'.
Bound variable: ,var
Pre-bound Lisp variable, matched by value.
Wild card: _ (underscore)
Matches anything, with no binding.
Sequence: (pat1 ...), [pat1 ...]
Matches the \"shape\" of the pattern, as well as each individual
subpattern."
(let ((var (make-symbol "var")))
`(let ((,var ,object)) (mcase ,var
(,pattern ,@body)
(_ (signal 'erl-exit-signal
(list (tuple 'badmatch ',pattern ,var))))))))
(defun mcase* (object clauses)
(let ((clause (mcase-choose object clauses)))
(if clause
(funcall clause)
(signal 'erl-exit-signal '(case-clause)))))
(defun mcase-choose (object clauses)
(if (null clauses)
nil
(let* ((clause (car clauses))
(pattern (car clause))
(action (cadr clause))
(result (patmatch pattern object)))
(if (eq result 'fail)
(mcase-choose object (cdr clauses))
`(lambda ()
(let ,(alist-to-letlist result)
(funcall ,action)))))))
(defun alist-to-letlist (alist)
"Convert an alist into `let' binding syntax, eg: ((A . B)) => ((A 'B))"
(mapcar (lambda (cell)
(list (car cell) (list 'quote (cdr cell))))
alist))
(defun pmatch-tail (seq)
(if (consp seq)
(cdr seq)
(let ((new (make-vector (1- (length seq)) nil)))
(dotimes (i (length new))
(aset new i (aref seq (1+ i))))
new)))
(defun patmatch (pattern object &optional bindings)
"Match OBJECT with PATTERN, and return an alist of bindings."
(if (eq bindings 'fail)
'fail
(cond ((pmatch-wildcard-p pattern)
bindings)
((pmatch-constant-p pattern) (pmatch-constant pattern object bindings))
((pmatch-bound-var-p pattern) (pmatch-match-var pattern object bindings))
((pmatch-unbound-var-p pattern) (pmatch-bind-var pattern object bindings))
((pmatch-trivial-p pattern) (if (equal pattern object) bindings 'fail))
((consp pattern)
(if (consp object)
(patmatch (cdr pattern) (cdr object)
(patmatch (car pattern) (car object) bindings))
'fail))
((vectorp pattern)
(if (and (vectorp object)
(= (length pattern) (length object)))
(patmatch (coerce pattern 'list) (coerce object 'list) bindings)
'fail))
(t
'fail))))
(defun pmatch-wildcard-p (pat)
(eq pat '_))
(defun pmatch-trivial-p (pat)
"Test for patterns which can always be matched literally with `equal'."
(or (numberp pat)
(equal pat [])
(equal pat nil)
(equal pat t)))
(defun pmatch-constant-p (pat)
"Test for (quoted) constant patterns.
Example: (QUOTE QUOTE)"
(and (consp pat)
(= (length pat) 2)
(eq (car pat) 'quote)))
(defun pmatch-constant-value (pat)
"The value of a constant pattern.
(QUOTE X) => X"
(cadr pat))
(defun pmatch-constant (pat object bindings)
"Match OBJECT with the constant pattern PAT."
(if (equal (pmatch-constant-value pat) object)
bindings
'fail))
(defun pmatch-unbound-var-p (obj)
"Unbound variable is any symbol except nil or t."
(and (symbolp obj)
(not (eq obj nil))
(not (eq obj t))))
(defun pmatch-unbound-var-symbol (sym)
sym)
(defun pmatch-bind-var (pat object bindings)
"Add a binding of pattern variable VAR to OBJECT in BINDINGS."
(if (eq object erl-tag)
'fail
(let* ((var (pmatch-unbound-var-symbol pat))
(binding (assoc var bindings)))
(cond ((null binding)
(acons var object bindings))
((equal (cdr binding) object)
bindings)
(t
'fail)))))
(eval-when-compile (defvar pattern))
(defun pmatch-match-var (var object bindings)
"Match the value of the Lisp variable VAR with OBJECT."
(if (equal (symbol-value (pmatch-bound-var-name pattern)) object)
bindings
'fail))
(defun pmatch-bound-var-p (obj)
(and (symbolp obj)
(eq (elt (symbol-name obj) 0) ?,)))
(defun pmatch-bound-var-name (sym)
(intern (substring (symbol-name sym) 1)))
(defun pmatch-alist-keysort (alist)
(sort alist (lambda (a b)
(string< (symbol-name (car a))
(symbol-name (car b))))))
(defun pmatch-expect (pattern object expected)
"Assert that matching PATTERN with OBJECT yields EXPECTED.
EXPECTED is either 'fail or a list of bindings (in any order)."
(let ((actual (patmatch pattern object)))
(if (or (and (eq actual 'fail)
(eq actual expected))
(and (listp expected)
(listp actual)
(equal (pmatch-alist-keysort actual)
(pmatch-alist-keysort expected))))
t
(error "Patmatch: %S %S => %S, expected %S"
pattern object actual expected))))
(defun pmatch-test ()
"Test the pattern matcher."
(interactive)
(pmatch-expect t t ())
(pmatch-expect '(t nil 1) '(t nil 1) ())
(let ((foo 'foo))
(pmatch-expect '(FOO ,foo 'foo [FOO]) '(foo foo foo [foo])
'((FOO . foo))))
(pmatch-expect 1 2 'fail)
(pmatch-expect '(x x) '(1 2) 'fail)
(pmatch-expect '_ '(1 2) 'nil)
(assert (equal 'yes
(mcase '(call 42 lists length ((1 2 3)))
(t 'no)
(1 'no)
((call Ref 'lists 'length (_))
'yes)
(_ 'no))))
(message "Smooth sailing"))
(provide 'patmatch)