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

added #:unprotected-submodule

Browse Source
This commit is contained in:
Robby Findler 2019-05-08 20:31:51 -05:00
parent b7d738d59a
commit 2c3fce244c
3 changed files with 85 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -1784,8 +1784,11 @@ earlier fields.}}
@defform/subs[
#:literals (struct rename)
(contract-out p/c-item ...)
([p/c-item
(contract-out unprotected-submodule contract-out-item ...)
([unprotected-submodule
(code:line)
(code:line #:unprotected-submodule submodule-name)]
[contract-out-item
(struct id/super ((id contract-expr) ...)
struct-option)
(rename orig-id id contract-expr)
@ -1859,6 +1862,8 @@ Specifically, the symbol @indexed-racket['provide/contract-original-contract]
is bound to vectors of two elements, the exported identifier and a
syntax object for the expression that produces the contract controlling
the export.
@history[#:changed "7.3.0.3" @list{Added @racket[#:unprotected-submodule].}]
}
@defform[(recontract-out id ...)]{
@ -1895,9 +1900,9 @@ the export.
the private module.
}
@defform[(provide/contract p/c-item ...)]{
@defform[(provide/contract unprotected-submodule contract-out-item ...)]{
A legacy shorthand for @racket[(provide (contract-out p/c-item ...))],
A legacy shorthand for @racket[(provide (contract-out unprotected-submodule contract-out-item ...))],
except that a @racket[_contract-expr] within @racket[provide/contract]
is evaluated at the position of the @racket[provide/contract] form
instead of at the end of the enclosing module.}

36
pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -1242,6 +1242,42 @@
(require 'provide/contract67-a racket/contract/base)
(provide (contract-out (struct stream ([x any/c] [y any/c]))))))))
(test/spec-passed/result
'provide/contract68
'(let ()
(eval '(module provide/contract68-a racket/base
(require racket/contract/base)
(provide (contract-out
#:unprotected-submodule unsafe
[f (-> integer? (listof integer?))]))
(define (f x) (list x))))
(eval '(module provide/contract68-b racket/base
(require (submod 'provide/contract68-a unsafe))
(define answer (f #f))
(provide answer)))
(eval '(dynamic-require ''provide/contract68-b 'answer)))
'(#f))
(test/spec-passed/result
'provide/contract69
'(let ()
(eval '(module provide/contract69-a racket/base
(require racket/contract/base)
(provide (contract-out
#:unprotected-submodule no-contract
(struct s ([x integer?]))))
(struct s (x))))
(eval '(module provide/contract69-b racket/base
(require (submod 'provide/contract69-a no-contract))
(define answer (s-x (s #f)))
(provide answer)))
(eval '(dynamic-require ''provide/contract69-b 'answer)))
'#f)
(contract-error-test
'provide/contract-struct-out
#'(begin

61
racket/collects/racket/contract/private/provide.rkt
View File

@ -223,6 +223,8 @@
pai enpfn val)))
(define-for-syntax current-unprotected-submodule-name (make-parameter #f))
;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
;; given the syntax for an identifier and a contract,
;; builds a begin expression for the entire contract and provide
@ -261,6 +263,11 @@
'provide/contract
pos-module-source
#f)
#,@(let ([upe (current-unprotected-submodule-name)])
(if upe
(list #`(module+ #,upe
(provide (rename-out [#,id external-name]))))
(list)))
#,@(if provide?
(list #`(provide (rename-out [#,id-rename external-name])))
null)))
@ -1108,7 +1115,19 @@
mangle-for-maker?
provide?))
(define p/c-clauses (syntax->list (syntax (p/c-ele ...))))
(define-values (p/c-clauses unprotected-submodule-name)
(syntax-case (syntax (p/c-ele ...)) ()
[(#:unprotected-submodule modname . more)
(identifier? #'modname)
(values (syntax->list #'more) (syntax-e #'modname))]
[(#:unprotected-submodule x . more)
(raise-syntax-error who
"expected a module name to follow #:unprotected-submodule"
provide-stx
(if (pair? (syntax-e #'more))
(car (syntax-e #'more))
#f))]
[_ (values (syntax->list (syntax (p/c-ele ...))) #f)]))
(define struct-id-mapping (make-free-identifier-mapping))
(define (add-struct-clause-to-struct-id-mapping a parent flds/stx)
(define flds (syntax->list flds/stx))
@ -1141,26 +1160,26 @@
struct-id-mapping
selector-id
(id-for-one-id #f #f selector-id))))))
(cond
[just-check-errors?
(code-for-each-clause p/c-clauses)
(signal-dup-syntax-error)]
[else
(for ([clause (in-list p/c-clauses)])
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(struct a ((fld ctc) ...) options ...)
(identifier? #'a)
(add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
[(struct (a b) ((fld ctc) ...) options ...)
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
[_ (void)]))
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
[pos-module-source-id pos-module-source-id])
(syntax
(begin
(define pos-module-source-id (quote-module-name))
bodies ...)))]))]))
(parameterize ([current-unprotected-submodule-name unprotected-submodule-name])
(cond
[just-check-errors?
(code-for-each-clause p/c-clauses)
(signal-dup-syntax-error)]
[else
(for ([clause (in-list p/c-clauses)])
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(struct a ((fld ctc) ...) options ...)
(identifier? #'a)
(add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
[(struct (a b) ((fld ctc) ...) options ...)
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
[_ (void)]))
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
[pos-module-source-id pos-module-source-id])
(syntax
(begin
(define pos-module-source-id (quote-module-name))
bodies ...)))])))]))
(define-for-syntax (provide/contract-for-whom stx who)