#lang scheme
(require (for-syntax scheme/match scheme/struct-info "define.ss" "syntax.ss"))

(define-syntax-rule (match? e p ...)
  (match e [p #t] ... [_ #f]))

(define-syntax (define-struct-pattern stx)
  (parameterize ([current-syntax stx])
    (syntax-case stx ()
      [(_ pattern-name struct-name)
       (block

        (define pattern-id #'pattern-name)
        (define struct-id #'struct-name)

        (unless (identifier? pattern-id)
          (syntax-error pattern-id "expected an identifier"))

        (unless (identifier? struct-id)
          (syntax-error struct-id "expected an identifier"))

        (define struct-info (syntax-local-value struct-id))

        (unless (struct-info? struct-info)
          (syntax-error struct-id "expected a struct name"))

        (match (extract-struct-info struct-info)
          [(list type-id
                 constructor-id
                 predicate-id
                 accessor-ids
                 mutator-ids
                 super-id)
           (with-syntax ([make constructor-id]
                         [(p ...) (generate-temporaries accessor-ids)])
             (syntax/loc stx
               (define-match-expander pattern-name
                 (syntax-rules ()
                   [(_ p ...) (struct struct-name [p ...])])
                 (redirect-transformer #'make))))]))])))

(provide match? define-struct-pattern)