83 lines
3.1 KiB
Racket
83 lines
3.1 KiB
Racket
#lang typed/racket
|
|
|
|
(provide struct/props)
|
|
|
|
(require (for-syntax racket/syntax
|
|
racket/function
|
|
syntax/parse
|
|
syntax/stx))
|
|
|
|
(begin-for-syntax
|
|
(define-syntax-rule (when-attr name . rest)
|
|
(if (attribute name) #`rest #'())))
|
|
|
|
(define-syntax struct/props
|
|
(syntax-parser
|
|
[(_ (~optional (~and polymorphic (T:id ...)))
|
|
name:id
|
|
(~optional parent:id)
|
|
(~and fields ([field:id (~literal :) 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))
|
|
|
|
#`(begin
|
|
#,@(when-attr custom-write
|
|
(: printer #,(maybe-∀ #'(→ ins Output-Port (U #t #f 0 1) Any)))
|
|
(define printer custom-write))
|
|
#,@(if (attribute 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]))
|
|
#`((: eq+h (List #,(maybe-∀2
|
|
#'(→ ins ins2 (→ Any Any Boolean) Any))
|
|
#,(maybe-∀
|
|
#'(→ ins (→ Any Integer) Integer))
|
|
#,(maybe-∀
|
|
#'(→ ins (→ Any Integer) Integer))))
|
|
(define eq+h equal+hash-ann)))
|
|
#'())
|
|
|
|
(struct #,@(when-attr polymorphic (T ...))
|
|
name
|
|
#,@(when-attr parent parent)
|
|
fields
|
|
#,@(when-attr transparent #:transparent)
|
|
#,@(when-attr custom-write #:property prop:custom-write printer)
|
|
#,@(when-attr equal+hash #:property prop:equal+hash eq+h)))]))
|
|
|