main.rkt (4318B)
1 #lang typed/racket 2 3 (provide struct/props) 4 5 (require (for-syntax racket/syntax 6 racket/function 7 syntax/parse 8 syntax/stx 9 type-expander/expander)) 10 11 (begin-for-syntax 12 (define-syntax-rule (when-attr name . rest) 13 (if (attribute name) #`rest #'()))) 14 15 (define-syntax (struct/props stx) 16 (with-disappeared-uses 17 (syntax-parse stx 18 [(_ (~optional (~and polymorphic (T:id ...))) 19 name:id 20 (~optional parent:id) 21 ([field:id :colon type:type] ...) 22 (~or 23 (~optional (~and transparent #:transparent)) 24 (~optional (~seq #:property 25 (~literal prop:custom-write) 26 custom-write:expr)) 27 (~optional (~seq #:property 28 (~literal prop:equal+hash) 29 equal+hash:expr))) 30 ...) 31 (define poly? (and (attribute polymorphic) (not (stx-null? #'(T ...))))) 32 33 (define maybe-∀ 34 (if poly? 35 (λ (result-stx) #`(∀ (T ...) #,result-stx)) 36 (λ (result-stx) result-stx))) 37 38 (define/with-syntax (T2 ...) 39 (if poly? 40 (stx-map (λ (t) (format-id #'here "~a-2" t)) #'(T ...)) 41 #'(_unused))) 42 (define maybe-∀2 43 (if poly? 44 (λ (result-stx) #`(∀ (T ... T2 ...) #,result-stx)) 45 (λ (result-stx) result-stx))) 46 47 (define/with-syntax ins 48 (if poly? #'(name T ...) #'name)) 49 50 (define/with-syntax ins2 51 (if poly? #'(name T2 ...) #'name)) 52 53 (define/with-syntax PrinterType 54 (maybe-∀ #'(→ ins Output-Port (U #t #f 0 1) Any))) 55 (define/with-syntax ComparerType-Equal 56 (maybe-∀2 #'(→ ins ins2 (→ Any Any Boolean) Any))) 57 (define/with-syntax ComparerType-Hash1 58 (maybe-∀ #'(→ ins (→ Any Integer) Integer))) 59 (define/with-syntax ComparerType-Hash2 60 (maybe-∀ #'(→ ins (→ Any Integer) Integer))) 61 (define/with-syntax ComparerType 62 #'(List ComparerType-Equal 63 ComparerType-Hash1 64 ComparerType-Hash2)) 65 66 #`(begin 67 #,@(when-attr custom-write 68 (: printer PrinterType) 69 (: printer-implementation PrinterType) 70 (define (printer self port mode) 71 (printer-implementation self port mode))) 72 73 #,@(when-attr equal+hash 74 (: eq+h ComparerType) 75 (: eq+h-implementation (→ ComparerType)) 76 (define eq+h 77 (list (ann (λ (a b r) ((car (eq+h-implementation)) a b r)) 78 ComparerType-Equal) 79 (ann (λ (a r) ((cadr (eq+h-implementation)) a r)) 80 ComparerType-Hash1) 81 (ann (λ (a r) ((caddr (eq+h-implementation)) a r)) 82 ComparerType-Hash2)))) 83 84 (struct #,@(when-attr polymorphic (T ...)) 85 name 86 #,@(when-attr parent parent) 87 ([field : type] ...) 88 #,@(when-attr transparent #:transparent) 89 #,@(when-attr custom-write #:property prop:custom-write printer) 90 #,@(when-attr equal+hash #:property prop:equal+hash eq+h)) 91 92 #,@(when-attr custom-write 93 (define printer-implementation custom-write)) 94 95 #,@(when-attr equal+hash 96 #,(let () 97 (define/with-syntax equal+hash-ann 98 (syntax-parse #'equal+hash 99 [((~and list (~literal list)) equal? hash1 hash2) 100 #`(list (ann equal? 101 #,(maybe-∀2 102 #'(→ ins ins2 (→ Any Any Boolean) Any))) 103 (ann hash1 104 #,(maybe-∀ 105 #'(→ ins (→ Any Integer) Integer))) 106 (ann hash2 107 #,(maybe-∀ 108 #'(→ ins (→ Any Integer) Integer))))] 109 [expr:expr #'expr])) 110 #`(define eq+h-implementation (λ () equal+hash-ann)))))]))) 111