..
original commit: 6b84101c1f7996bd678cb93f4cc250d948bbe8a5
This commit is contained in:
Robby Findler
parent
02422a012b
commit
62b7af443d
|
|
@ -19,6 +19,7 @@
|
||||||
|
|
||||||
(require (lib "class.ss"))
|
(require (lib "class.ss"))
|
||||||
(require (lib "contract-helpers.scm" "mzlib" "private"))
|
(require (lib "contract-helpers.scm" "mzlib" "private"))
|
||||||
|
(require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
|
||||||
|
|
||||||
;; (define/contract id contract expr)
|
;; (define/contract id contract expr)
|
||||||
;; defines `id' with `contract'; initially binding
|
;; defines `id' with `contract'; initially binding
|
||||||
|
|
@ -95,96 +96,246 @@
|
||||||
define-stx
|
define-stx
|
||||||
(syntax name))]))
|
(syntax name))]))
|
||||||
|
|
||||||
(require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
|
;; (provide/contract p/c-ele ...)
|
||||||
|
;; p/c-ele = (id expr) | (struct (id expr) ...)
|
||||||
;; (provide/contract (id expr) ...)
|
|
||||||
;; provides each `id' with the contract `expr'.
|
;; provides each `id' with the contract `expr'.
|
||||||
(define-syntax (provide/contract provide-stx)
|
(define-syntax (provide/contract provide-stx)
|
||||||
(syntax-case provide-stx ()
|
(syntax-case provide-stx (struct)
|
||||||
[(_) (raise-syntax-error 'provide/contract "must provide at least one id")]
|
[(_ p/c-ele ...)
|
||||||
[(_ (id ctrct) ...)
|
(let ()
|
||||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
|
||||||
(with-syntax ([(id-rename ...)
|
|
||||||
(map (lambda (x)
|
|
||||||
(datum->syntax-object
|
|
||||||
provide-stx
|
|
||||||
(string->symbol
|
|
||||||
(format "provide/contract-id-~a-ACK-DONT_USE_ME"
|
|
||||||
(syntax-object->datum x)))))
|
|
||||||
(syntax->list (syntax (id ...))))]
|
|
||||||
[(contract-id ...)
|
|
||||||
(map (lambda (x)
|
|
||||||
(datum->syntax-object
|
|
||||||
provide-stx
|
|
||||||
(string->symbol
|
|
||||||
(format "provide/contract-contract-id-~a-ACK-DONT_USE_ME"
|
|
||||||
(syntax-object->datum x)))))
|
|
||||||
(syntax->list (syntax (id ...))))]
|
|
||||||
[pos-module-source (datum->syntax-object
|
|
||||||
provide-stx
|
|
||||||
(string->symbol
|
|
||||||
(format
|
|
||||||
"provide/contract-pos-module-source-~a-ACK-DONT_USE_ME"
|
|
||||||
(car (syntax->list (syntax (id ...)))))))]
|
|
||||||
[pos-stx (datum->syntax-object provide-stx 'here)]
|
|
||||||
[module-source-as-symbol (datum->syntax-object provide-stx 'module-source-as-symbol)])
|
|
||||||
(syntax
|
|
||||||
(begin
|
|
||||||
(provide (rename id-rename id) ...)
|
|
||||||
(require (lib "contract-helpers.scm" "mzlib" "private"))
|
|
||||||
|
|
||||||
(define pos-module-source (module-source-as-symbol #'pos-stx))
|
;; code-for-each-clause : (listof syntax) -> (listof syntax)
|
||||||
;; this is here to check for unbound ids.
|
;; constructs code for each clause of a provide/contract
|
||||||
(if #f (begin (void) id ...))
|
(define (code-for-each-clause clauses)
|
||||||
|
(cond
|
||||||
|
[(null? clauses) null]
|
||||||
|
[else
|
||||||
|
(let ([clause (car clauses)])
|
||||||
|
(syntax-case clause (struct)
|
||||||
|
[(struct struct-name ((field-name contract) ...))
|
||||||
|
(and (identifier? (syntax struct-name))
|
||||||
|
(andmap identifier? (syntax->list (syntax (field-name ...)))))
|
||||||
|
(build-struct-code (syntax struct-name)
|
||||||
|
(syntax->list (syntax (field-name ...)))
|
||||||
|
(syntax->list (syntax (contract ...))))]
|
||||||
|
[(struct name)
|
||||||
|
(identifier? (syntax name))
|
||||||
|
(raise-syntax-error 'provide/contract
|
||||||
|
"missing fields"
|
||||||
|
provide-stx
|
||||||
|
clause)]
|
||||||
|
[(struct name (fields ...))
|
||||||
|
(for-each (lambda (field)
|
||||||
|
(syntax-case field ()
|
||||||
|
[(x y)
|
||||||
|
(identifier? (syntax x))
|
||||||
|
(void)]
|
||||||
|
[(x y)
|
||||||
|
(raise-syntax-error 'provide/contract
|
||||||
|
"malformed struct field, expected identifier"
|
||||||
|
provide-stx
|
||||||
|
(syntax x))]
|
||||||
|
[else
|
||||||
|
(raise-syntax-error 'provide/contract
|
||||||
|
"malformed struct field"
|
||||||
|
provide-stx
|
||||||
|
field)]))
|
||||||
|
(syntax->list (syntax (fields ...))))
|
||||||
|
|
||||||
(define contract-id ctrct) ...
|
;; if we didn't find a bad field something is wrong!
|
||||||
(define-syntax id-rename
|
(raise-syntax-error 'provide/contract "internal error" provide-stx clause)]
|
||||||
(make-set!-transformer
|
[(struct name . fields)
|
||||||
(lambda (stx)
|
(raise-syntax-error 'provide/contract
|
||||||
(with-syntax ([neg-stx (datum->syntax-object stx 'here)])
|
"malformed struct fields"
|
||||||
(syntax-case stx (set!)
|
provide-stx
|
||||||
[(set! _ body) (raise-syntax-error
|
clause)]
|
||||||
#f
|
[(name contract)
|
||||||
"cannot set! provide/contract identifier"
|
(identifier? (syntax name))
|
||||||
stx
|
(cons (code-for-one-id (syntax name) (syntax contract))
|
||||||
(syntax _))]
|
(code-for-each-clause (cdr clauses)))]
|
||||||
[(_ arg (... ...))
|
[(name contract)
|
||||||
(syntax
|
(raise-syntax-error 'provide/contract
|
||||||
((-contract contract-id
|
"expected identifier"
|
||||||
id
|
provide-stx
|
||||||
pos-module-source
|
(syntax name))]
|
||||||
(module-source-as-symbol #'neg-stx)
|
[unk
|
||||||
(quote-syntax _))
|
(raise-syntax-error 'provide/contract
|
||||||
arg
|
"malformed clause"
|
||||||
(... ...)))]
|
provide-stx
|
||||||
[_
|
(syntax unk))]))]))
|
||||||
(identifier? (syntax _))
|
|
||||||
(syntax
|
;; build-struct-code : syntax (listof syntax) (listof syntax) -> syntax
|
||||||
(-contract contract-id
|
;; constructs the code for a struct clause
|
||||||
id
|
(define (build-struct-code struct-name field-names field-contracts)
|
||||||
pos-module-source
|
(let* ([field-contract-ids (map (lambda (field-name)
|
||||||
(module-source-as-symbol #'neg-stx)
|
(mangle-id field-name "provide/contract-field-contract"))
|
||||||
(quote-syntax _)))])))))
|
field-names)]
|
||||||
...)))]
|
[selector-ids (map (lambda (field-contract-id)
|
||||||
[(_ clauses ...)
|
(build-selector-id struct-name field-contract-id))
|
||||||
(for-each
|
field-contract-ids)]
|
||||||
(lambda (clause)
|
[mutator-ids (map (lambda (field-contract-id)
|
||||||
(syntax-case clause ()
|
(build-mutator-id struct-name field-contract-id))
|
||||||
[(x y)
|
field-contract-ids)]
|
||||||
(identifier? (syntax x))
|
[predicate-id (build-predicate-id struct-name)])
|
||||||
(void)]
|
(with-syntax ([(selector-codes ...)
|
||||||
[(x y)
|
(map (lambda (field-name field-contract-id)
|
||||||
(raise-syntax-error
|
(code-for-one-id (build-selector-id struct-name
|
||||||
'provide/contract
|
field-contract-id)
|
||||||
"malformed clause (expected an identifier as first item in clause)"
|
(build-selector-contract struct-name
|
||||||
provide-stx
|
predicate-id
|
||||||
(syntax x))]
|
field-contract-id)))
|
||||||
[_ (raise-syntax-error
|
field-names
|
||||||
'provide/contract
|
field-contract-ids)]
|
||||||
"malformed clause (expected two items in each clause)"
|
[(mutator-codes ...)
|
||||||
provide-stx
|
(map (lambda (mutator-id field-contract-id)
|
||||||
clause)]))
|
(code-for-one-id mutator-id
|
||||||
(syntax->list (syntax (clauses ...))))]))
|
(build-mutator-contract struct-name
|
||||||
|
predicate-id
|
||||||
|
field-contract-id)))
|
||||||
|
mutator-ids
|
||||||
|
field-contract-ids)]
|
||||||
|
[predicate-code (code-for-one-id predicate-id (syntax (-> any? boolean?)))]
|
||||||
|
[constructor-code (code-for-one-id
|
||||||
|
(build-constructor-id struct-name)
|
||||||
|
(build-constructor-contract field-contract-ids
|
||||||
|
predicate-id))]
|
||||||
|
[(field-contracts ...) field-contracts]
|
||||||
|
[(field-contract-ids ...) field-contract-ids])
|
||||||
|
(syntax
|
||||||
|
(begin
|
||||||
|
(define field-contract-ids field-contracts) ...
|
||||||
|
selector-codes ...
|
||||||
|
mutator-codes ...
|
||||||
|
predicate-code
|
||||||
|
constructor-code)))))
|
||||||
|
|
||||||
|
;; build-constructor-contract : (listof syntax) syntax -> syntax
|
||||||
|
(define (build-constructor-contract field-contract-ids predicate-id)
|
||||||
|
(with-syntax ([(field-contract-ids ...) field-contract-ids]
|
||||||
|
[predicate-id predicate-id])
|
||||||
|
(syntax (-> field-contract-ids ... predicate-id))))
|
||||||
|
|
||||||
|
;; build-selector-contract : syntax syntax -> syntax
|
||||||
|
;; constructs the contract for a selector
|
||||||
|
(define (build-selector-contract struct-name predicate-id field-contract-id)
|
||||||
|
(with-syntax ([field-contract-id field-contract-id]
|
||||||
|
[predicate-id predicate-id])
|
||||||
|
(syntax (-> predicate-id field-contract-id))))
|
||||||
|
|
||||||
|
;; build-mutator-contract : syntax syntax -> syntax
|
||||||
|
;; constructs the contract for a selector
|
||||||
|
(define (build-mutator-contract struct-name predicate-id field-contract-id)
|
||||||
|
(with-syntax ([field-contract-id field-contract-id]
|
||||||
|
[predicate-id predicate-id])
|
||||||
|
(syntax (-> predicate-id contract-id void?))))
|
||||||
|
|
||||||
|
;; build-constructor-id : syntax -> syntax
|
||||||
|
;; constructs the name of the selector for a particular field of a struct
|
||||||
|
(define (build-constructor-id struct-name)
|
||||||
|
(datum->syntax-object
|
||||||
|
struct-name
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
"make-"
|
||||||
|
(symbol->string (syntax-object->datum struct-name))))))
|
||||||
|
|
||||||
|
;; build-predicate-id : syntax -> syntax
|
||||||
|
;; constructs the name of the selector for a particular field of a struct
|
||||||
|
(define (build-predicate-id struct-name)
|
||||||
|
(datum->syntax-object
|
||||||
|
struct-name
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
(symbol->string (syntax-object->datum struct-name))
|
||||||
|
"?"))))
|
||||||
|
|
||||||
|
;; build-selector-id : syntax syntax -> syntax
|
||||||
|
;; constructs the name of the selector for a particular field of a struct
|
||||||
|
(define (build-selector-id struct-name field-name)
|
||||||
|
(datum->syntax-object
|
||||||
|
struct-name
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
(symbol->string (syntax-object->datum struct-name))
|
||||||
|
"-"
|
||||||
|
(symbol->string (syntax-object->datum field-name))))))
|
||||||
|
|
||||||
|
;; build-mutator-id : syntax syntax -> syntax
|
||||||
|
;; constructs the name of the selector for a particular field of a struct
|
||||||
|
(define (build-mutator-id struct-name field-name)
|
||||||
|
(datum->syntax-object
|
||||||
|
struct-name
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
"set-"
|
||||||
|
(symbol->string (syntax-object->datum struct-name))
|
||||||
|
"-"
|
||||||
|
(symbol->string (syntax-object->datum field-name))
|
||||||
|
"!"))))
|
||||||
|
|
||||||
|
;; code-for-one-id : syntax syntax -> syntax
|
||||||
|
;; given the syntax for an identifier and a contract,
|
||||||
|
;; builds a begin expression for the entire contract and provide
|
||||||
|
(define (code-for-one-id id ctrct)
|
||||||
|
(with-syntax ([id-rename (mangle-id id "provide/contract-id")]
|
||||||
|
[contract-id (mangle-id id "provide/contract-contract-id")]
|
||||||
|
[pos-module-source (mangle-id id "provide/contract-pos-module-source")]
|
||||||
|
[pos-stx (datum->syntax-object provide-stx 'here)]
|
||||||
|
[module-source-as-symbol (datum->syntax-object provide-stx 'module-source-as-symbol)]
|
||||||
|
[id id]
|
||||||
|
[ctrct ctrct])
|
||||||
|
(syntax
|
||||||
|
(begin
|
||||||
|
(provide (rename id-rename id))
|
||||||
|
|
||||||
|
;; unbound id check
|
||||||
|
(if #f id)
|
||||||
|
(define pos-module-source (module-source-as-symbol #'pos-stx))
|
||||||
|
(define contract-id ctrct)
|
||||||
|
(define-syntax id-rename
|
||||||
|
(make-set!-transformer
|
||||||
|
(lambda (stx)
|
||||||
|
(with-syntax ([neg-stx (datum->syntax-object stx 'here)])
|
||||||
|
(syntax-case stx (set!)
|
||||||
|
[(set! _ body) (raise-syntax-error
|
||||||
|
#f
|
||||||
|
"cannot set! provide/contract identifier"
|
||||||
|
stx
|
||||||
|
(syntax _))]
|
||||||
|
[(_ arg (... ...))
|
||||||
|
(syntax
|
||||||
|
((-contract contract-id
|
||||||
|
id
|
||||||
|
pos-module-source
|
||||||
|
(module-source-as-symbol #'neg-stx)
|
||||||
|
(quote-syntax _))
|
||||||
|
arg
|
||||||
|
(... ...)))]
|
||||||
|
[_
|
||||||
|
(identifier? (syntax _))
|
||||||
|
(syntax
|
||||||
|
(-contract contract-id
|
||||||
|
id
|
||||||
|
pos-module-source
|
||||||
|
(module-source-as-symbol #'neg-stx)
|
||||||
|
(quote-syntax _)))])))))))))
|
||||||
|
|
||||||
|
;; mangle-id : syntax string -> syntax
|
||||||
|
;; constructs a mangled name of an identifier from an identifier
|
||||||
|
;; the name isn't fresh, so `id' must already be unique.
|
||||||
|
(define (mangle-id id prefix)
|
||||||
|
(datum->syntax-object
|
||||||
|
provide-stx
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
prefix
|
||||||
|
(format "-~a-ACK-DONT_USE_ME" (syntax-object->datum id))))))
|
||||||
|
|
||||||
|
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
|
||||||
|
(syntax
|
||||||
|
(begin
|
||||||
|
(require (lib "contract-helpers.scm" "mzlib" "private"))
|
||||||
|
bodies ...))))]))
|
||||||
|
|
||||||
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
|
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
|
||||||
;; doesn't return
|
;; doesn't return
|
||||||
|
|
|
||||||
|
|
@ -4,13 +4,14 @@
|
||||||
|
|
||||||
(SECTION 'contracts)
|
(SECTION 'contracts)
|
||||||
|
|
||||||
|
(parameterize ([error-print-width 200])
|
||||||
(let ()
|
(let ()
|
||||||
;; test/spec-passed : symbol sexp -> void
|
;; test/spec-passed : symbol sexp -> void
|
||||||
;; tests a passing specification
|
;; tests a passing specification
|
||||||
(define (test/spec-passed name expression)
|
(define (test/spec-passed name expression)
|
||||||
(test 'passed
|
(test (void)
|
||||||
eval
|
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
|
||||||
`(let () ,expression 'passed)))
|
(list expression '(void))))
|
||||||
|
|
||||||
;; test/spec-failed : symbol sexp string -> void
|
;; test/spec-failed : symbol sexp string -> void
|
||||||
;; tests a failing specification with blame assigned to `blame'
|
;; tests a failing specification with blame assigned to `blame'
|
||||||
|
|
@ -21,11 +22,10 @@
|
||||||
(and m (cadr m)))))
|
(and m (cadr m)))))
|
||||||
(test blame
|
(test blame
|
||||||
failed-contract
|
failed-contract
|
||||||
(eval
|
(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
||||||
`(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
exn-message])
|
||||||
exn-message])
|
(eval expression)
|
||||||
,expression
|
'failed/expected-exn-got-normal-termination)))
|
||||||
'failed/expected-exn-got-normal-termination))))
|
|
||||||
|
|
||||||
(test/spec-passed
|
(test/spec-passed
|
||||||
'contract-flat1
|
'contract-flat1
|
||||||
|
|
@ -457,6 +457,48 @@
|
||||||
'(let ()
|
'(let ()
|
||||||
(define/contract i (-> integer? integer?) (lambda (x) (i #t)))
|
(define/contract i (-> integer? integer?) (lambda (x) (i #t)))
|
||||||
(i 1))
|
(i 1))
|
||||||
"<<unknown>>"))
|
"<<unknown>>")
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'provide/contract1
|
||||||
|
'(let ()
|
||||||
|
(eval '(module contract-test-suite1 mzscheme
|
||||||
|
(require (lib "contracts.ss"))
|
||||||
|
(provide/contract (x integer?))
|
||||||
|
(define x 1)))
|
||||||
|
(eval '(require contract-test-suite1))
|
||||||
|
(eval 'x)))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'provide/contract2
|
||||||
|
'(let ()
|
||||||
|
(eval '(module contract-test-suite2 mzscheme
|
||||||
|
(require (lib "contracts.ss"))
|
||||||
|
(provide/contract)))
|
||||||
|
(eval '(require contract-test-suite2))))
|
||||||
|
|
||||||
|
(test/spec-failed
|
||||||
|
'provide/contract3
|
||||||
|
'(let ()
|
||||||
|
(eval '(module contract-test-suite3 mzscheme
|
||||||
|
(require (lib "contracts.ss"))
|
||||||
|
(provide/contract (x integer?))
|
||||||
|
(define x #f)))
|
||||||
|
(eval '(require contract-test-suite3))
|
||||||
|
(eval 'x))
|
||||||
|
"contract-test-suite3")
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'provide/contract4
|
||||||
|
'(let ()
|
||||||
|
(eval '(module contract-test-suite4 mzscheme
|
||||||
|
(require (lib "contracts.ss"))
|
||||||
|
(provide/contract (struct s ((a any?))))
|
||||||
|
(define-struct s (a))))
|
||||||
|
(eval '(require contract-test-suite4))
|
||||||
|
(eval '(list make-s s-a s? set-s-a!))))
|
||||||
|
|
||||||
|
|
||||||
|
))
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
Loading…
Reference in New Issue
Block a user