commit 63586ec1b982512ea1a97d0a697caf19cc5e848c
parent 6f815dd95e2fc562d2016dc82f3de6867bcf6cd4
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 28 Sep 2016 00:35:13 +0200
Compatibility with the type-expander library
Diffstat:
| M | info.rkt | | | 3 | ++- |
| M | main.rkt | | | 174 | ++++++++++++++++++++++++++++++++++++++++--------------------------------------- |
2 files changed, 90 insertions(+), 87 deletions(-)
diff --git a/info.rkt b/info.rkt
@@ -3,7 +3,8 @@
(define deps '("base"
"rackunit-lib"
"typed-racket-lib"
- "typed-racket-more"))
+ "typed-racket-more"
+ "type-expander"))
(define build-deps '("scribble-lib"
"racket-doc"
"typed-racket-doc"))
diff --git a/main.rkt b/main.rkt
@@ -5,105 +5,107 @@
(require (for-syntax racket/syntax
racket/function
syntax/parse
- syntax/stx))
+ syntax/stx
+ type-expander/expander))
(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-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 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 (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 ins
+ (if poly? #'(name T ...) #'name))
- (define/with-syntax ins2
- (if poly? #'(name T2 ...) #'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 Fixnum) Fixnum)))
- (define/with-syntax ComparerType-Hash2
- (maybe-∀ #'(→ ins (→ Any Fixnum) Fixnum)))
- (define/with-syntax ComparerType
- #'(List ComparerType-Equal
- ComparerType-Hash1
- ComparerType-Hash2))
+ (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 Fixnum) Fixnum)))
+ (define/with-syntax ComparerType-Hash2
+ (maybe-∀ #'(→ ins (→ Any Fixnum) Fixnum)))
+ (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)))
+ #`(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))))
+ #,@(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)
- fields
- #,@(when-attr transparent #:transparent)
- #,@(when-attr custom-write #:property prop:custom-write printer)
- #,@(when-attr equal+hash #:property prop:equal+hash eq+h))
+ (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 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 Fixnum) Fixnum)))
- (ann hash2
- #,(maybe-∀
- #'(→ ins (→ Any Fixnum) Fixnum))))]
- [expr:expr #'expr]))
- #`(define eq+h-implementation (λ () equal+hash-ann)))))]))
+ #,@(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 Fixnum) Fixnum)))
+ (ann hash2
+ #,(maybe-∀
+ #'(→ ins (→ Any Fixnum) Fixnum))))]
+ [expr:expr #'expr]))
+ #`(define eq+h-implementation (λ () equal+hash-ann)))))])))
