#lang typed-scheme (require (for-syntax scheme) (for-syntax syntax/struct) (for-syntax syntax/stx)) (provide define-constant define-datatype) (define-syntax (define-constant stx) (syntax-case stx (:) [(_ [value : Type]) (with-syntax ([Private (syntax-local-introduce #'Type)]) (with-syntax ([(struct:Private make-Private Private?) (build-struct-names #'Private '() #t #t #'Type)] [(struct:Type make-Type Type?) (build-struct-names #'Type '() #t #t #'Type)]) #'(begin (define-struct: Private ()) (define-type-alias Type Private) (: value Type) (define value (make-Private)) (: Type? (Any -> Boolean)) (define Type? Private?))))] [(_ clause1 clauses ...) #'(begin (define-constant clause1) (define-constant clauses ...))])) (define-syntax (define-datatype stx) (syntax-case stx () [(_ (Type a ...) [Variant Variant-clause ...] ...) (with-syntax ([(Variant-Type ...) (for/list ([variant (syntax->list #'(Variant ...))] [clause (syntax->list #'((Variant-clause ...) ...))]) (if (eq? (syntax->datum (stx-car clause)) '#:constant) variant (with-syntax ([V variant]) #'(V a ...))))]) #'(begin (define-variant Variant-Type Variant-clause ...) ... (define-type-alias (Type a ...) (U Variant-Type ...))))] [(_ Type [Variant Variant-clause ...] ...) #'(begin (define-variant Variant Variant-clause ...) ... (define-type-alias Type (U Variant ...)))])) (define-syntax define-variant (syntax-rules () [(_ (Variant a ...) (fields ...)) (define-struct: (a ...) Variant (fields ...))] [(_ Variant #:constant constant) (define-constant [constant : Variant])] [(_ Variant (fields ...)) (define-struct: Variant (fields ...))]))