suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove duplication of type-variable duplicate detection.

Browse Source
This commit is contained in:
Eric Dobson 2013-05-25 11:33:26 -07:00
parent dce13a36b9
commit 1bcdeaea24
1 changed files with 26 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/typed-racket/base-env/prims.rkt
View File

@ -309,40 +309,45 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax/loc stx (define-type-alias ty (Opaque pred)))) (syntax/loc stx (define-type-alias ty (Opaque pred))))
#,(ignore-property #'(require/contract pred hidden pred-cnt lib) #t))))])) #,(ignore-property #'(require/contract pred hidden pred-cnt lib) #t))))]))
(begin-for-syntax
(define-syntax-class type-variables
#:attributes ((vars 1))
#:description "a sequence of type variables"
(pattern (vars:id ...)
#:fail-when (check-duplicate-identifier (syntax->list #'(vars ...)))
"duplicate type variable declaration")))
(define-syntax (plambda: stx) (define-syntax (plambda: stx)
(syntax-parse stx (syntax-parse stx
[(plambda: (tvars:id ...) formals . body) [(plambda: tvars:type-variables formals . body)
#:fail-when (check-duplicate-identifier (syntax->list #'(tvars ...)))
"duplicate type variable declaration"
(quasisyntax/loc stx (quasisyntax/loc stx
(#%expression (#%expression
#,(plambda-property (syntax/loc stx (lambda: formals . body)) #,(plambda-property
#'(tvars ...))))])) (syntax/loc stx (lambda: formals . body))
#'(tvars.vars ...))))]))
(define-syntax (pcase-lambda: stx) (define-syntax (pcase-lambda: stx)
(syntax-parse stx (syntax-parse stx
[(pcase-lambda: (tvars:id ...) cl ...) [(pcase-lambda: tvars:type-variables cl ...)
#:fail-when (check-duplicate-identifier (syntax->list #'(tvars ...)))
"duplicate type variable declaration"
(quasisyntax/loc stx (quasisyntax/loc stx
(#%expression (#%expression
#,(plambda-property (syntax/loc stx (case-lambda: cl ...)) #,(plambda-property
#'(tvars ...))))])) (syntax/loc stx (case-lambda: cl ...))
#'(tvars.vars ...))))]))
(define-syntax (popt-lambda: stx) (define-syntax (popt-lambda: stx)
(syntax-parse stx (syntax-parse stx
[(popt-lambda: (tvars:id ...) formals . body) [(popt-lambda: tvars:type-variables formals . body)
#:fail-when (check-duplicate-identifier (syntax->list #'(tvars ...)))
"duplicate type variable declaration"
(quasisyntax/loc stx (quasisyntax/loc stx
(#%expression (#%expression
#,(plambda-property (syntax/loc stx (opt-lambda: formals . body)) #,(plambda-property
#'(tvars ...))))])) (syntax/loc stx (opt-lambda: formals . body))
#'(tvars.vars ...))))]))
(define-syntax (pdefine: stx) (define-syntax (pdefine: stx)
(syntax-parse stx #:literals (:) (syntax-parse stx #:literals (:)
[(pdefine: (tvars:id ...) (nm:id . formals:annotated-formals) : ret-ty . body) [(pdefine: tvars:type-variables (nm:id . formals:annotated-formals) : ret-ty . body)
(with-syntax ([type (syntax/loc #'ret-ty (All (tvars ...) (formals.arg-ty ... -> ret-ty)))]) (with-syntax ([type (syntax/loc #'ret-ty (All (tvars.vars ...) (formals.arg-ty ... -> ret-ty)))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(: nm : type) (: nm : type)
@ -374,14 +379,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
(identifier? #'nm) (identifier? #'nm)
(with-syntax ([new-nm (type-label-property #'nm #'ty)]) (with-syntax ([new-nm (type-label-property #'nm #'ty)])
(syntax/loc stx (define new-nm body)))] (syntax/loc stx (define new-nm body)))]
[(define: (tvars:id ...) nm:id : ty body) [(define: tvars:type-variables nm:id : ty body)
(with-syntax ([type (syntax/loc #'ty (All (tvars ...) ty))]) (with-syntax ([type (syntax/loc #'ty (All (tvars.vars ...) ty))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(: nm : type) (: nm : type)
(define nm body))))] (define nm body))))]
[(define: (tvars:id ...) (nm:id . formals:annotated-formals) : ret-ty body ...) [(define: tvars:type-variables (nm:id . formals:annotated-formals) : ret-ty body ...)
(with-syntax ([type (syntax/loc #'ret-ty (All (tvars ...) (formals.arg-ty ... -> ret-ty)))]) (with-syntax ([type (syntax/loc #'ret-ty (All (tvars.vars ...) (formals.arg-ty ... -> ret-ty)))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(: nm : type) (: nm : type)