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

added tests that check on provide/contract when there are multiple files containing modules

Browse Source 
related to PR 11724
  related to PR 11084
This commit is contained in:
Robby Findler 2011-02-11 09:06:43 -06:00
parent 9d2e025e51
commit 731a754e2b
2 changed files with 216 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/racket/contract/private/blame.rkt
View File

@ -7,6 +7,7 @@
blame-source
blame-positive
blame-negative
blame-user
blame-contract
blame-value
blame-original?

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

@ -11263,15 +11263,221 @@ so that propagation occurs.
(compose blame-positive exn:fail:contract:blame-object)
(with-handlers ((void values)) (contract not #t 'pos 'neg))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;
;;;; Legacy Contract Constructor tests
;;;;
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;
;
;
; ;;; ; ;;; ;;;;;;; ;;;
; ;;; ;;; ;;; ;;;
; ;;; ;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;;; ;;; ;;; ;;;;
; ;;;;;;;;;;; ;;; ;;; ;;; ;;;; ;;; ;;;; ;;; ;;; ;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;;;;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;;;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;;
; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;
;
;
;
;
(let ()
;; build-and-run : (listof (cons/c string[filename] (cons/c string[lang-line] (listof sexp[body-of-module]))) -> any
;; sets up the files named by 'test-case', dynamically requires the first one, deletes the files
;; and returns/raises-the-exception from the require'd file
(define (build-and-run test-case)
(define dir (make-temporary-file "contract-test~a" 'directory))
(for ([f (in-list test-case)])
(call-with-output-file (build-path dir (car f))
(lambda (port)
(display (cadr f) port)
(newline port)
(for ([sexp (in-list (cddr f))])
(fprintf port "~s\n" sexp)))))
(dynamic-wind
void
(lambda () (contract-eval `(dynamic-require ,(build-path dir (car (car test-case))) #f)))
(lambda ()
(for ([f (in-list test-case)])
(delete-file (build-path dir (car f))))
(delete-directory dir))))
(define exn:fail:contract:blame-object (contract-eval 'exn:fail:contract:blame-object))
(define (get-last-part-of-path sexp)
(define m (regexp-match #rx"/([-a-z0-9.]*)[^/]*$" (format "~s" sexp)))
(printf "sexp: ~s => ~s\n" (format "~s" sexp) m)
(and m (cadr m)))
;; basic negative blame case
(let ([blame
(exn:fail:contract:blame-object
(with-handlers ((exn? values))
(build-and-run
(list (list "a.rkt"
"#lang racket/base"
'(require "b.rkt")
'(f #f))
(list "b.rkt"
"#lang racket/base"
'(require racket/contract)
'(provide/contract [f (-> integer? integer?)])
'(define (f x) 1))))))])
(ctest "a.rkt"
'multi-file-blame1-positive
(,get-last-part-of-path (blame-positive ,blame)))
(ctest "b.rkt"
'multi-file-blame1-negative
(,get-last-part-of-path (blame-negative ,blame)))
(ctest "a.rkt"
'multi-file-blame1-user
(,get-last-part-of-path (blame-user ,blame))))
;; basic positive blame case
(let ([blame
(exn:fail:contract:blame-object
(with-handlers ((exn? values))
(build-and-run
(list (list "a.rkt"
"#lang racket/base"
'(require "b.rkt")
'(f 1))
(list "b.rkt"
"#lang racket/base"
'(require racket/contract)
'(provide/contract [f (-> integer? integer?)])
'(define (f x) #f))))))])
(ctest "b.rkt"
'multi-file-blame2-positive
(,get-last-part-of-path (blame-positive ,blame)))
(ctest "a.rkt"
'multi-file-blame2-negative
(,get-last-part-of-path (blame-negative ,blame)))
(ctest "a.rkt"
'multi-file-blame2-user
(,get-last-part-of-path (blame-user ,blame))))
;; positive blame via a re-provide
(let ([blame
(exn:fail:contract:blame-object
(with-handlers ((exn? values))
(build-and-run
(list (list "a.rkt"
"#lang racket/base"
'(require "b.rkt")
'(f 1))
(list "b.rkt"
"#lang racket/base"
'(require "c.rkt")
'(provide f))
(list "c.rkt"
"#lang racket/base"
'(require racket/contract)
'(provide/contract [f (-> integer? integer?)])
'(define (f x) #f))))))])
(ctest "c.rkt"
'multi-file-blame3-positive
(,get-last-part-of-path (blame-positive ,blame)))
(ctest "b.rkt"
'multi-file-blame3-negative
(,get-last-part-of-path (blame-negative ,blame)))
(ctest "?.rkt"
'multi-file-blame3-user
(,get-last-part-of-path (blame-user ,blame))))
;; negative blame via a re-provide
(let ([blame
(exn:fail:contract:blame-object
(with-handlers ((exn? values))
(build-and-run
(list (list "a.rkt"
"#lang racket/base"
'(require "b.rkt")
'(f #f))
(list "b.rkt"
"#lang racket/base"
'(require "c.rkt")
'(provide f))
(list "c.rkt"
"#lang racket/base"
'(require racket/contract)
'(provide/contract [f (-> integer? integer?)])
'(define (f x) 1))))))])
(ctest "b.rkt"
'multi-file-blame4-positive
(,get-last-part-of-path (blame-positive ,blame)))
(ctest "c.rkt"
'multi-file-blame4-negative
(,get-last-part-of-path (blame-negative ,blame)))
(ctest "?.rkt"
'multi-file-blame4-user
(,get-last-part-of-path (blame-user ,blame))))
;; have some sharing in the require graph
(let ([blame
(exn:fail:contract:blame-object
(with-handlers ((exn? values))
(build-and-run
(list (list "client.rkt"
"#lang racket/base"
'(require "server.rkt" "other.rkt")
'(turn-init #f))
(list "server.rkt"
"#lang racket/base"
'(require racket/contract)
'(provide/contract [turn-init (-> number? any)])
'(define turn-init void))
(list "other.rkt"
"#lang racket/base"
'(require "server.rkt"))))))])
(ctest "client.rkt"
'multi-file-blame5-positive
(,get-last-part-of-path (blame-positive ,blame)))
(ctest "server.rkt"
'multi-file-blame5-negative
(,get-last-part-of-path (blame-negative ,blame)))
(ctest "server.rkt"
'multi-file-blame5-user
(,get-last-part-of-path (blame-user ,blame)))))
;
;
;
;
; ;;;
; ;;;
; ;;; ;;;; ;; ;;; ;;;;; ;;; ;;; ;;;
; ;;; ;; ;;; ;;;;;;; ;;;;;;; ;;;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;; ;;
; ;;; ;;;;;;; ;;; ;;; ;;;;; ;;; ;; ;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;;
; ;;; ;;;;;; ;;;;;;; ;;; ;;; ;;;;; ;;;
; ;;; ;;;; ;; ;;; ;;;;;; ;;; ;;;
; ;;; ;;;;;
; ;;;;;; ;;;;
;
;
;
;
;
;
; ; ;
; ;;; ;;;
; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ;;; ;;; ;;;;;;
; ;;;;; ;;;;; ;;;;;;; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ;;;;; ;;;;;;;; ;;
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;;
; ;;;;; ;;;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ;;;;; ;;; ;; ;;;
; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;;;
;
;
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;