dispatch-union.rkt (1858B)
1 #lang typed/racket/base 2 3 (require racket/require 4 phc-toolkit 5 phc-adt 6 (for-syntax racket/base 7 phc-toolkit/untyped 8 racket/syntax 9 racket/format 10 syntax/parse 11 syntax/parse/experimental/template 12 type-expander/expander 13 "free-identifier-tree-equal.rkt") 14 (for-meta 2 racket/base) 15 (for-meta 2 phc-toolkit/untyped) 16 (for-meta 2 syntax/parse)) 17 18 (provide dispatch-union) 19 20 (define-syntax/parse (dispatch-union v 21 ([type-to-replaceᵢ Aᵢ predicateᵢ] …) 22 [Xⱼ resultⱼ] …) 23 (define-syntax-class to-replace 24 (pattern [t result] 25 #:with (_ predicate) 26 (findf (λ (r) (free-id-tree=? #'t (stx-car r))) 27 (syntax->list 28 #'([type-to-replaceᵢ predicateᵢ] …))) 29 #:with clause #`[(predicate v) result])) 30 31 (define-syntax-class tagged 32 #:literals (tagged) 33 (pattern [(tagged name [fieldₖ (~optional :colon) typeₖ] …) result] 34 #:with clause #`[((tagged? name fieldₖ …) v) result])) 35 36 (define-syntax-class other 37 (pattern [other result] 38 #:with clause #`[else result])) 39 40 ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x) 41 (syntax-parse #'([Xⱼ resultⱼ] …) 42 [({~or to-replace:to-replace 43 tagged:tagged 44 {~between other:other 0 1 45 #:too-many (~a "only one non-tagged type can be part of" 46 " the union")}} 47 …) 48 (quasisyntax/top-loc stx 49 (cond 50 to-replace.clause … 51 tagged.clause … 52 other.clause …))])))