[plt-scheme] Dispatch by Pattern
I have put together a couple of mzscheme macros that allows one to define
procedures (and "multi-procedures") through pattern matching directly on the
arguments.
The standard way of defining procedures in Scheme may be interpreted as
simple pattern matching. For example, the form (x y) in (lambda (x y) ...)
may be seen as a pattern for matching and deconstructing a list of
arguments. The macros below are a logical extension to this and allows us
to specify more sophisticated patterns in argument lists.
There are two components to the extension:
1) Pattern matching in procedure arguments - this part
relies on the MzScheme built-in pattern matching facility
match.ss based on an original by Duba and Wright.
2) When a definition is encountered for an already existing procedure
but with a new argument pattern, the new case is added to the
existing procedure.
The macros redefine the following forms (without runtime overhead if you
don't use patterns):
define
lambda
case-lambda
and introduces a form
case-define
Examples of use:
; We start with something simple:
(define (f 1) 'one)
(define (f 2) 'two)
(f 1) ;=> 'one
(f 2) ;=> 'two
; Pattern matching on a list:
(define (my-car (first . rest))
first)
(my-car '(1 2 3)) ;=> 1
;The canonical factorial (the second "fact" may be replaced
;by _ for brevity):
(case-define
[(fact 0) 1]
[(fact n) (* n (fact (- n 1)))])
;This also works (but note that the last "define" case is tested
;first, so we have to put the more specific case last).
(define (fact n) (* n (fact (- n 1))))
(define (fact 0) 1)
;Lambda and case-lambda now work with patterns:
(define fact
(case-lambda [(0) 1]
[(n) (* n (fact (- n 1)))]))
;"Multimethods":
;Let's polymorphically extend +: First, define + on strings (never
;mind that string-append is not commutative).
(define (+ (? string? s1)
(? string? s2))
(string-append s1 s2))
;Now let's define + elementwise on lists of numbers (or lists of
;strings for that matter):
(define (+ () ())
())
(define (+ (first1 . rest1)
(first2 . rest2))
(cons (+ first1 first2)
(+ rest1 rest2)))
;Now we can test it:
(+ 1 2) ;=> 3
(+ '(1 2 3) '(4 5 6)) ;=> '(5 7 9)
(+ "poly" "morphic") ;=> "polymorphic"
; Example that matches on structs:
; Define tree data structure:
(define-struct node (left right))
(define-struct leaf (contents))
(define-struct empty ())
(case-define
[(list->tree ()) (make-empty)]
[(_ (first . rest)) (make-node (list->tree first)
(list->tree rest))]
[(_ atom) (make-leaf atom)])
(case-define
[(tree->list ($ empty)) ()]
[(_ ($ leaf contents)) contents]
[(_ ($ node left right)) (cons (tree->list left)
(tree->list right))])
(tree->list (list->tree '(((1) 2) . 3))) ;=> '(((1) 2) . 3))
Regards
Andre
;; The macros:
;; Put in collects/mzscheme. Import statement is
;; (require (lib "pattern-dispatch.ss" "mzscheme"))
(module pattern-dispatch mzscheme
(provide (rename define* define)
(rename case-define* case-define)
(rename lambda* lambda)
(rename case-lambda* case-lambda))
(require-for-syntax (lib "list.ss"))
(require (lib "etc.ss")
(lib "match.ss"))
;; Execute body, catching all errors and returning `#f' if one occurred.
;; If no errors, return value of body.
;; Snippet copied from Eli Barzilay's code.
(define-syntax no-errors
(syntax-rules ()
[(_ <body>)
(with-handlers ((void (lambda (x) #f))) <body>)]))
(define-syntax-set (define* case-define* lambda* case-lambda*)
;; define* expands to define in all the non-pattern cases.
(define define*/proc
(lambda (stx)
(syntax-case stx ()
[(_ (<f> . <arglist>) <expr> ...)
(andmap symbol? (improper->proper
(syntax-object->datum #'<arglist>)))
#'(define (<f> . <arglist>) <expr> ...)]
[(_ (<f> <arg>) <expr> ...)
#'(begin
(define <f> (if (no-errors (procedure? <f>))
(let ([next-method <f>])
(case-lambda* [(<arg>) <expr> ...]
[(x) (next-method x)]))
(lambda* (<arg>) <expr> ...))))]
[(_ (<f> . <arglist>) <expr> ...)
#'(begin
(define <f> (if (no-errors (procedure? <f>))
(let ([next-method <f>])
(case-lambda* [<arglist> <expr> ...]
[x (apply next-method x)]))
(lambda* <arglist> <expr> ...))))]
[(_ <identifier> <expr> ...)
#'(define <identifier> <expr> ...)])))
(define case-define*/proc
(lambda (stx)
(syntax-case stx ()
[(_ [<expr> ...])
#'(define* <expr> ...)]
[(_ [(<f> <arg>) <expr> ...]
...)
(with-syntax ([name (car (syntax-e #'(<f> ...)))])
#'(begin
(define name (if (no-errors (procedure? name))
(let ([next-method name])
(case-lambda* [(<arg>) <expr> ...]
...
[(x) (next-method
x)]))
(case-lambda* [(<arg>) <expr> ...]
...)))))]
[(_ [(<f> . <arglist>) <expr> ...]
...)
(with-syntax ([name (car (syntax-e #'(<f> ...)))])
#'(begin
(define name (if (no-errors (procedure? name))
(let ([next-method name])
(case-lambda* [<arglist> <expr> ...]
...
[x (apply next-method
x)]))
(case-lambda* [<arglist> <expr> ...]
...)))))])))
;; lambda* expands to lambda in all the non-pattern cases.
(define lambda*/proc
(lambda (stx)
(syntax-case stx ()
[(_ <arglist> <expr> ...)
(andmap symbol? (improper->proper
(syntax-object->datum #'<arglist>)))
#'(lambda <arglist> <expr> ...)]
[(_ (<pat>) <expr> ...)
#'(match-lambda
[<pat> <expr> ...])]
[(_ (<pat> . <rest>) <expr> ...)
#'(match-lambda*
[(<pat> . <rest>) <expr> ...])])))
;; case-lambda* expands to case-lambda in all the non-pattern cases.
(define case-lambda*/proc
(lambda (stx)
(syntax-case stx ()
[(_ [<arglist> <expr> ...])
#'(lambda* <arglist> <expr> ...)]
[(_ [<arglist> <expr> ...]
...)
(andmap symbol? (apply append (map improper->proper
(syntax-object->datum
#'(<arglist> ...)))))
#'(case-lambda [<arglist> <expr> ...]
...)]
[(_ [(<pat>) <expr> ...]
...)
#'(match-lambda
[<pat> <expr> ...]
...)]
[(_ [<arglist> <expr> ...]
...)
#'(match-lambda*
[<arglist> <expr> ...]
...)])))
(define (improper->proper x)
(cond [(null? x) null]
[(not (pair? x)) (list x)]
[else (cons (car x)
(improper->proper (cdr x)))]))
) ;; end syntax-set
) ;; end module
![[logo]](/logo.png){kind=logo}