with-string-match slhelper

with-string-match.lisp

(defvar *pattern-extractors*
  (make-hash-table)
  "Maps from names to pattern extraction functions.")

(defmacro define-pattern-extractor (name &body spec)
  "Define a pattern extractor with NAME.

SPEC may consist of an operator name to pass a string to in order to
extract a value, or a lambda list followed by a body processing the
string passed as argument."
  (multiple-value-bind (arg forms)
      (cond ((null spec)
             (error "Need at least an operator name."))
            ((null (rest spec))
             (let ((s (gensym)))
               (values s (list (list (first spec) s)))))
            (t
             (values (first spec) (rest spec))))
    `(progn
       (setf (gethash ',name *pattern-extractors*)
             (lambda (,arg)
               ,@forms))
       ',name)))

(define-pattern-extractor :n parse-number)

(define-pattern-extractor :s identity)

(defun find-pattern-extractor (name)
  "Return the pattern extraction function for NAME, or signal an error
if there none."
  (or (gethash name *pattern-extractors*)
      (error "Can't find pattern extractor for ~S." name)))

(defun match-string (pattern string)
  "Match PATTERN against STRING and return a list of extracted values.

PATTERN should be a list alternating between strings and pattern
extractor names.

STRING should be the string to match the pattern against."
  (let ((values '())
        (empty ""))
    (loop
     (cond ((or (null pattern) (equal empty string))
            (return))
           ((stringp (first pattern))
            (if (eql (length (first pattern))
                     (mismatch (first pattern) string))
                (setf string (subseq string (length (first pattern)))
                      pattern (rest pattern))
                (error "Can't match ~S against pattern string ~S."
                       string (first pattern))))
           ((null (rest pattern))
            (push (funcall (find-pattern-extractor (first pattern))
                           string)
                  values)
            (setf string empty))
           ((stringp (second pattern))
            (let ((pos (search (second pattern) string)))
              (when (null pos)
                (error "Can't find pattern string ~S in ~S."
                       (second pattern)
                       string))
              (push (funcall (find-pattern-extractor (first pattern))
                             (subseq string 0 pos))
                    values)
              (setf string (subseq string (+ pos (length (second pattern)))))
              (setf pattern (cddr pattern))))
           (t
            (error "Unexpected pattern ~S." pattern))))
    (values-list (nreverse values))))

(defmacro with-string-match (pattern string &body forms)
  "Match PATTERN against STRING and evaluate FORMS with values bound
to variables specified in the pattern.

PATTERN should be a list alternating between strings and 2-element
lists whose first element is a pattern extractor name and second
element names a variable that will be bound to the extracted value."
  (let ((vars (loop for p in pattern
                    when (listp p)
                    collect (second p)))
        (pat (loop for p in pattern
                   collect (if (listp p)
                               (first p)
                               p))))
    `(multiple-value-bind ,vars (match-string ',pat ,string)
       (declare (ignorable ,@vars))
       ,@forms)))