suzanne.soy/typed-struct-props
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Declare the property implementations after the struct declaration, so that things like struct-copy work in the properties.

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-14 21:48:09 +02:00
parent 122587f6ea
commit 16b5cd4ba4
1 changed files with 51 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
main.rkt
View File

@ -19,8 +19,12 @@
(~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)))
(~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 ...)))))
@ -46,10 +50,50 @@
#`(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-type PrinterType
#,(maybe-∀ #'(→ ins Output-Port (U #t #f 0 1) Any)))
(: printer PrinterType)
(: printer-implementation PrinterType)
(define (printer self port mode)
(printer-implementation self port mode)))
#,@(when-attr equal+hash
(define-type ComparerType-Equal
#,(maybe-∀2
#'(→ ins ins2 (→ Any Any Boolean) Any)))
(define-type ComparerType-Hash1
#,(maybe-∀
#'(→ ins (→ Any Fixnum) Fixnum)))
(define-type ComparerType-Hash2
#,(maybe-∀
#'(→ ins (→ Any Fixnum) Fixnum)))
(define-type ComparerType
(List ComparerType-Equal
ComparerType-Hash1
ComparerType-Hash2))
(: 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)
fields
#,@(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)
@ -63,20 +107,5 @@
#,(maybe-∀
#'(→ ins (→ Any Fixnum) Fixnum))))]
[expr:expr #'expr]))
#`((: eq+h (List #,(maybe-∀2
#'(→ ins ins2 (→ Any Any Boolean) Any))
#,(maybe-∀
#'(→ ins (→ Any Fixnum) Fixnum))
#,(maybe-∀
#'(→ ins (→ Any Fixnum) Fixnum))))
(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)))]))
#`(define eq+h-implementation (λ () equal+hash-ann)))))]))