Pattern matching
Andre
Hi,
Here, as promised, is the germ of an implementation of
extensible pattern matching (design in collaboration with
David Van Horn).
It allows one to define a matcher with a custom name:
(define-match-environment match)
add some patterns to it with the extend-matcher interface,
for example:
(extend-matcher match (quote) val success failure ; quote is a literal
((quote x) ; pattern
(if (equal? 'x val) ; translation
success ; success continuation
failure))) ; failure continuation
(extend-matcher match (cons) val sk fk ; cons is literal
((cons pat1 pat2) ; pattern
(let ((fail (lambda () fk))) ; translation
(if (pair? val)
(match (car val)
(pat1 (match (cdr val)
(pat2 sk)
(else (fail))))
(else (fail)))
(fail)))))
and then we can use, e.g.
(match (cons 1 2)
((cons x y) (list x y))) ;==> (1 2)
There is also a facility for local, lexical extensions
(with-patterns match (kons) val sk fk ; folowing patterns only
; valid in lexical scope
(((kons pat1 pat2)
(let ((fail (lambda () fk)))
(if (pair? val)
(match (car val)
(pat1 (match (cdr val)
(pat2 sk)
(else (fail))))
(else (fail)))
(fail)))))
(match (cons 1 2)
((kons a b) (list a b)))) ;==> (1 2)
The design is quite flexible and allows different matcher styles,
non-linear patterns, set!-patterns, etc. as library features. A
standard library is being developed.
A couple more patterns and examples are provided after the implementation
below.
Feedback welcome.
Andre van Tonder
;====================================================================
; Internal syntax utilities:
(define-syntax syntax-error (syntax-rules ()))
(define-syntax syntax-apply
(syntax-rules ()
((syntax-apply (f . args) exp ...)
(f exp ... . args))))
(define-syntax if-symbol?
(syntax-rules ()
((if-symbol? (x . y) sk fk) fk)
((if-symbol? #(x ...) sk fk) fk)
((if-symbol? x sk fk)
(let-syntax ((test (syntax-rules ()
((test x sk* fk*) sk*)
((test non-x sk* fk*) fk*))))
(test foo sk fk)))))
(define-syntax add-temporaries
(syntax-rules ()
((add-temporaries lst k)
(add-temporaries lst () k))
((add-temporaries () done k)
(syntax-apply k done))
((add-temporaries (h . t) (pair ...) k)
(add-temporaries t (pair ... (h temp)) k))))
;=======================================================================
; Matcher.
(define (show x) x)
(define-syntax define-match-environment
(syntax-rules ()
((define-match-environment match)
(begin
(emit-match (=> else)
(((match ("extension") . rest)
(syntax-error "Match error" rest))
((match exp)
(error "No match for" (show exp)))
((match (x . y) . clauses)
(let ((val (x . y)))
(match val . clauses)))
((match val (pattern (=> fail) . template) . clauses)
(let ((fail (lambda () (match val . clauses))))
(match val
(pattern . template)
(else (fail)))))
((match val (else . template) . clauses)
(begin . template))
((match val (pattern . template) . clauses)
(match ("extension") val pattern
(begin . template)
(match val . clauses))))
match
())
))))
(define-syntax extend-matcher
(syntax-rules ()
((extend-matcher match literals value success failure
(pattern translation) ...)
(match ("extend") match
literals
((match ("extension") value pattern success failure)
translation)
...))))
(define-syntax with-patterns
(syntax-rules ()
((with-patterns match literals value success failure
((pattern translation) ...)
expr)
(match ("extend-lexical") match literals expr
((match ("extension") value pattern success failure)
translation)
...))))
(define-syntax emit-match
(syntax-rules ()
((emit-match literals
clauses
match
(new-literal ...)
new-clause ...)
(define-syntax match
(syntax-rules (new-literal ... . literals)
((match ("extend") match literals* . clauses*)
(emit-match (new-literal ... . literals)
(new-clause ... . clauses)
match
literals*
. clauses*))
((match ("extend-lexical") match literals* expr . clauses*)
(emit-match-lexical (new-literal ... . literals)
(new-clause ... . clauses)
match
literals*
expr
. clauses*))
new-clause ... . clauses)))))
(define-syntax emit-match-lexical
(syntax-rules ()
((emit-match-lexical literals
clauses
match
(new-literal ...)
expr
new-clause ...)
(letrec-syntax ((match
(syntax-rules (new-literal ... . literals)
((match ("extend") match literals* . clauses*)
(emit-match (new-literal ... . literals)
(new-clause ... . clauses)
match
literals*
. clauses*))
((match ("extend-lexical")
match
literals*
expr*
. clauses*)
(emit-match-lexical (new-literal ... . literals)
(new-clause ... . clauses)
match
literals*
expr*
. clauses*))
new-clause ... . clauses)))
expr))))
;==========================================================================
; Default match environment and extensions library:
(define-match-environment match)
(extend-matcher match () val sk fk
((x . y)
(syntax-error "Illegal pattern in clause" ((x . y) sk)))
(x
(if-symbol? x
(let ((x val)) sk)
(if (equal? x val)
sk
fk))))
(extend-matcher match (_) val sk fk
(_ sk))
(extend-matcher match (quote) val sk fk
('x
(if (equal? 'x val)
sk
fk)))
(extend-matcher match (cons) val sk fk
((cons pat1 pat2)
(let ((fail (lambda () fk)))
(if (pair? val)
(match (car val)
(pat1 (match (cdr val)
(pat2 sk)
(_ (fail))))
(_ (fail)))
(fail)))))
(extend-matcher match (list) val sk fk
((list)
(if (null? val)
sk
fk))
((list p . ps)
(let ((fail (lambda () fk)))
(if (pair? val)
(match (car val)
(p (match (cdr val)
((list . ps) sk)
(_ (fail))))
(_ (fail)))
(fail)))))
(extend-matcher match (quasiquote) val sk fk
(`pat (match-quasiquote val `pat sk fk)))
(define-syntax match-quasiquote
(syntax-rules (quasiquote unquote)
((match-quasiquote val `#(pat ...) sk fk)
(let ((fail (lambda () fk)))
(if (vector? val)
(match (vector->list val)
((list `pat ...) sk)
(_ (fail)))
(fail))))
((match-quasiquote val `,pat sk fk)
(match val
(pat sk)
(_ fk)))
((match-quasiquote val `(pat . pats) sk fk)
(let ((fail (lambda () fk)))
(if (pair? val)
(match (car val)
(`pat (match (cdr val)
(`pats sk)
(_ (fail))))
(_ (fail)))
(fail))))
((match-quasiquote val `pat sk fk)
(match val
('pat sk)
(_ fk)))))
; End of extensions library
;-----------------------------------------------------------------------------
;=============================================================================
; Examples:
(match '(1 2 3 4)
((list x y u v) (list x y u v))) ;==> (1 2 3 4)
(match (cons 1 2)
((cons x y) (list x y))) ;==> (1 2)
(match 1
(1 (=> next) (next))
(_ 2)) ;==> 2
(match `(if #f 0 1)
(`(if #t ,a ,b) a)
(`(if #f ,a ,b) b)) ;==> 1
(extend-matcher match (and) val sk fk
((and) sk)
((and pat . pats)
(let ((fail (lambda () fk)))
(match val
(pat (match val
((and . pats) sk)
(_ (fail))))
(_ (fail))))))
(match (cons 1 2)
((and (cons x y) z) (values x y z))) ;==> 1 2 (1 . 2)
(with-patterns match (?) val sk fk
(((? pred? . pats)
(let ((fail (lambda () fk)))
(if (pred? val)
(match val
((and . pats) sk)
(_ (fail)))
(fail)))))
(match 1
((? symbol? x) (list 'symbol x))
((? number? x) (list 'number x)))) ;==> (number 1)