From 731a754e2b3cc6ac4eed277efdac2105803dc005 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 11 Feb 2011 09:06:43 -0600 Subject: [PATCH] added tests that check on provide/contract when there are multiple files containing modules related to PR 11724 related to PR 11084 --- collects/racket/contract/private/blame.rkt | 1 + collects/tests/racket/contract-test.rktl | 224 ++++++++++++++++++++- 2 files changed, 216 insertions(+), 9 deletions(-) diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index 5cdb913fd3..2bfe1b8ada 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -7,6 +7,7 @@ blame-source blame-positive blame-negative + blame-user blame-contract blame-value blame-original? diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 8e66ca0861..51f9745630 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -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))))) + + + +; +; +; +; +; ;;; +; ;;; +; ;;; ;;;; ;; ;;; ;;;;; ;;; ;;; ;;; +; ;;; ;; ;;; ;;;;;;; ;;;;;;; ;;;;; ;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;; ;; +; ;;; ;;;;;;; ;;; ;;; ;;;;; ;;; ;; ;; +; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;; +; ;;; ;;;;;; ;;;;;;; ;;; ;;; ;;;;; ;;; +; ;;; ;;;; ;; ;;; ;;;;;; ;;; ;;; +; ;;; ;;;;; +; ;;;;;; ;;;; +; +; + +; +; +; +; +; ; ; +; ;;; ;;; +; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ;;; ;;; ;;;;;; +; ;;;;; ;;;;; ;;;;;;; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ;;;;; ;;;;;;;; ;; +; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; +; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; +; ;;;;; ;;;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ;;;;; ;;; ;; ;;; +; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;;; +; +; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;