adt.rkt

#lang racket/base

(require (for-syntax racket/base
                     racket/syntax
                     syntax/parse)
         racket/contract
         racket/match)

(provide define-datatype)

(begin-for-syntax
  (define (make-pred id)
    (format-id id #:source id #:props id "~a?" id))

  (define-syntax-class type
    #:attributes [name name? definition]
    [pattern (name:id field:id ...+)
             #:attr name? (make-pred #'name)
             #:attr definition
             #'(struct name (field ...) #:transparent)]
    [pattern name:id
             #:attr name? (make-pred #'name)
             #:attr definition
             #'(begin
                 (struct internal () #:reflection-name 'name)
                 (define known-value (internal))
                 (define (name? v) (eq? v known-value))
                 (define-match-expander name
                   (syntax-parser [(_) #'(== known-value eq?)])
                   (syntax-parser [(_) #'(known-value)]
                                  [_ #'known-value])))]))

(define-syntax define-datatype
  (syntax-parser
    [(_ type-name:id data-constructor:type ...)
     #:with type-name? (make-pred #'type-name)
     #'(begin
         data-constructor.definition ...
         (define type-name?
           (flat-named-contract
            'type-name?
            (or/c data-constructor.name? ...))))]))