549ada06a6
The documentation does not promise that these will be fixnums. This is a problem for 7.5 where struct properties are now typechecked.
112 lines
4.2 KiB
Racket
112 lines
4.2 KiB
Racket
#lang typed/racket
|
|
|
|
(provide struct/props)
|
|
|
|
(require (for-syntax racket/syntax
|
|
racket/function
|
|
syntax/parse
|
|
syntax/stx
|
|
type-expander/expander))
|
|
|
|
(begin-for-syntax
|
|
(define-syntax-rule (when-attr name . rest)
|
|
(if (attribute name) #`rest #'())))
|
|
|
|
(define-syntax (struct/props stx)
|
|
(with-disappeared-uses
|
|
(syntax-parse stx
|
|
[(_ (~optional (~and polymorphic (T:id ...)))
|
|
name:id
|
|
(~optional parent:id)
|
|
([field:id :colon type:type] ...)
|
|
(~or
|
|
(~optional (~and transparent #:transparent))
|
|
(~optional (~seq #:property
|
|
(~literal prop:custom-write)
|
|
custom-write:expr))
|
|
(~optional (~seq #:property
|
|
(~literal prop:equal+hash)
|
|
equal+hash:expr)))
|
|
...)
|
|
(define poly? (and (attribute polymorphic) (not (stx-null? #'(T ...)))))
|
|
|
|
(define maybe-∀
|
|
(if poly?
|
|
(λ (result-stx) #`(∀ (T ...) #,result-stx))
|
|
(λ (result-stx) result-stx)))
|
|
|
|
(define/with-syntax (T2 ...)
|
|
(if poly?
|
|
(stx-map (λ (t) (format-id #'here "~a-2" t)) #'(T ...))
|
|
#'(_unused)))
|
|
(define maybe-∀2
|
|
(if poly?
|
|
(λ (result-stx) #`(∀ (T ... T2 ...) #,result-stx))
|
|
(λ (result-stx) result-stx)))
|
|
|
|
(define/with-syntax ins
|
|
(if poly? #'(name T ...) #'name))
|
|
|
|
(define/with-syntax ins2
|
|
(if poly? #'(name T2 ...) #'name))
|
|
|
|
(define/with-syntax PrinterType
|
|
(maybe-∀ #'(→ ins Output-Port (U #t #f 0 1) Any)))
|
|
(define/with-syntax ComparerType-Equal
|
|
(maybe-∀2 #'(→ ins ins2 (→ Any Any Boolean) Any)))
|
|
(define/with-syntax ComparerType-Hash1
|
|
(maybe-∀ #'(→ ins (→ Any Integer) Integer)))
|
|
(define/with-syntax ComparerType-Hash2
|
|
(maybe-∀ #'(→ ins (→ Any Integer) Integer)))
|
|
(define/with-syntax ComparerType
|
|
#'(List ComparerType-Equal
|
|
ComparerType-Hash1
|
|
ComparerType-Hash2))
|
|
|
|
#`(begin
|
|
#,@(when-attr custom-write
|
|
(: printer PrinterType)
|
|
(: printer-implementation PrinterType)
|
|
(define (printer self port mode)
|
|
(printer-implementation self port mode)))
|
|
|
|
#,@(when-attr equal+hash
|
|
(: eq+h ComparerType)
|
|
(: eq+h-implementation (→ ComparerType))
|
|
(define eq+h
|
|
(list (ann (λ (a b r) ((car (eq+h-implementation)) a b r))
|
|
ComparerType-Equal)
|
|
(ann (λ (a r) ((cadr (eq+h-implementation)) a r))
|
|
ComparerType-Hash1)
|
|
(ann (λ (a r) ((caddr (eq+h-implementation)) a r))
|
|
ComparerType-Hash2))))
|
|
|
|
(struct #,@(when-attr polymorphic (T ...))
|
|
name
|
|
#,@(when-attr parent parent)
|
|
([field : type] ...)
|
|
#,@(when-attr transparent #:transparent)
|
|
#,@(when-attr custom-write #:property prop:custom-write printer)
|
|
#,@(when-attr equal+hash #:property prop:equal+hash eq+h))
|
|
|
|
#,@(when-attr custom-write
|
|
(define printer-implementation custom-write))
|
|
|
|
#,@(when-attr equal+hash
|
|
#,(let ()
|
|
(define/with-syntax equal+hash-ann
|
|
(syntax-parse #'equal+hash
|
|
[((~and list (~literal list)) equal? hash1 hash2)
|
|
#`(list (ann equal?
|
|
#,(maybe-∀2
|
|
#'(→ ins ins2 (→ Any Any Boolean) Any)))
|
|
(ann hash1
|
|
#,(maybe-∀
|
|
#'(→ ins (→ Any Integer) Integer)))
|
|
(ann hash2
|
|
#,(maybe-∀
|
|
#'(→ ins (→ Any Integer) Integer))))]
|
|
[expr:expr #'expr]))
|
|
#`(define eq+h-implementation (λ () equal+hash-ann)))))])))
|
|
|