#lang typed/racket/base (require racket/require phc-toolkit phc-adt (for-syntax racket/base phc-toolkit/untyped racket/syntax racket/format syntax/parse syntax/parse/experimental/template type-expander/expander "free-identifier-tree-equal.rkt") (for-meta 2 racket/base) (for-meta 2 phc-toolkit/untyped) (for-meta 2 syntax/parse)) (provide dispatch-union) (define-syntax/parse (dispatch-union v ([type-to-replaceᵢ Aᵢ predicateᵢ] …) [Xⱼ resultⱼ] …) (define-syntax-class to-replace (pattern [t result] #:with (_ predicate) (findf (λ (r) (free-id-tree=? #'t (stx-car r))) (syntax->list #'([type-to-replaceᵢ predicateᵢ] …))) #:with clause #`[(predicate v) result])) (define-syntax-class tagged #:literals (tagged) (pattern [(tagged name [fieldₖ (~optional :colon) typeₖ] …) result] #:with clause #`[((tagged? name fieldₖ …) v) result])) (define-syntax-class other (pattern [other result] #:with clause #`[else result])) ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x) (syntax-parse #'([Xⱼ resultⱼ] …) [({~or to-replace:to-replace tagged:tagged {~between other:other 0 1 #:too-many (~a "only one non-tagged type can be part of" " the union")}} …) (quasisyntax/top-loc stx (cond to-replace.clause … tagged.clause … other.clause …))])))