.
original commit: e041f9011678922198c46afde29f05b06c1b27aa
This commit is contained in:
Robby Findler
parent
b0d6dee04b
commit
fc971fb502
|
|
@ -167,7 +167,7 @@ add struct contracts for immutable structs?
|
|||
[(rename . _)
|
||||
(raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)]
|
||||
[(struct struct-name ((field-name contract) ...))
|
||||
(and (identifier? (syntax struct-name))
|
||||
(and (well-formed-struct-name? (syntax struct-name))
|
||||
(andmap identifier? (syntax->list (syntax (field-name ...)))))
|
||||
(let ([sc (build-struct-code provide-stx
|
||||
(syntax struct-name)
|
||||
|
|
@ -180,6 +180,11 @@ add struct contracts for immutable structs?
|
|||
"missing fields"
|
||||
provide-stx
|
||||
clause)]
|
||||
[(struct name . rest)
|
||||
(not (well-formed-struct-name? (syntax name)))
|
||||
(raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them"
|
||||
provide-stx
|
||||
(syntax name))]
|
||||
[(struct name (fields ...))
|
||||
(for-each (lambda (field)
|
||||
(syntax-case field ()
|
||||
|
|
@ -220,11 +225,36 @@ add struct contracts for immutable structs?
|
|||
provide-stx
|
||||
(syntax unk))]))]))
|
||||
|
||||
;; well-formed-struct-name? : syntax -> bool
|
||||
(define (well-formed-struct-name? stx)
|
||||
(or (identifier? stx)
|
||||
(syntax-case stx ()
|
||||
[(name super)
|
||||
(and (identifier? (syntax name))
|
||||
(identifier? (syntax super)))
|
||||
#t]
|
||||
[else #f])))
|
||||
|
||||
;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
|
||||
;; constructs the code for a struct clause
|
||||
;; first arg is the original syntax object, for source locations
|
||||
(define (build-struct-code stx struct-name field-names field-contracts)
|
||||
(let* ([field-contract-ids (map (lambda (field-name)
|
||||
(define (build-struct-code stx struct-name-position field-names field-contracts)
|
||||
(let* ([struct-name (syntax-case struct-name-position ()
|
||||
[(a b) (syntax a)]
|
||||
[else struct-name-position])]
|
||||
[parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)])
|
||||
(and parent-info
|
||||
(let ([fields (cadddr parent-info)])
|
||||
(cond
|
||||
[(null? fields) 0]
|
||||
[(not (car (last-pair fields)))
|
||||
(raise-syntax-error
|
||||
'provide/contract
|
||||
"cannot determine the number of fields in super struct"
|
||||
provide-stx
|
||||
struct-name)]
|
||||
[else (length fields)]))))]
|
||||
[field-contract-ids (map (lambda (field-name)
|
||||
(a:mangle-id provide-stx
|
||||
"provide/contract-field-contract"
|
||||
field-name
|
||||
|
|
@ -239,25 +269,35 @@ add struct contracts for immutable structs?
|
|||
[predicate-id (build-predicate-id struct-name)]
|
||||
[constructor-id (build-constructor-id struct-name)])
|
||||
(with-syntax ([(selector-codes ...)
|
||||
(map (lambda (selector-id field-contract-id)
|
||||
(code-for-one-id stx
|
||||
selector-id
|
||||
(build-selector-contract struct-name
|
||||
predicate-id
|
||||
field-contract-id)
|
||||
#f))
|
||||
selector-ids
|
||||
field-contract-ids)]
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map/count (lambda (selector-id field-contract-id index)
|
||||
(if (or (not parent-struct-count)
|
||||
(parent-struct-count . <= . index))
|
||||
(code-for-one-id stx
|
||||
selector-id
|
||||
(build-selector-contract struct-name
|
||||
predicate-id
|
||||
field-contract-id)
|
||||
#f)
|
||||
#f))
|
||||
selector-ids
|
||||
field-contract-ids))]
|
||||
[(mutator-codes ...)
|
||||
(map (lambda (mutator-id field-contract-id)
|
||||
(code-for-one-id stx
|
||||
mutator-id
|
||||
(build-mutator-contract struct-name
|
||||
predicate-id
|
||||
field-contract-id)
|
||||
#f))
|
||||
mutator-ids
|
||||
field-contract-ids)]
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map/count (lambda (mutator-id field-contract-id index)
|
||||
(if (or (not parent-struct-count)
|
||||
(parent-struct-count . <= . index))
|
||||
(code-for-one-id stx
|
||||
mutator-id
|
||||
(build-mutator-contract struct-name
|
||||
predicate-id
|
||||
field-contract-id)
|
||||
#f)
|
||||
#f))
|
||||
mutator-ids
|
||||
field-contract-ids))]
|
||||
[predicate-code (code-for-one-id stx predicate-id (syntax (-> any? boolean?)) #f)]
|
||||
[constructor-code (code-for-one-id
|
||||
stx
|
||||
|
|
@ -283,6 +323,32 @@ add struct contracts for immutable structs?
|
|||
predicate-code
|
||||
constructor-code
|
||||
(provide struct-name struct:struct-name))))))
|
||||
|
||||
;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
|
||||
(define (map/count f l1 l2)
|
||||
(let loop ([l1 l1]
|
||||
[l2 l2]
|
||||
[i 0])
|
||||
(cond
|
||||
[(and (null? l1) (null? l2)) '()]
|
||||
[(or (null? l1) (null? l2)) (error 'map/count "mismatched lists")]
|
||||
[else (cons (f (car l1) (car l2) i)
|
||||
(loop (cdr l1)
|
||||
(cdr l2)
|
||||
(+ i 1)))])))
|
||||
|
||||
;; extract-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
|
||||
(define (extract-parent-struct-info stx)
|
||||
(syntax-case stx ()
|
||||
[(a b)
|
||||
(syntax-local-value
|
||||
(syntax b)
|
||||
(lambda ()
|
||||
(raise-syntax-error 'provide/contract
|
||||
"expected a struct name"
|
||||
provide-stx
|
||||
(syntax a))))]
|
||||
[a #f]))
|
||||
|
||||
;; build-constructor-contract : syntax (listof syntax) syntax -> syntax
|
||||
(define (build-constructor-contract stx field-contract-ids predicate-id)
|
||||
|
|
|
|||
|
|
@ -1093,11 +1093,29 @@
|
|||
'provide/contract7
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite7 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b))
|
||||
(define-struct (t s) (c d))
|
||||
(provide/contract
|
||||
(struct s ((a any?) (b any?)))
|
||||
(struct (t s) ((a any?) (b any?) (c any?) (d any?))))))
|
||||
(eval '(require contract-test-suite7))
|
||||
(eval '(let ([x (make-t 1 2 3 4)])
|
||||
(s-a x)
|
||||
(s-b x)
|
||||
(t-c x)
|
||||
(t-d x)
|
||||
(void)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract8
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite8 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(provide/contract (rename the-internal-name the-external-name integer?))
|
||||
(define the-internal-name 1)
|
||||
(+ the-internal-name 1)))
|
||||
(eval '(require contract-test-suite7))
|
||||
(eval '(require contract-test-suite8))
|
||||
(eval '(+ the-external-name 1))))
|
||||
|
||||
|
||||
|
|
@ -1164,6 +1182,27 @@
|
|||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed/result
|
||||
'object-contract/field6
|
||||
'(send (contract (object-contract [m (integer? . -> . integer?)])
|
||||
(new (class object% (define x 1) (define/public (m y) x) (super-new)))
|
||||
'pos
|
||||
'neg)
|
||||
m
|
||||
2)
|
||||
1)
|
||||
|
||||
#;
|
||||
(test/spec-passed/result
|
||||
'object-contract/field7
|
||||
'(send (contract (object-contract)
|
||||
(new (class object% (define x 1) (define/public (m y) x) (super-new)))
|
||||
'pos
|
||||
'neg)
|
||||
m
|
||||
2)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
'object-contract->1
|
||||
'(send
|
||||
|
|
@ -2378,6 +2417,21 @@
|
|||
(test/well-formed #'(case-> (->d* (any? any?) (lambda x any?)) (-> integer? integer?)))
|
||||
(test/well-formed #'(case-> (->d* (any? any?) any? (lambda x any?)) (-> integer? integer?)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ;;
|
||||
;; Inferred Name Tests ;;
|
||||
;; ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(eval
|
||||
'(module contract-test-suite-inferred-name1 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define contract-inferred-name-test-contract (-> integer? any))
|
||||
(define (contract-inferred-name-test x) #t)
|
||||
(provide/contract (contract-inferred-name-test contract-inferred-name-test-contract))))
|
||||
(eval '(require contract-test-suite-inferred-name1))
|
||||
(eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ;;
|
||||
;; Contract Name Tests ;;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user