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

started a test suite for the check syntax coloring annotations that the contract system leaves behind

Browse Source
This commit is contained in:
Robby Findler 2010-09-03 13:57:59 -05:00
parent 992de7fb10
commit 994c28d8b0
3 changed files with 108 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/drracket/private/syncheck/contract-traversal.rkt
View File

@ -9,7 +9,6 @@
(define (annotate-contracts stx low-binders binding-inits) (define (annotate-contracts stx low-binders binding-inits)
(define boundary-start-map (make-hash)) (define boundary-start-map (make-hash))
(define internal-start-map (make-hash)) (define internal-start-map (make-hash))
(define arrow-map (make-hash))
(define domain-map (make-hash)) (define domain-map (make-hash))
(define range-map (make-hash)) (define range-map (make-hash))
@ -23,7 +22,6 @@
(add-to-map stx 'racket/contract:internal-contract internal-start-map) (add-to-map stx 'racket/contract:internal-contract internal-start-map)
(add-to-map stx 'racket/contract:negative-position domain-map) (add-to-map stx 'racket/contract:negative-position domain-map)
(add-to-map stx 'racket/contract:positive-position range-map) (add-to-map stx 'racket/contract:positive-position range-map)
(add-to-map stx 'racket/contract:function-contract arrow-map)
(syntax-case stx () (syntax-case stx ()
[(a . b) (loop #'a) (loop #'b)] [(a . b) (loop #'a) (loop #'b)]
[_ (void)])) [_ (void)]))
@ -34,7 +32,7 @@
(do-contract-traversal start-stx #t (do-contract-traversal start-stx #t
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits low-binders binding-inits
arrow-map domain-map range-map domain-map range-map
#t))) #t)))
;; fill in the coloring-plans table for internal contracts ;; fill in the coloring-plans table for internal contracts
@ -43,7 +41,7 @@
(do-contract-traversal start-stx #f (do-contract-traversal start-stx #f
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits low-binders binding-inits
arrow-map domain-map range-map domain-map range-map
#f))) #f)))
;; enact the coloring plans ;; enact the coloring plans
@ -63,7 +61,7 @@
(define (do-contract-traversal start-stx boundary-contract? (define (do-contract-traversal start-stx boundary-contract?
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity) low-binders binding-inits domain-map range-map polarity)
(let ploop ([stx start-stx] (let ploop ([stx start-stx]
[polarity polarity]) [polarity polarity])
@ -89,11 +87,11 @@
(for ((stx (in-list (hash-ref domain-map id '())))) (for ((stx (in-list (hash-ref domain-map id '()))))
(do-contract-traversal stx boundary-contract? (do-contract-traversal stx boundary-contract?
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map (not polarity))) low-binders binding-inits domain-map range-map (not polarity)))
(for ((stx (in-list (hash-ref range-map id '())))) (for ((stx (in-list (hash-ref range-map id '()))))
(do-contract-traversal stx boundary-contract? (do-contract-traversal stx boundary-contract?
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity)))]))] low-binders binding-inits domain-map range-map polarity)))]))]
[else [else
;; we didn't find a contract, but we might find one in a subexpression ;; we didn't find a contract, but we might find one in a subexpression
@ -159,10 +157,10 @@
;; on one side will not pollute the other side. ;; on one side will not pollute the other side.
(do-contract-traversal #'b boundary-contract? (do-contract-traversal #'b boundary-contract?
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity) low-binders binding-inits domain-map range-map polarity)
(do-contract-traversal #'c boundary-contract? (do-contract-traversal #'c boundary-contract?
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity)] low-binders binding-inits domain-map range-map polarity)]
;; [(begin expr ...) (void)] ;; [(begin expr ...) (void)]
[(begin0 fst rst ...) [(begin0 fst rst ...)
(ploop #'fst polarity)] (ploop #'fst polarity)]

16
collects/racket/contract/private/arr-i.rkt
View File

@ -739,7 +739,15 @@
#f))) #f)))
#,(and (istx-post an-istx) (map syntax-e (pre/post-vars (istx-post an-istx)))))) #,(and (istx-post an-istx) (map syntax-e (pre/post-vars (istx-post an-istx))))))
'racket/contract:contract 'racket/contract:contract
(vector this->i (let ()
;; the ->i in the original input to this guy (define (find-kwd kwd)
(list (car (syntax-e stx))) (for/or ([x (in-list (syntax->list stx))])
'())))))) (and (eq? (syntax-e x) kwd)
x)))
(define pre (find-kwd '#:pre))
(define post (find-kwd '#:post))
(define orig (list (car (syntax-e stx))))
(vector this->i
;; the ->i in the original input to this guy
(if post (cons post orig) orig)
(if pre (list pre) '()))))))))

93
collects/tests/racket/contract-test.rktl
View File

@ -25,6 +25,10 @@
(parameterize ([current-namespace contract-namespace]) (parameterize ([current-namespace contract-namespace])
(compile x))) (compile x)))
(define (contract-expand-once x)
(parameterize ([current-namespace contract-namespace])
(expand-once x)))
(define-syntax (ctest stx) (define-syntax (ctest stx)
(syntax-case stx () (syntax-case stx ()
[(_ a ...) [(_ a ...)
@ -147,13 +151,39 @@
(contract-eval `(,test ,name contract-name ,contract-exp)) (contract-eval `(,test ,name contract-name ,contract-exp))
(contract-eval `(,test ,name contract-name (opt/c ,contract-exp)))) (contract-eval `(,test ,name contract-name (opt/c ,contract-exp))))
(test/spec-passed
'contract-flat1
'(contract not #f 'pos 'neg))
(test/pos-blame (define (test-obligations quoted-expr expected-props)
'contract-flat2
'(contract not #t 'pos 'neg)) (define (cleanup key obj stx)
(case key
[(racket/contract:contract)
(let ([cleanup-ent
(λ (x)
(sort (map syntax->datum (vector-ref obj x)) string<=? #:key (λ (x) (format "~s" x))))])
(list key (cleanup-ent 1) (cleanup-ent 2)))]
[(racket/contract:positive-position racket/contract:negative-position)
(list key (syntax->datum stx))]
[(racket/contract:contract-on-boundary) `(racket/contract:contract-on-boundary ,(syntax->datum stx))]
[(racket/contract:internal-contract) `(racket/contract:internal-contract ,(syntax->datum stx))]
[else
(error 'test-obligations "unknown property ~s" key)]))
(let ([props '()])
(let ([stx (contract-expand-once quoted-expr)])
(let loop ([stx stx])
(cond
[(syntax? stx)
(for ([key (in-list (syntax-property-symbol-keys stx))])
(when (regexp-match #rx"^racket/contract:" (symbol->string key))
(set! props (cons (cleanup key (syntax-property stx key) stx)
props))))
(loop (syntax-e stx))]
[(pair? stx)
(loop (car stx))
(loop (cdr stx))])))
(test expected-props
`(obligations-for ,quoted-expr)
(sort props string<=? #:key (λ (x) (format "~s" x))))))
; ;
@ -172,7 +202,6 @@
; ;
; ;
(test/no-error '(-> integer? integer?)) (test/no-error '(-> integer? integer?))
(test/no-error '(-> (flat-contract integer?) (flat-contract integer?))) (test/no-error '(-> (flat-contract integer?) (flat-contract integer?)))
(test/no-error '(-> integer? any)) (test/no-error '(-> integer? any))
@ -3339,6 +3368,15 @@
(reverse x)) (reverse x))
'(3 1 2 4)) '(3 1 2 4))
(test/spec-passed
'contract-flat1
'(contract not #f 'pos 'neg))
(test/pos-blame
'contract-flat2
'(contract not #t 'pos 'neg))
; ;
; ;
@ -9549,6 +9587,47 @@ so that propagation occurs.
(λ (x) x))) (λ (x) x)))
11) 11)
;
;
;
; ;;
; ;; ;;
; ;;
; ;;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;; ;; ;;;; ;;;
; ;;;;; ;;;;;;;;; ;;;;; ;;;;;;;;;;;;;; ;; ;;;;;;;;;;;
; ;; ;; ;; ;; ;; ;; ;; ;;; ;;;; ;; ;; ;;;;;;;;
; ;; ;; ;; ;; ;; ;; ;; ;;;;;;;; ;; ;; ;;;;;; ;;;
; ;;;;; ;; ;;;;; ;;;;; ;;;;;;;; ;; ;; ;;;;;;;; ;;
; ;;;; ;; ;;; ;;;; ;;;; ;; ;;; ;; ;;;; ;;;
; ;; ;;
; ;; ;;
;
(test-obligations '(-> a b)
'((racket/contract:contract (->) ())
(racket/contract:negative-position a)
(racket/contract:positive-position b)))
(test-obligations '(->i ([x a]) any)
'((racket/contract:contract (->i) ())
(racket/contract:contract-on-boundary a)
(racket/contract:negative-position a)))
(test-obligations '(->i ([x a]) [res b])
'((racket/contract:contract (->i) ())
(racket/contract:contract-on-boundary a)
(racket/contract:contract-on-boundary b)
(racket/contract:negative-position a)
(racket/contract:positive-position b)))
(test-obligations '(->i ([x a]) #:pre () #t [res b] #:post () #t)
'((racket/contract:contract (->i #:post) (#:pre))
(racket/contract:contract-on-boundary a)
(racket/contract:contract-on-boundary b)
(racket/contract:negative-position a)
(racket/contract:positive-position b)))
(test-obligations '(listof a)
'((racket/contract:contract (listof) ())
(racket/contract:positive-position a)))
; ;
; ;