lib/distel/elisp/patmatch.el

   1 ;; -*- comment-column: 32 -*-
   2
   3 (eval-when-compile (require 'cl))
   4
   5 (put 'mcase 'lisp-indent-function 1)
   6 (put 'pmatch 'lisp-indent-function 2)
   7 (put 'mlet 'lisp-indent-function 2)
   8
   9 (defmacro mcase (object &rest clauses)
  10   "Pattern-matching case expression.
  11 The syntax is like the normal `case':
  12
  13   (mcase EXPR
  14     (PATTERN . BODY)
  15     ...)
  16
  17 The body of the first matching pattern is executed, with pattern
  18 variables bound to their matching values. If no patterns match, an
  19 error is signaled.
  20
  21 See `mlet' for a description of pattern syntax."
  22   `(mcase* ,object ,(mcase-parse-clauses clauses)))
  23
  24 (eval-and-compile
  25 (defun mcase-parse-clauses (clauses)
  26   `(list ,@(mapcar #'(lambda (clause)
  27                        `(list ',(car clause)
  28                               (lambda () ,@(cdr clause))))
  29                    clauses))))
  30
  31 (defmacro pmatch (&rest args)
  32   "Deprecated; see `mlet'."
  33   `(mlet ,@args))
  34
  35 (defmacro mlet (pattern object &rest body)
  36   "Match PATTERN with OBJECT, and execute BODY with all bindings.
  37 The pattern syntax is:
  38
  39 Trivial: t, nil, 42
  40   Testing with `equal'
  41 Pattern variable: x, my-variable
  42   Variable that the pattern should bind. If the same variable
  43   appears several times in a pattern, then all of its bindings must
  44   match.
  45   Within the body of a successful pattern match, lisp variables are
  46   bound for all pattern variables.
  47 Constant: 'symbol, '(1 2 3), ...
  48   Quoted constant, matched with `equal'.
  49 Bound variable: ,var
  50   Pre-bound Lisp variable, matched by value.
  51 Wild card: _ (underscore)
  52   Matches anything, with no binding.
  53 Sequence: (pat1 ...), [pat1 ...]
  54   Matches the \"shape\" of the pattern, as well as each individual
  55   subpattern."
  56   (let ((var (make-symbol "var")))
  57     `(let ((,var ,object))      ; so that we just eval `object' once
  58        (mcase ,var
  59          (,pattern ,@body)
  60          (_        (signal 'erl-exit-signal
  61                            (list (tuple 'badmatch ',pattern ,var))))))))
  62
  63 (defun mcase* (object clauses)
  64   (let ((clause (mcase-choose object clauses)))
  65     (if clause
  66         (funcall clause)
  67       (signal 'erl-exit-signal '(case-clause)))))
  68
  69 (defun mcase-choose (object clauses)
  70   (if (null clauses)
  71       nil
  72     (let* ((clause  (car clauses))
  73            (pattern (car clause))
  74            (action  (cadr clause))
  75            (result  (patmatch pattern object)))
  76       (if (eq result 'fail)
  77           (mcase-choose object (cdr clauses))
  78         `(lambda ()
  79            (let ,(alist-to-letlist result)
  80              (funcall ,action)))))))
  81
  82 (defun alist-to-letlist (alist)
  83   "Convert an alist into `let' binding syntax, eg: ((A . B)) => ((A 'B))"
  84   (mapcar (lambda (cell)
  85             (list (car cell) (list 'quote (cdr cell))))
  86           alist))
  87
  88 (defun pmatch-tail (seq)
  89   (if (consp seq)
  90       (cdr seq)
  91     (let ((new (make-vector (1- (length seq)) nil)))
  92       (dotimes (i (length new))
  93         (aset new i (aref seq (1+ i))))
  94       new)))
  95
  96 (defun patmatch (pattern object &optional bindings)
  97   "Match OBJECT with PATTERN, and return an alist of bindings."
  98   (if (eq bindings 'fail)
  99       'fail
 100     (cond ((pmatch-wildcard-p pattern)
 101            bindings)
 102           ((pmatch-constant-p pattern) ; '(x)
 103            (pmatch-constant pattern object bindings))
 104           ((pmatch-bound-var-p pattern) ; ,foo
 105            (pmatch-match-var pattern object bindings))
 106           ((pmatch-unbound-var-p pattern) ; foo
 107            (pmatch-bind-var pattern object bindings))
 108           ((pmatch-trivial-p pattern) ; nil, t, any-symbol
 109            (if (equal pattern object) bindings 'fail))
 110           ((consp pattern)
 111            (if (consp object)
 112                (patmatch (cdr pattern) (cdr object)
 113                          (patmatch (car pattern) (car object) bindings))
 114              'fail))
 115           ((vectorp pattern)
 116            (if (and (vectorp object)
 117                     (= (length pattern) (length object)))
 118                (patmatch (coerce pattern 'list) (coerce object 'list) bindings)
 119              'fail))
 120           (t
 121            'fail))))
 122
 123 (defun pmatch-wildcard-p (pat)
 124   (eq pat '_))
 125
 126 (defun pmatch-trivial-p (pat)
 127   "Test for patterns which can always be matched literally with `equal'."
 128   (or (numberp pat)
 129       (equal pat [])
 130       (equal pat nil)
 131       (equal pat t)))
 132
 133 (defun pmatch-constant-p (pat)
 134   "Test for (quoted) constant patterns.
 135 Example: (QUOTE QUOTE)"
 136   (and (consp pat)
 137        (= (length pat) 2)
 138        (eq (car pat) 'quote)))
 139
 140 (defun pmatch-constant-value (pat)
 141   "The value of a constant pattern.
 142 (QUOTE X) => X"
 143   (cadr pat))
 144
 145 (defun pmatch-constant (pat object bindings)
 146   "Match OBJECT with the constant pattern PAT."
 147   (if (equal (pmatch-constant-value pat) object)
 148       bindings
 149     'fail))
 150
 151 (defun pmatch-unbound-var-p (obj)
 152   "Unbound variable is any symbol except nil or t."
 153   (and (symbolp obj)
 154        (not (eq obj nil))
 155        (not (eq obj t))))
 156
 157 (defun pmatch-unbound-var-symbol (sym)
 158   sym)
 159
 160 (defun pmatch-bind-var (pat object bindings)
 161   "Add a binding of pattern variable VAR to OBJECT in BINDINGS."
 162   (if (eq object erl-tag)
 163       ;; `erl-tag' cannot bind to a variable; this is to prevent pids
 164       ;; or ports from matching tuple patterns.
 165       'fail
 166     (let* ((var (pmatch-unbound-var-symbol pat))
 167            (binding (assoc var bindings)))
 168       (cond ((null binding)
 169              (acons var object bindings))
 170             ((equal (cdr binding) object)
 171              bindings)
 172             (t
 173              'fail)))))
 174
 175 (eval-when-compile (defvar pattern)) ; dynamic
 176
 177 (defun pmatch-match-var (var object bindings)
 178   "Match the value of the Lisp variable VAR with OBJECT."
 179   (if (equal (symbol-value (pmatch-bound-var-name pattern)) object)
 180       bindings
 181     'fail))
 182
 183 (defun pmatch-bound-var-p (obj)
 184   (and (symbolp obj)
 185        (eq (elt (symbol-name obj) 0) ?,)))
 186
 187 (defun pmatch-bound-var-name (sym)
 188   (intern (substring (symbol-name sym) 1)))
 189
 190 (defun pmatch-alist-keysort (alist)
 191   (sort alist (lambda (a b)
 192                 (string< (symbol-name (car a))
 193                          (symbol-name (car b))))))
 194
 195 ;;; Test suite
 196
 197 (defun pmatch-expect (pattern object expected)
 198   "Assert that matching PATTERN with OBJECT yields EXPECTED.
 199 EXPECTED is either 'fail or a list of bindings (in any order)."
 200   (let ((actual (patmatch pattern object)))
 201     (if (or (and (eq actual 'fail)
 202                  (eq actual expected))
 203             (and (listp expected)
 204                  (listp actual)
 205                  (equal (pmatch-alist-keysort actual)
 206                         (pmatch-alist-keysort expected))))
 207         t
 208       (error "Patmatch: %S %S => %S, expected %S"
 209              pattern object actual expected))))
 210
 211 (defun pmatch-test ()
 212   "Test the pattern matcher."
 213   (interactive)
 214   (pmatch-expect t t ())
 215   (pmatch-expect '(t nil 1) '(t nil 1) ())
 216   (let ((foo 'foo))
 217     (pmatch-expect '(FOO ,foo 'foo [FOO]) '(foo foo foo [foo])
 218                    '((FOO . foo))))
 219   (pmatch-expect 1 2 'fail)
 220   (pmatch-expect '(x x) '(1 2) 'fail)
 221   (pmatch-expect '_ '(1 2) 'nil)
 222   (assert (equal 'yes
 223                  (mcase '(call 42 lists length ((1 2 3)))
 224                    (t 'no)
 225                    (1 'no)
 226                    ((call Ref 'lists 'length (_))
 227                     'yes)
 228                    (_ 'no))))
 229   (message "Smooth sailing"))
 230
 231 (provide 'patmatch)
 232