added recontract-out
This commit is contained in:
Ryan Culpepper
parent
0ea03360c3
commit
1a77f4ee0e
|
|
@ -2,7 +2,9 @@
|
|||
|
||||
(provide provide/contract
|
||||
(protect-out (for-syntax true-provide/contract
|
||||
make-provide/contract-transformer)))
|
||||
make-provide/contract-transformer
|
||||
provide/contract-transformer?
|
||||
replace-provide/contract-transformer-positive-blame)))
|
||||
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
|
|
@ -48,60 +50,76 @@
|
|||
(current-inspector) #f '(0))])
|
||||
make-))
|
||||
|
||||
(define-for-syntax (make-provide/contract-transformer
|
||||
contract-id id external-id pos-module-source)
|
||||
(make-set!-transformer
|
||||
(let ([saved-id-table (make-hasheq)])
|
||||
(λ (stx)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
;; In an expression context:
|
||||
(let* ([key (syntax-local-lift-context)]
|
||||
;; Already lifted in this lifting context?
|
||||
[lifted-id
|
||||
(or (hash-ref saved-id-table key #f)
|
||||
;; No: lift the contract creation:
|
||||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[external-id external-id]
|
||||
[pos-module-source pos-module-source]
|
||||
[loc-id (identifier-prune-to-source-module id)])
|
||||
(let ([srcloc-code
|
||||
(with-syntax
|
||||
([src
|
||||
(or (and (path-string? (syntax-source #'id))
|
||||
(path->relative-string/library
|
||||
(syntax-source #'id) #f))
|
||||
(syntax-source #'id))]
|
||||
[line (syntax-line #'id)]
|
||||
[col (syntax-column #'id)]
|
||||
[pos (syntax-position #'id)]
|
||||
[span (syntax-span #'id)])
|
||||
#'(make-srcloc 'src 'line 'col 'pos 'span))])
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#`(contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(quote-module-name)
|
||||
'external-id
|
||||
#,srcloc-code))))))])
|
||||
(when key (hash-set! saved-id-table key lifted-id))
|
||||
;; Expand to a use of the lifted expression:
|
||||
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
|
||||
(syntax-case stx (set!)
|
||||
[name (identifier? #'name) #'saved-id]
|
||||
[(set! id arg)
|
||||
(raise-syntax-error
|
||||
'contract/out
|
||||
"cannot set! a contract/out variable"
|
||||
stx #'id)]
|
||||
[(name . more)
|
||||
(with-syntax ([app (datum->syntax stx '#%app)])
|
||||
(syntax/loc stx (app saved-id . more)))])))
|
||||
;; In case of partial expansion for module-level and internal-defn
|
||||
;; contexts, delay expansion until it's a good time to lift
|
||||
;; expressions:
|
||||
(quasisyntax/loc stx (#%expression #,stx)))))))
|
||||
(begin-for-syntax
|
||||
|
||||
(struct provide/contract-transformer (contract-id id external-id pos-module-source saved-id-table)
|
||||
#:property
|
||||
prop:set!-transformer
|
||||
(lambda (self stx)
|
||||
(let ([contract-id (provide/contract-transformer-contract-id self)]
|
||||
[id (provide/contract-transformer-id self)]
|
||||
[external-id (provide/contract-transformer-external-id self)]
|
||||
[pos-module-source (provide/contract-transformer-pos-module-source self)]
|
||||
[saved-id-table (provide/contract-transformer-saved-id-table self)])
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
;; In an expression context:
|
||||
(let* ([key (syntax-local-lift-context)]
|
||||
;; Already lifted in this lifting context?
|
||||
[lifted-id
|
||||
(or (hash-ref saved-id-table key #f)
|
||||
;; No: lift the contract creation:
|
||||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[external-id external-id]
|
||||
[pos-module-source pos-module-source]
|
||||
[loc-id (identifier-prune-to-source-module id)])
|
||||
(let ([srcloc-code
|
||||
(with-syntax
|
||||
([src
|
||||
(or (and (path-string? (syntax-source #'id))
|
||||
(path->relative-string/library
|
||||
(syntax-source #'id) #f))
|
||||
(syntax-source #'id))]
|
||||
[line (syntax-line #'id)]
|
||||
[col (syntax-column #'id)]
|
||||
[pos (syntax-position #'id)]
|
||||
[span (syntax-span #'id)])
|
||||
#'(make-srcloc 'src 'line 'col 'pos 'span))])
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#`(contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(quote-module-name)
|
||||
'external-id
|
||||
#,srcloc-code))))))])
|
||||
(when key (hash-set! saved-id-table key lifted-id))
|
||||
;; Expand to a use of the lifted expression:
|
||||
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
|
||||
(syntax-case stx (set!)
|
||||
[name (identifier? #'name) #'saved-id]
|
||||
[(set! id arg)
|
||||
(raise-syntax-error
|
||||
'contract/out
|
||||
"cannot set! a contract/out variable"
|
||||
stx #'id)]
|
||||
[(name . more)
|
||||
(with-syntax ([app (datum->syntax stx '#%app)])
|
||||
(syntax/loc stx (app saved-id . more)))])))
|
||||
;; In case of partial expansion for module-level and internal-defn
|
||||
;; contexts, delay expansion until it's a good time to lift
|
||||
;; expressions:
|
||||
(quasisyntax/loc stx (#%expression #,stx))))))
|
||||
|
||||
(define (make-provide/contract-transformer cid id eid pos)
|
||||
(provide/contract-transformer cid id eid pos (make-hasheq)))
|
||||
|
||||
(define (replace-provide/contract-transformer-positive-blame self new-pos)
|
||||
(let ([contract-id (provide/contract-transformer-contract-id self)]
|
||||
[id (provide/contract-transformer-id self)]
|
||||
[external-id (provide/contract-transformer-external-id self)])
|
||||
(provide/contract-transformer contract-id id external-id new-pos (make-hasheq))))
|
||||
)
|
||||
|
||||
(define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
|
||||
(syntax-case provide-stx ()
|
||||
|
|
|
|||
43
collects/tests/unstable/recontract.rkt
Normal file
43
collects/tests/unstable/recontract.rkt
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
#lang racket/base
|
||||
(require rackunit)
|
||||
|
||||
(module A racket
|
||||
(define (f x) (if (positive? x) x 'wrong))
|
||||
(provide (contract-out [f (-> real? real?)])))
|
||||
|
||||
(module B racket
|
||||
(require unstable/recontract
|
||||
(submod ".." A))
|
||||
(provide (rename-out [f f-from-a])
|
||||
(recontract-out f)))
|
||||
|
||||
(module C racket
|
||||
(require (submod ".." B))
|
||||
(define (af x) (f-from-a x))
|
||||
(define (bf x) (f x))
|
||||
(provide af bf))
|
||||
|
||||
(require 'C)
|
||||
|
||||
(define-syntax-rule (tcerr expr from blame)
|
||||
(do-tcerr (lambda () expr) 'expr from blame))
|
||||
|
||||
(define (do-tcerr thunk quoted-expr from blame)
|
||||
(test-case (format "~s" quoted-expr)
|
||||
(check-exn (lambda (e)
|
||||
(let ([msg (exn-message e)])
|
||||
(let ([from-m (regexp-match #rx"contract from:[ \n]*\\([^)]* ([A-Z])\\)" msg)])
|
||||
(check-equal? (and from-m (cadr from-m)) from "contract from"))
|
||||
(let ([blame-m (regexp-match #rx"blaming:[ \n]*\\([^)]* ([A-Z])\\)" msg)])
|
||||
(check-equal? (and blame-m (cadr blame-m)) blame "blaming"))))
|
||||
thunk)))
|
||||
|
||||
;; Normally, A is the positive blame party
|
||||
(test-equal? "af ok" (af 1) 1)
|
||||
(tcerr (af -2) "A" "A")
|
||||
(tcerr (af 'apple) "A" "C")
|
||||
|
||||
;; Check that recontract-out changes positive party to B
|
||||
(test-equal? "bf ok" (bf 1) 1)
|
||||
(tcerr (bf -2) "B" "B")
|
||||
(tcerr (bf 'apple) "B" "C")
|
||||
60
collects/unstable/recontract.rkt
Normal file
60
collects/unstable/recontract.rkt
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/provide-transform)
|
||||
racket/contract/base
|
||||
racket/contract/private/provide
|
||||
syntax/location)
|
||||
(provide provide/recontract
|
||||
recontract-out)
|
||||
|
||||
;; TODO: support rename, struct (?), etc
|
||||
;; TODO: check whether this works w/ define/contract, with-contract, etc
|
||||
|
||||
(begin-for-syntax
|
||||
;; get-pctx : identifier syntax -> provide/contract-transformer
|
||||
(define (get-pctx id ctx)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f "expected identifier" ctx id))
|
||||
(let ([pctx (syntax-local-value id (lambda () #f))])
|
||||
(unless (provide/contract-transformer? pctx)
|
||||
;; FIXME: or should recontracting an uncontracted name be a no-op?
|
||||
(raise-syntax-error #f "expected name imported with contract" ctx id))
|
||||
pctx)))
|
||||
|
||||
(define-syntax (provide/recontract stx)
|
||||
(syntax-case stx ()
|
||||
[(provide/recontract id ...)
|
||||
(let* ([ids (syntax->list #'(id ...))])
|
||||
(for ([id (in-list ids)]) (get-pctx id stx)) ;; check for errors
|
||||
#'(begin (define pos-mod-src (quote-module-name))
|
||||
(provide/recontract1 id pos-mod-src) ...))]))
|
||||
|
||||
(define-syntax (provide/recontract1 stx)
|
||||
(syntax-case stx ()
|
||||
[(provide/recontract1 id pos-mod-src)
|
||||
(with-syntax ([(aux-id) (generate-temporaries #'(id))])
|
||||
#'(begin
|
||||
(define-syntax aux-id
|
||||
(let ([old-pctx (get-pctx (quote-syntax id) #f)])
|
||||
(replace-provide/contract-transformer-positive-blame
|
||||
old-pctx (quote-syntax pos-mod-src))))
|
||||
(provide (rename-out [aux-id id]))))]))
|
||||
|
||||
;; ----
|
||||
|
||||
(define-syntax recontract-out
|
||||
(make-provide-pre-transformer
|
||||
(lambda (stx modes)
|
||||
;; Adapted from similar check in racket/contract/private/out:
|
||||
;; For now, only work in the base phase ...
|
||||
(unless (member modes '(() (0)))
|
||||
(raise-syntax-error #f "allowed only in relative phase-level 0" stx))
|
||||
|
||||
;; FIXME: check for syntax errors
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(syntax-local-lift-module-end-declaration
|
||||
#`(provide/recontract . args))])
|
||||
|
||||
#`(combine-out))))
|
||||
47
collects/unstable/scribblings/recontract.scrbl
Normal file
47
collects/unstable/scribblings/recontract.scrbl
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/eval
|
||||
"utils.rkt"
|
||||
(for-label racket/base
|
||||
racket/contract
|
||||
unstable/recontract))
|
||||
|
||||
@(define the-eval (make-base-eval))
|
||||
@(the-eval '(require racket/contract/base unstable/recontract))
|
||||
|
||||
@title[#:tag "recontract"]{Re-Contracting Identifiers}
|
||||
@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
|
||||
|
||||
@defmodule[unstable/recontract]
|
||||
|
||||
@defform[(recontract-out id ...)]{
|
||||
|
||||
Provides each @racket[id] with its existing contract, but changes the
|
||||
positive blame party of the contract to the enclosing module, instead
|
||||
of the module that originally attached the contract to @racket[id].
|
||||
Each @racket[id] must be imported from a module that exports it via
|
||||
@racket[contract-out] or @racket[recontract-out]; otherwise a syntax
|
||||
error is raised.
|
||||
|
||||
Use @racket[recontract-out] when you want to use the same contracts
|
||||
both between different parts of a library and between the library and
|
||||
its clients. The library should use @racket[recontract-out] in the
|
||||
public interface modules so that clients do not see references to
|
||||
private implementation modules in contract errors.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(module private racket
|
||||
(define (f x) (if (positive? x) x 'wrong))
|
||||
(provide (contract-out [f (-> real? real?)])))
|
||||
|
||||
(module public racket
|
||||
(require 'private unstable/recontract)
|
||||
(provide (recontract-out f)))
|
||||
|
||||
(require 'public)
|
||||
(f 1)
|
||||
(f -2)
|
||||
(f 'apple)
|
||||
]
|
||||
}
|
||||
|
||||
@(close-eval the-eval)
|
||||
|
|
@ -95,6 +95,7 @@ Keep documentation and tests up to date.
|
|||
@include-section["match.scrbl"]
|
||||
@include-section["parameter-group.scrbl"]
|
||||
@include-section["pretty.scrbl"]
|
||||
@include-section["recontract.scrbl"]
|
||||
@include-section["sequence.scrbl"]
|
||||
@include-section["string.scrbl"]
|
||||
@include-section["struct.scrbl"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user