views.ss
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; views.ss
;;
;; Richard Cobbe
;; cobbe@ccs.neu.edu
;; Version 1.1
;; August 2006
;;
;; This module defines and exports two macros useful for creating
;; pattern-matching views.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module views mzscheme

  (require (lib "plt-match.ss"))

  (define-match-expander view
    (lambda (stx)
      (syntax-case stx ()
        [(_ pred? ([selector pattern] ...))
         #'(? pred? (app selector pattern) ...)]))
    (lambda (stx)
      (syntax-case stx ()
        [(_ pred? ([selector pattern] ...))
         #'(? pred? (= selector pattern) ...)]))
    (lambda (stx)
      (raise-syntax-error #f "may only be used as match pattern" stx)))

  (define-syntax define-view
    (lambda (stx)
      (syntax-case stx ()
        [(_ view-name pred? (selector ...))
         (identifier? #'view-name)
         (with-syntax ([(pattern-var ...)
                        (generate-temporaries #'(selector ...))]
                       [(pred-var) (generate-temporaries #'(pred?))]
                       [(selector-var ...)
                        (generate-temporaries #'(selector ...))])
           #'(begin
               (define pred-var pred?)
               (define selector-var selector) ...
               (define-match-expander view-name
                 (lambda (stx)
                   (syntax-case stx ()
                     [(_ pattern-var ...)
                      #'(? pred-var (app selector-var pattern-var) ...)]))
                 (lambda (stx)
                   (syntax-case stx ()
                     [(_ pattern-var ...)
                      #'(? pred-var (= selector-var pattern-var) ...)]))
                 (lambda (stx)
                   (raise-syntax-error #f
                                       "may only be used as match pattern"
                                       stx)))))]
        [(_ bad-name pred? (selector ...))
         (raise-syntax-error #f "bad view name" stx #'bad-name)]
        [_
         (raise-syntax-error
          #f
          "bad view defn: expected (define-view view-name pred? (selector ...))"
          stx)])))

  (provide view define-view))