Scheme Pattern Matching with @-bindings
In my first post about pattern matching with Scheme, I mentioned that the main feature that I thought was missing was the ability to bind a pattern to an identifier, while still matching on the internals of that pattern.
Haskell has a way of doing it with an @ character, which might look this: func (Just x@[_]) = x.
In this post I show how I added that functionality to my pattern matching code.
That function's pattern match will ensure that the Maybe has a value, and that the value is a single-element list.
Instead of returning only the element from the list, or re-building the list from its single element, however,
it binds the x identifier to the singleton list that was passed and returns that.
Source code with comments and examples (MPL-v2.0) or inline
Usage
The @-binding is an added feature to my existing pattern matching code, so please read its post first for an idea of how to use it.
In order to use an @-binding in a pattern match, simply wrap the pattern in a pair, the first element of which is an identifier beginning with an @ (at) symbol.
The new fifth example in the source code is reproduced below to show that.
(define (pattern-match/example-5)
(let ((e '(PAIR (NAME (identifier . "x"))
(NAME (identifier . "y")))))
(pattern-match e get
(('PAIR (@first ('NAME ('identifier . x)))
second)
(printf "pair has first element ~A with name ~A, and second element ~A~%" (get 'first) (get 'x) (get 'second)))
(else
(printf "failed outer~%")))))
The first item in the pair will be bound to the first identifier (accessed with (get 'first)),
while still being pattern-matched further to extract its identifier, which is bound to x.
Implementation
To show how simple the pattern matching code is, the code in its entirety (including inline comments) is reproduced below. All code on this web page is made available under the Mozilla Public License Version 2.0.
;; Pattern match on a value and execute the expressions of the first match.
(define-syntax pattern-match
(syntax-rules (else)
((pattern-match value getter-name
(pattern body ...)
...
(else otherwise ...))
(cond
((pattern-match/bind value (quote pattern))
=> (lambda (bindings)
(let ((getter-name (lambda (id)
(let ((found (assv id bindings)))
(if found
(cadr found)
#f)))))
body
...)))
...
(else
otherwise
...)))))
;; Create a list of bindings from a pattern and a value to match it to.
(define (pattern-match/bind value pattern)
(cond
; If the pattern is a pair with its first item being a single quoted symbol
; beginning with the @ character, it's a binding on the whole value, while
; the value is still to be pattern-matched further by the second item of
; the pair.
((and (pair? pattern)
(not (null? pattern))
(not (null? (cdr pattern)))
(pattern-match/@-symbol? (car pattern)))
(pattern-match/unify (list
(list (pattern-match/@-symbol->symbol
(car pattern))
value))
(pattern-match/bind value (cadr pattern))))
; If the pattern is a single-quoted symbol, it's a binding!
((and (symbol? pattern)
(not (pattern-match/quoted-symbol? pattern)))
(list (list pattern value)))
; If they're both empty, it's a match!
((and (null? value)
(null? pattern))
'())
; If one but not the other is empty, it's not a match... :(
((or (null? value)
(null? pattern))
#f)
; If they're both the same quoted symbols, it's a match!
; This is a special case, because symbols in the pattern must be
; double-quoted, otherwise they are identifiers (handled above).
((and (symbol? value)
(pattern-match/quoted-symbol? pattern)
(eqv? value (pattern-match/quoted-symbol->symbol pattern)))
'())
; If they're both the same atoms, it's a match!
((and (atom? value)
(atom? pattern)
(equal? value pattern))
'())
; If they're both pairs, then try recursively matching them...
((and (pair? value) (pair? pattern))
(let ((lhs (pattern-match/bind (car value) (car pattern)))
(rhs (pattern-match/bind (cdr value) (cdr pattern))))
(pattern-match/unify lhs rhs)))
; We've run out of options; it's not a match... :(
(else #f)))
;; Is the given value a quoted symbol?
(define (pattern-match/quoted-symbol? value)
(and (list? value)
(not (null? value))
(not (null? (cdr value)))
(null? (cddr value))
(eqv? (car value) 'quote)
(symbol? (cadr value))))
;; Extract the symbol from a quoted symbol.
(define pattern-match/quoted-symbol->symbol cadr)
;; Is the given value an unquoted symbol beginning with an @?
(define (pattern-match/@-symbol? value)
(and (symbol? value)
(not (pattern-match/quoted-symbol? value))
(char=? #\@ (car (string->list (symbol->string value))))))
;; Get the name of the @ symbol without the @.
(define (pattern-match/@-symbol->symbol value)
(if (pattern-match/@-symbol? value)
(string->symbol (list->string (cdr (string->list (symbol->string value)))))
#f))
;; Unify two branches of a pattern match bind.
(define (pattern-match/unify lhs rhs)
(cond
; Recursive base case: if either branch failed, propagate the failure
((or (not lhs) (not rhs))
#f)
; Recursive base case: if the right-hand-side bindings are empty, then
; return the left-hand-side bindings
((null? rhs)
lhs)
; Recursive base case: if the left-hand-side bindings are empty, then
; return the right-hand-side bindings
((null? lhs)
rhs)
; Recursive step: look for the first right-hand-side binding in the
; list of left-hand-side bindings. If it is present in the left-hand-side
; but the assignments do not match, this pattern match fails; otherwise
; recurse, holding on to the first right-hand-side binding if it does not
; appear on the left-hand-side, and continuing with the rest of the
; right-hand-side binding.
(else
(let ((found (assv (caar rhs) lhs)))
(cond
((and found (equal? found (car rhs)))
(pattern-match/unify lhs (cdr rhs)))
(found
#f)
(else
(cons (car rhs)
(pattern-match/unify lhs (cdr rhs)))))))))