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

Added support for configurable constructor names in require/typed.

Browse Source 
Closes PR11171. Closes PR11194. Closes PR11314.
This commit is contained in:
Eric Dobson 2011-06-28 10:43:10 -04:00 committed by Vincent St-Amour
parent e367f1d0f2
commit f3692eae29
15 changed files with 235 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/tests/typed-scheme/succeed/pr11171.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang racket/load
(module UNTYPED racket/base
(struct IntTree
(elem left right))
(provide (struct-out IntTree)))
(module TYPED typed/racket
(require/typed 'UNTYPED
[struct IntTree
([elem : Integer]
[left : IntTree]
[right : IntTree])]))

14
collects/tests/typed-scheme/succeed/pr11194.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang racket/load
(module untyped racket
(struct foo (bar baz))
(define f (lambda (x) (+ (foo-baz x) 3)))
(provide [struct-out foo]
f))
(module typed typed/racket
(require/typed 'untyped
[struct foo ([bar : Number] [baz : String])]))
(require 'typed)

16
collects/tests/typed-scheme/succeed/pr11314.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/load
(module A racket
(define-struct point [x y])
(point 1 2)
(provide (all-defined-out)))
(module B typed/racket
(require/typed 'A
[struct point ([x : Integer] [y : Integer])])
(point 1 2)
(struct: pt ([x : Integer] [y : Integer]))
(pt 1 2))
(require 'A)
(require 'B)

31
collects/tests/typed-scheme/succeed/require-struct.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/load
(module untyped racket
(provide (all-defined-out))
(struct a (v))
(struct b a (v))
(struct c (v) #:constructor-name c-maker)
(struct d c (v) #:constructor-name d-maker)
(define-struct e (v))
(define-struct (f e) (v)))
(module typed typed/racket
(require/typed 'untyped
(struct a ((v : Integer)))
#;(struct (b a) ((v : String)))
(struct c ((v : Integer)) #:constructor-name c-maker)
#;(struct (d c) ((v : String)) #:constructor-name d-maker)
(struct e ((v : Integer)) #:extra-constructor-name make-e)
#;(struct (f e) ((v : String)) #:extra-constructor-name make-f))
(a 0)
;(b 1 "2")
(c-maker 3)
;(d-maker 4 "5")
(make-e 6)
;(make-f 7 "8")
(e 9)
#;(f 10 "11"))
(require 'typed)

4
collects/tests/typed-scheme/succeed/require-substruct.rkt
View File

@ -6,8 +6,8 @@
(provide (all-defined-out)))
(module n typed-scheme
(require-typed-struct X ([x : Number]) 'm)
(require-typed-struct (Y X) ([y : Number]) 'm)
(require-typed-struct X ([x : Number]) #:extra-constructor-name make-X 'm)
(require-typed-struct (Y X) ([y : Number]) #:extra-constructor-name make-Y 'm)
(make-X 43)
(define: x : Any 3)
(if (Y? x)

2
collects/tests/typed-scheme/succeed/rts-prov.rkt
View File

@ -5,7 +5,7 @@
(provide (all-defined-out)))
(module m typed-scheme
(require-typed-struct q () 'l)
(require-typed-struct q () #:extra-constructor-name make-q 'l)
(provide (all-defined-out)))
(module n typed-scheme

2
collects/tests/typed-scheme/succeed/struct-out.rkt
View File

@ -1,3 +1,3 @@
#lang typed-scheme
(require-typed-struct posn ([x : Number] [y : Number]) lang/posn)
(require-typed-struct posn ([x : Number] [y : Number]) #:extra-constructor-name make-posn lang/posn)
(provide (struct-out posn))

112
collects/typed-scheme/base-env/prims.rkt
View File

@ -67,11 +67,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax-class simple-clause
#:attributes (nm ty)
(pattern [nm:opt-rename ty]))
(define-splicing-syntax-class opt-constructor
(pattern (~optional (~seq (~or #:extra-constructor-name #:constructor-name) name:id))))
(define-syntax-class struct-clause
;#:literals (struct)
#:attributes (nm (body 1))
(pattern [struct nm:opt-rename (body ...)]
#:fail-unless (eq? 'struct (syntax-e #'struct)) #f))
#:attributes (nm (body 1) (constructor-parts 1))
(pattern [struct nm:opt-rename (body ...) constructor:opt-constructor]
#:fail-unless (eq? 'struct (syntax-e #'struct)) #f
#:with (constructor-parts ...) #'constructor))
(define-syntax-class opaque-clause
;#:literals (opaque)
#:attributes (ty pred opt)
@ -85,10 +89,10 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ lib:expr (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
(unless (< 0 (length (syntax->list #'(sc ... strc ... oc ...))))
(raise-syntax-error #f "at least one specification is required" stx))
#'(begin
#`(begin
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
(require/typed #:internal sc.nm sc.ty lib) ...
(require-typed-struct strc.nm (strc.body ...) lib) ...)]
(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... lib) ...)]
[(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
#`(require/typed #:internal nm ty lib #,@(if (attribute parent)
#'(#:struct-maker parent)
@ -377,48 +381,90 @@ This file defines two sorts of primitives. All of them are provided into any mod
[dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
#'(begin d-s dtsi)))])))))
;Copied from racket/private/define-struct
(define-for-syntax (self-ctor-transformer orig stx)
(define (transfer-srcloc orig stx)
(datum->syntax orig (syntax-e orig) stx orig))
(syntax-case stx ()
[(self arg ...) (datum->syntax stx
(cons (syntax-property (transfer-srcloc orig #'self)
'constructor-for
(syntax-local-introduce #'self))
(syntax-e (syntax (arg ...))))
stx
stx)]
[_ (transfer-srcloc orig stx)]))
(define-for-syntax make-struct-info-self-ctor
(let ()
(struct struct-info-self-ctor (id info)
#:property prop:procedure
(lambda (ins stx)
(self-ctor-transformer (struct-info-self-ctor-id ins) stx))
#:property prop:struct-info (lambda (x) (extract-struct-info (struct-info-self-ctor-info x))))
struct-info-self-ctor))
(define-syntax (require-typed-struct stx)
(define-syntax-class opt-parent
(pattern nm:id #:attr parent #'#f)
(pattern (nm:id parent:id)))
(define-splicing-syntax-class constructor-term
(pattern (~seq) #:attr name #'#f #:attr extra #f)
(pattern (~seq #:constructor-name name:id) #:attr extra #f)
(pattern (~seq #:extra-constructor-name name:id) #:attr extra #t))
(syntax-parse stx #:literals (:)
[(_ nm:id ([fld : ty] ...) lib)
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
[(_ name:opt-parent ([fld : ty] ...) input-maker:constructor-term lib)
(define has-parent? (and (syntax-e #'name.parent) #t))
(with-syntax* ([nm #'name.nm]
[parent #'name.parent]
[spec (if has-parent? #'(nm parent) #'nm)]
[(struct-info _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
[maker-name (if (syntax-e #'input-maker.name) #'input-maker.name #'nm)] ;New default (corresponds to how struct works)
;maker-name's symbolic form is used in the require form
[id-is-ctor? (or (attribute input-maker.extra) (bound-identifier=? #'maker-name #'nm))]
[internal-maker (generate-temporary #'maker-name)] ;Only used if id-is-ctor? is true
[real-maker (if (syntax-e #'id-is-ctor?) #'internal-maker #'maker-name)] ;The actual identifier bound to the constructor
[extra-maker (and (attribute input-maker.extra)
(not (bound-identifier=? #'make-name #'nm))
#'maker-name)])
(quasisyntax/loc stx
(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(define-for-syntax si
(make-struct-info
(lambda ()
(list #'struct-info
#'maker
#'real-maker
#'pred
(reverse (list #'sel ...))
(list mut ...)
#f))))
(dtsi* () nm ([fld : ty] ...) #:type-only)
(define-syntax nm
(if id-is-ctor?
(make-struct-info-self-ctor #'internal-maker si)
si))
(dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only)
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f)
(require/typed (maker-name real-maker) nm lib #:struct-maker parent)
;This needs to be a different identifier to meet the specifications
;of struct (the id constructor shouldn't expand to it)
#,(if (syntax-e #'extra-maker)
#'(require/typed (maker-name extra-maker) nm lib #:struct-maker #f)
#'(begin))
(require/typed lib
[sel (nm -> ty)]) ...)))]
[(_ (nm parent) ([fld : ty] ...) lib)
(and (identifier? #'nm) (identifier? #'parent))
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
#`(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(lambda ()
(list #'struct-info
#'maker
#'pred
(list #'sel ...)
(list mut ...)
#f))))
(dtsi* () (nm parent) ([fld : ty] ...) #:type-only)
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker parent)
(require/typed lib
[sel (nm -> ty)]) ...))]))
[sel (nm -> ty)]) ...)))]))
(define-syntax (do: stx)
(syntax-parse stx #:literals (:)

15
collects/typed-scheme/scribblings/reference/special-forms.scrbl
View File

@ -318,10 +318,15 @@ naming a predicate, and @racket[_r] is an optionally-renamed identifier.
@defform/subs[#:literals (struct opaque)
(require/typed m rt-clause ...)
([rt-clause [r t]
[struct name ([f : t] ...)]
[struct (name parent) ([f : t] ...)]
[opaque t pred]])
]{This form requires identifiers from the module @racket[m], giving
[struct name ([f : t] ...)
struct-option ...]
[struct (name parent) ([f : t] ...)
struct-option ...]
[opaque t pred]]
[struct-option
(code:line #:constructor-name constructor-id)
(code:line #:extra-constructor-name constructor-id)])]
{This form requires identifiers from the module @racket[m], giving
them the specified types.
The first form requires @racket[r], giving it type @racket[t].
@ -339,7 +344,7 @@ Racket.
@ex[(module UNTYPED racket/base
(define n 100)
(define-struct IntTree
(struct IntTree
(elem left right))
(provide n (struct-out IntTree)))

3
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -115,6 +115,9 @@
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:type-only #t)]
;; define-typed-struct w/ polymorphism
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]

6
collects/typed/net/cgi.rkt
View File

@ -2,10 +2,10 @@
(require typed/private/utils)
(require-typed-struct cgi-error () net/cgi)
(require-typed-struct cgi-error () #:extra-constructor-name make-cgi-error net/cgi)
(require-typed-struct (incomplete-%-suffix cgi-error) ([chars : (Listof Char)]) net/cgi)
(require-typed-struct (invalid-%-suffix cgi-error) ([char : Char]) net/cgi)
(require-typed-struct (incomplete-%-suffix cgi-error) ([chars : (Listof Char)]) #:extra-constructor-name make-incomplete-%-suffix net/cgi)
(require-typed-struct (invalid-%-suffix cgi-error) ([char : Char]) #:extra-constructor-name make-invalid-%-suffix net/cgi)
(require/typed/provide net/cgi

2
collects/typed/net/cookie.rkt
View File

@ -18,6 +18,6 @@
[get-cookie (String String -> (Listof String))]
[get-cookie/single (String String -> (Option String))])
(require-typed-struct (cookie-error exn:fail) () net/cookie)
(require-typed-struct (cookie-error exn:fail) () #:extra-constructor-name make-cookie-error net/cookie)
(provide Cookie cookie? (struct-out cookie-error))

3
collects/typed/net/mime.rkt
View File

@ -10,6 +10,7 @@
[read : String]
[size : Number]
[params : (Listof (Pair Symbol String))])
#:extra-constructor-name make-disposition
net/mime)
(require-typed-struct entity ([type : (U Symbol String)]
[subtype : (U Symbol String)]
@ -23,9 +24,11 @@
[fields : (Listof String)]
[parts : (Listof String) ]
[body : (Output-Port -> Void)])
#:extra-constructor-name make-entity
net/mime)
(require-typed-struct message
([version : String] [entity : entity] [fields : (Listof Symbol)])
#:extra-constructor-name make-message
net/mime)

31
collects/typed/net/nntp.rkt
View File

@ -4,6 +4,7 @@
(require-typed-struct/provide
communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
#:extra-constructor-name make-communicator
net/nntp)
(require/typed/provide net/nntp
@ -18,14 +19,24 @@
[make-desired-header (String -> String)]
[extract-desired-headers ((Listof String) (Listof String) -> (Listof String))])
(require-typed-struct/provide (nntp exn:fail) () net/nntp)
(require-typed-struct/provide (unexpected-response nntp) ([code : Number] [text : String]) net/nntp)
(require-typed-struct/provide (bad-status-line nntp) ([line : String]) net/nntp)
(require-typed-struct/provide (premature-close nntp) ([communicator : communicator]) net/nntp)
(require-typed-struct/provide (bad-newsgroup-line nntp) ([line : String]) net/nntp)
(require-typed-struct/provide (non-existent-group nntp) ([group : String]) net/nntp)
(require-typed-struct/provide (article-not-in-group nntp) ([article : Number]) net/nntp)
(require-typed-struct/provide (no-group-selected nntp) () net/nntp)
(require-typed-struct/provide (article-not-found nntp) ([article : Number]) net/nntp)
(require-typed-struct/provide (authentication-rejected nntp) () net/nntp)
(require-typed-struct/provide (nntp exn:fail)
() #:extra-constructor-name make-nntp net/nntp)
(require-typed-struct/provide (unexpected-response nntp)
([code : Number] [text : String]) #:extra-constructor-name make-unexpected-response net/nntp)
(require-typed-struct/provide (bad-status-line nntp)
([line : String]) #:extra-constructor-name make-bad-status-line net/nntp)
(require-typed-struct/provide (premature-close nntp)
([communicator : communicator]) #:extra-constructor-name make-premature-close net/nntp)
(require-typed-struct/provide (bad-newsgroup-line nntp)
([line : String]) #:extra-constructor-name make-bad-newsgroup-line net/nntp)
(require-typed-struct/provide (non-existent-group nntp)
([group : String]) #:extra-constructor-name make-non-existent-group net/nntp)
(require-typed-struct/provide (article-not-in-group nntp)
([article : Number]) #:extra-constructor-name make-article-not-in-group net/nntp)
(require-typed-struct/provide (no-group-selected nntp)
() #:extra-constructor-name make-no-group-selected net/nntp)
(require-typed-struct/provide (article-not-found nntp)
([article : Number]) #:extra-constructor-name make-article-not-found net/nntp)
(require-typed-struct/provide (authentication-rejected nntp)
() #:extra-constructor-name make-authentication-rejected net/nntp)

44
collects/typed/net/pop3.rkt
View File

@ -4,6 +4,7 @@
(require-typed-struct/provide communicator
([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])
#:extra-constructor-name make-communicator
net/pop3)
(require/typed/provide net/pop3
@ -23,20 +24,31 @@
[extract-desired-headers ((Listof String)(Listof String)-> (Listof String))])
(require-typed-struct/provide (pop3 exn) () net/pop3)
(require-typed-struct/provide (cannot-connect pop3) () net/pop3)
(require-typed-struct/provide (username-rejected pop3) () net/pop3)
(require-typed-struct/provide (password-rejected pop3) () net/pop3)
(require-typed-struct/provide (not-ready-for-transaction pop3)
([communicator : communicator]) net/pop3)
(require-typed-struct/provide (not-given-headers pop3)
([communicator : communicator] [message : Integer]) net/pop3)
(require-typed-struct/provide (illegal-message-number pop3)
([communicator : communicator] [message : Integer]) net/pop3)
(require-typed-struct/provide (cannot-delete-message pop3)
([communicator : communicator] [message : Integer]) net/pop3)
(require-typed-struct/provide (disconnect-not-quiet pop3)
([communicator : communicator]) net/pop3)
(require-typed-struct/provide (malformed-server-response pop3)
([communicator : communicator]) net/pop3)
(require-typed-struct/provide (pop3 exn)
() #:extra-constructor-name make-pop3 net/pop3)
(require-typed-struct/provide (cannot-connect pop3)
() #:extra-constructor-name make-cannot-connect net/pop3)
(require-typed-struct/provide (username-rejected pop3)
() #:extra-constructor-name make-username-rejected net/pop3)
(require-typed-struct/provide (password-rejected pop3)
() #:extra-constructor-name make-password-rejected net/pop3)
(require-typed-struct/provide (not-ready-for-transaction pop3)
([communicator : communicator])
#:extra-constructor-name make-not-ready-for-transaction net/pop3)
(require-typed-struct/provide (not-given-headers pop3)
([communicator : communicator] [message : Integer])
#:extra-constructor-name make-not-given-headers net/pop3)
(require-typed-struct/provide (illegal-message-number pop3)
([communicator : communicator] [message : Integer])
#:extra-constructor-name make-illegal-message-number net/pop3)
(require-typed-struct/provide (cannot-delete-message pop3)
([communicator : communicator] [message : Integer])
#:extra-constructor-name make-cannot-delete-message net/pop3)
(require-typed-struct/provide (disconnect-not-quiet pop3)
([communicator : communicator])
#:extra-constructor-name make-disconnect-not-quiet net/pop3)
(require-typed-struct/provide (malformed-server-response pop3)
([communicator : communicator])
#:extra-constructor-name make-malformed-server-response net/pop3)