(begin-for-syntax

(define-syntax-class constructor-or-tagged

(pattern [constructor-name:id . (~or ([field:id C:colon type:expr] …)

(type:expr …))])))

(define-type-expander (variant stx)

(syntax-parse stx

[(_ :constructor-or-tagged …)

(template

(U (?? (tagged constructor-name [field C type] …)

(constructor constructor-name type …))

…))]))

(define-syntax/parse (variant? :constructor-or-tagged …)

(template

(λ (v) (or (?? ((tagged? constructor-name field …) v)

(constructor? constructor-name v))

…))))

(define-syntax/parse

(define-variant variant-name

(~optkw #:debug)

(~maybe #:? name?)

(~maybe #:match variant-match)

(~and constructor-or-tagged :constructor-or-tagged) …)

(define/with-syntax default-name? (format-id #'name "~a?" #'name))

(define/with-syntax default-match (format-id #'name "~a-match" #'name))

(define-temp-ids "pat" ((type …) …))

(define-temp-ids "match-body" (constructor-name …))

(template

(begin

(define-type variant-name

(variant [constructor-name (?? ([email protected] [field C type] …)

([email protected] type …))]

…))

(define-syntax (?? variant-match default-match)

(syntax-rules (constructor-name … (?? ([email protected] field …)) …)

[(_ v

[(constructor-name (?? ([email protected] [field pat] …)

(pat …)))

. match-body]

…)

(match v

(?? [(tagged constructor-name [field pat] …) . match-body]

[(constructor constructor-name pat …) . match-body])

…)]))

(define-multi-id (?? name? default-name?)

#:else

#'(variant? constructor-or-tagged …)))))

(require (for-syntax racket/base

racket/list

syntax/parse

syntax/parse/experimental/template

racket/syntax

phc-toolkit/untyped

type-expander/expander)

phc-toolkit

multi-id

type-expander

"constructor.hl.rkt"

"structure.hl.rkt")

(provide variant

variant?

define-variant)

«constructor-or-tagged-stx-class»

«variant»

«variant?»

«define-variant»