match facility

[Andy Wingo]

Hello,

One of the things I have most enjoyed about the Guile 2.0 series is that
it bundles a pattern matcher.  I love using pattern matchers to
destructure data -- it feels really nice.

I needed to match some Elisp data recently, so I wrote the following
matcher.  What do you think about it?  If you like it, I can do the
paperwork.

    (setq lexical-binding t)

    (eval-when-compile (require 'cl))

    (defun compile-or-match (id pats kt kf)
      (if (null pats)
          kf
        (compile-match id (car pats) kt
                       (compile-or-match id (cdr pats) kt kf))))

    (defun compile-and-match (id pats kt kf)
      (if (null pats)
          kt
        (compile-match id (car pats)
                       (compile-and-match id (cdr pats) kt kf)
                       kf)))

    (defun compile-match (id pat kt kf)
      (cond ((consp pat)
             (cond
              ((eq (car pat) 'quote)
               `(if (equal ,id ',(cadr pat)) ,kt ,kf))
              ((eq (car pat) 'funcall)
               `(if (funcall ,@(cdr pat) ,id) ,kt ,kf))
              ((eq (car pat) 'or)
               (compile-or-match id (cdr pat) kt kf))
              ((eq (car pat) 'and)
               (compile-and-match id (cdr pat) kt kf))
              (t
               `(if (consp ,id)
                    ,(let ((head (gensym))
                           (tail (gensym)))
                       `(let ((,head (car ,id))
                              (,tail (cdr ,id)))
                          ,(compile-match head (car pat)
                                          (compile-match tail (cdr pat) kt kf)
                                          kf)))
                  ,kf))))
            ((eq pat '_) kt)
            ((null pat) `(if (null ,id) ,kt ,kf))
            ((eq pat t) `(if (eq ,id t) ,kt ,kf))
            ((symbolp pat) `(let ((,pat ,id)) ,kt))
            (t `(if (equal ,id ',pat) ,kt ,kf))))

    (defun compile-match-clauses (id clauses)
      (let ((exp '(error "Match failed"))
            (fns nil)
            (next (gensym))
            (kf (gensym))
            (return (gensym)))
        (setq clauses (reverse clauses))
        (while clauses
          (let ((kf (gensym)))
            (let ((clause (pop clauses)))
              (push `(,kf #'(lambda () ,exp)) fns)
              (setq exp
                    (compile-match id (car clause)
                                   `(throw ',return (progn ,@(cdr clause)))
                                   `(throw ',next ,kf))))))
        `(let* ,(reverse fns)
           (catch ',return
             (let ((,kf (catch ',next ,exp)))
               (while t
                 (setq next (catch ',next (funcall ,kf)))))))))

    (defmacro match (form &rest clauses)
      (let ((id (gensym)))
        `(let ((,id ,form))
           ,(compile-match-clauses id clauses))))

    (put 'match 'lisp-indent-function 1)

The syntax is:

  (match expr (pat body ...) ...)

where

  pat := _ ; matches anything
    | (and pat ...) ; matches values that match all sub-patterns
    | (or pat ...) ; matches pairs whose parts match any sub-pattern
    | (funcall f arg ...) ; matches if (funcall F ARG ... VAL)
    | 'literal ; matches a literal, using EQUAL
    | (pat . pat) ; matches pairs whose parts match
    | id ; binds ID to VALUE, in the context of BODY ...
    | val ; like 'literal, the last case

An example use:

    (defun compile-sxml-match-attrs (id pat kt kf)
      (match pat
        (() kt)
        (((attr-name attr-val-pat) . attrs)
         (let ((val (gensym)))
           `(match (assq ',attr-name ,id)
              ((_ ,val)
               ,(compile-sxml-match val attr-val-pat
                                    (compile-sxml-match-attrs id attrs kt kf)
                                    kf))
              (() ,kf)
              (_ (error "Bad XML: expected attrs list after tag")))))))

Both in the function and its output: pretty fun.

Perhaps the elispy thing to do would be to have t be the match-anything
case.  Dunno.

Thoughts welcome.

Andy
-- 
http://wingolog.org/