Some anon in the MIT pattern matching thread was mulling over a pattern matching that preserves the abstraction layers. It reminded me when I was trying to do pattern matching in Java using the visitor pattern. Maybe in Scheme it would be possible to do it nicely?
I've put together a prototype in Guile using GOOPS. It's lacks everything that would make it practical, but it preserves the abstraction layer. When matching, the object receives a `visitor' in the form of a curried function and it can decide what kind of information it wants to feed it.
;;; 20% solution to encapsulated pattern matching using Guile's GOOPS.
;;;
;;; Released to the public domain.
;;;
(use-modules (oop goops)
(oop goops describe))
;; For this to work, every class you want to match on will have to
;; implement its own `accept-visitor' method. In this it can feed
;; anything it wants to a curried function. See the example below.
;; Build a visitor to match on objects.
(define (build-matcher pattern exit)
(cond
((not (or (pair? pattern) (null? pattern)))
(error "Malformed pattern!" pattern))
;; If we have ran out of patterns, we either succeeded or can't
;; match anymore.
((null? pattern)
(lambda args (or (null? args) (exit #f))))
;; A symbol always matches.
((symbol? (car pattern))
(lambda v
(if (and (pair? v) (null? (cdr v)))
(build-matcher (cdr pattern) exit)
(exit #f))))
;; Special case: quoting.
((and (pair? (car pattern)) (eq? (caar pattern) 'quote)
(pair? (cdar pattern)) (null? (cddar pattern)))
(lambda v
(if (and (pair? v) (null? (cdr v)))
(if (eq? (car v) (cadar pattern))
(build-matcher (cdr pattern) exit)
(exit #f)))))
;; Atoms other than symbols match if they are eq?.
((not (or (pair? (car pattern)) (null? (car pattern))))
(lambda v
(if (and (pair? v) (null? (cdr v)))
(if (eq? (car v) (car pattern))
(build-matcher (cdr pattern) exit)
(exit #f))
(exit #f))))
;; Node patterns.
((pair? (car pattern))
(lambda v
(if (and (pair? v) (null? (cdr v)))
(let ((result ((accept-visitor (build-matcher (car pattern) exit) (car v)))))
(when result (build-matcher (cdr pattern) exit)))
(exit #f))))
(else (error "Malformed pattern!" pattern))))
;; Does the value (object) match the pattern?
(define (goops-matches? pattern value)
(call-with-current-continuation
(lambda (k)
((accept-visitor (build-matcher pattern k) value)))))
;; Construct a visitor to extract values from an object hierarchy.
(define-syntax construct-extractor
(lambda (x)
(syntax-case x (quote)
((_ () body ...)
#'(begin body ...))
((_ ((quote _ ...) p ...) body ...)
#'(lambda (skip)
(construct-extractor (p ...) body ...)))
((_ ((p' ...) p ...) body ...)
#'(lambda (node)
(accept-visitor
(construct-extractor (p' ...)
(construct-extractor (p ...)
body ...))
node)))
((_ (v p ...) body ...)
(if (symbol? (syntax->datum #'v))
#'(lambda (v)
(construct-extractor (p ...) body ...))
#'(lambda (skip)
(construct-extractor (p ...) body ...)))))))
;; Do the matching and extracting in one convenient(?) macro.
(define-syntax goops-match
(syntax-rules (_)
((goops-match v
((p ...) b ...)
rest ...)
(if (goops-matches? '(p ...) v)
(accept-visitor (construct-extractor (p ...) b ...) v)
(goops-match v rest ...)))
((goops-match v
(_ b ...))
(begin b ...))
((goops-match v)
(error "failed to match" (describe v)))))
;; Example: object-oriented lists.
(define-class <g-list> ())
(define-class <g-nil> (<g-list>))
(define-class <g-cons> (<g-list>)
(car #:init-keyword #:car)
(cdr #:init-keyword #:cdr))
(define (apply+ f . args)
(let repeat ((f f) (args args))
(cond
((null? args) f)
(else (repeat (f (car args)) (cdr args))))))
(define-method (accept-visitor v (n <g-nil>))
(apply+ v '<g-nil>))
(define-method (accept-visitor v (c <g-cons>))
(apply+ v '<g-cons> (slot-ref c 'car) (slot-ref c 'cdr)))
(define example
(make <g-cons> #:car 1 #:cdr (make <g-cons> #:car 2 #:cdr (make <g-nil>))))
(define (list->g-list l)
(cond
((null? l) (make <g-nil>))
(else (make <g-cons> #:car (car l) #:cdr (list->g-list (cdr l))))))
(define (g-even-length? l)
(goops-match l
(('<g-nil>) #t)
(('<g-cons> h0 ('<g-cons> h1 t)) (g-even-length? t))
(_ #f)))
(define (g-zip l1 l2)
(goops-match (make <g-cons> #:car l1 #:cdr l2)
(('<g-cons> ('<g-nil>) ('<g-nil>)) (make <g-nil>))
(('<g-cons> ('<g-cons> h0 t0) ('<g-cons> h1 t1))
(make <g-cons>
#:car (make <g-cons> #:car h0 #:cdr h1)
#:cdr (g-zip t0 t1)))))
(define example2 (g-zip example example))
(define (display-zipped-g-list l)
(goops-match l
(('<g-nil>) (display "())") (newline))
(('<g-cons> ('<g-cons> h0 h1) t)
(display "((")
(display h0)
(display " . ")
(display h1)
(display ") . ")
(display-zipped-g-list t))))
(display-zipped-g-list example2)
(display-zipped-g-list
(g-zip (list->g-list (iota 10))
(list->g-list (map (lambda (x) (+ 1 x)) (iota 10)))))
;; (put 'goops-match 'scheme-indent-function 1)
;; (put 'construct-extractor 'scheme-indent-function 1)