;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; views.ss
;;
;; Richard Cobbe
;; cobbe@ccs.neu.edu
;; Version 2.1
;; August 2008
;;
;; This module defines and exports the `define-view' macro for creating
;; pattern-matching views, and the `view' pattern constructor for creating
;; anonymous views.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#lang scheme

(require scheme/match)

(provide view define-view)

(define-match-expander view
  (lambda (stx)
    (syntax-case stx ()
      [(_ pred? ([selector pattern] ...))
       #'(? pred? (app 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)
                 (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)])))