commit 16b5cd4ba494e93750749775120080cea79a41c7
parent 122587f6eaea04ac2ff51d9245b20b70bc1b2b14
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 14 Sep 2016 21:48:09 +0200
Declare the property implementations after the struct declaration, so that things like struct-copy work in the properties.
Diffstat:
| M | main.rkt | | | 73 | +++++++++++++++++++++++++++++++++++++++++++++++++++---------------------- |
1 file changed, 51 insertions(+), 22 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -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)))))]))
