From 0e17e027514ab1b0de77e52cc4428760904da79d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 15 Aug 2011 17:54:24 -0400 Subject: [PATCH] Refactor unit tests to handle tests that need base-special-env separately. original commit: c54fc6d6d79cec39fa7236fd314842f809feab73 --- .../typed-scheme/unit-tests/all-tests.rkt | 4 +- .../special-env-typecheck-tests.rkt | 120 ++++++++++++++++++ .../unit-tests/typecheck-tests.rkt | 86 ++----------- 3 files changed, 134 insertions(+), 76 deletions(-) create mode 100644 collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.rkt b/collects/tests/typed-scheme/unit-tests/all-tests.rkt index 19ed558a..46c9c118 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/all-tests.rkt @@ -36,7 +36,9 @@ type-annotation-tests module-tests fv-tests - contract-tests)]) + contract-tests + ;; this uses dynamic require because the file fails to compile when there's a test failure + (λ () ((dynamic-require "unit-tests/special-env-typecheck-tests.rkt" 'typecheck-special-tests))))]) (f)))) diff --git a/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt new file mode 100644 index 00000000..ff0d1af2 --- /dev/null +++ b/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt @@ -0,0 +1,120 @@ +#lang racket + +(require "test-utils.rkt" + (for-syntax scheme/base) + (for-template scheme/base) + (rep type-rep filter-rep object-rep) + (for-syntax (rename-in (types utils union convenience abbrev filter-ops) + [Un t:Un] + [true-lfilter -true-lfilter] + [true-filter -true-filter] + [-> t:->])) + (except-in (utils tc-utils utils) infer) + typed-scheme/infer/infer-dummy typed-scheme/infer/infer + unstable/mutated-vars + + rackunit rackunit/text-ui + syntax/parse + racket/file racket/port + (for-syntax syntax/kerncase syntax/parse racket/syntax + (types abbrev convenience utils) + unstable/mutated-vars + (utils tc-utils) (typecheck typechecker)) + typed-scheme/base-env/prims + typed-scheme/base-env/base-types + (only-in typed-scheme/typed-scheme do-standard-inits)) + +(begin-for-syntax (do-standard-inits)) + +(define-syntax-rule (tc-e/t e t) (tc-e e #:ret (ret t (-FS -top -bot)))) + +(define-syntax (tc-e stx) + (syntax-parse stx + [(_ expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))] + [(_ a #:ret b) + (quasisyntax/loc stx + (check-tc-result-equal? (format "~a ~a" #,(syntax-line stx) 'expr) + #,(let ([ex (local-expand #'a 'expression null)]) + (parameterize ([mutated-vars (find-mutated-vars ex)]) + (tc-expr ex))) + #,(syntax-local-eval #'b)))])) + +(define (typecheck-special-tests) + (test-suite + "Typechecker tests" + ;; should work but don't -- need expected type + #| +[tc-e (for/list ([(k v) (in-hash #hash((1 . 2)))]) 0) (-lst -Zero)] +[tc-e (in-list (list 1 2 3)) (-seq -Integer)] +[tc-e (in-vector (vector 1 2 3)) (-seq -Integer)] +|# + + [tc-e (in-hash #hash((1 . 2))) (-seq -Integer -Integer)] + [tc-e (in-hash-keys #hash((1 . 2))) (-seq -Integer)] + [tc-e (in-hash-values #hash((1 . 2))) (-seq -Integer)] + + (tc-e (file->string "tmp") -String) + (tc-e (file->string "tmp" #:mode 'binary) -String) + (tc-e (file->string "tmp" #:mode 'text) -String) + + (tc-e (file->bytes "tmp") -Bytes) + (tc-e (file->bytes "tmp" #:mode 'binary) -Bytes) + (tc-e (file->bytes "tmp" #:mode 'text) -Bytes) + + (tc-e (file->list "tmp") (-lst Univ)) + (tc-e ((inst file->list Any) "tmp" #:mode 'binary) (-lst Univ)) + (tc-e ((inst file->list Any) "tmp" #:mode 'text) (-lst Univ)) + + (tc-e (file->list "tmp" (lambda (x) "string")) (-lst -String)) + (tc-e ((inst file->list String) "tmp" (lambda (x) "string") #:mode 'binary) (-lst -String)) + (tc-e ((inst file->list String) "tmp" (lambda (x) "string") #:mode 'text) (-lst -String)) + + (tc-e (file->lines "tmp") (-lst -String)) + (tc-e (file->lines "tmp" #:mode 'text) (-lst -String)) + (tc-e (file->lines "tmp" #:line-mode (first (shuffle '(linefeed return return-linefeed any any-one))) + #:mode 'binary) (-lst -String)) + + + (tc-e (file->bytes-lines "tmp") (-lst -Bytes)) + (tc-e (file->bytes-lines "tmp" #:mode 'text) (-lst -Bytes)) + (tc-e (file->bytes-lines "tmp" #:line-mode (first (shuffle '(linefeed return return-linefeed any any-one))) + #:mode 'binary) (-lst -Bytes)) + + (tc-e (display-to-file "a" "tmp" #:mode (if (= 1 2) 'binary 'text) + #:exists (first (shuffle '(error append update replace truncate truncate/replace)))) + -Void) + + (tc-e (write-to-file "a" "tmp" #:mode (if (= 1 2) 'binary 'text) + #:exists (first (shuffle '(error append update replace truncate truncate/replace)))) + -Void) + + + (tc-e (display-lines-to-file (list 2 'esha "esht") "tmp" #:separator #f + #:mode (if (= 1 2) 'binary 'text) + #:exists (first (shuffle '(error append update replace truncate truncate/replace)))) + -Void) + + (tc-e (get-preference 'pref (lambda () 'error) 'timestamp #f #:use-lock? #t #:timeout-lock-there #f #:lock-there #f) Univ) + + + (tc-e (make-handle-get-preference-locked .3 'sym (lambda () 'eseh) 'timestamp #f #:lock-there #f #:max-delay .45) + (t:-> -Pathlike ManyUniv)) + + (tc-e (call-with-file-lock/timeout #f 'exclusive (lambda () 'res) (lambda () 'err) + #:lock-file "lock" + #:delay .01 + #:max-delay .2) (one-of/c 'res 'err)) + + (tc-e (make-derived-parameter current-input-port + (lambda: ((s : String)) (open-input-file s)) + object-name) (-Param -String Univ)) + + ;; exception handling + [tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" "")) + #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))] + + )) + + +(define-go typecheck-special-tests) +(provide typecheck-special-tests) \ No newline at end of file diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 8660f594..cfb72467 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -5,7 +5,7 @@ (for-template scheme/base)) (require (private type-annotation parse-type) (base-env prims - base-types-extra base-special-env + base-types-extra base-env-indexing base-structs) (typecheck typechecker) (rep type-rep filter-rep object-rep) @@ -20,18 +20,14 @@ (env type-name-env type-env-structs init-envs) rackunit rackunit/text-ui syntax/parse - (for-syntax (utils tc-utils) + (for-syntax (utils tc-utils) racket/file racket/port (typecheck typechecker) (env global-env) - (base-env #;base-env #;base-env-numeric - base-env-indexing base-special-env)) - racket/file + (base-env base-env-indexing)) + racket/file racket/port (for-template - - (base-env #;base-env base-types base-types-extra - #;base-env-numeric - base-special-env - base-env-indexing)) + racket/file racket/port + (base-env base-types base-types-extra base-env-indexing)) (for-syntax syntax/kerncase syntax/parse)) (require (prefix-in b: (base-env base-env)) @@ -39,7 +35,7 @@ (provide typecheck-tests g tc-expr/expand) -(b:init) (n:init) (initialize-structs) (initialize-indexing) (initialize-special) +(b:init) (n:init) (initialize-structs) (initialize-indexing) (define N -Number) (define B -Boolean) @@ -864,15 +860,7 @@ (-lst -Number)] [tc-err (list (values 1 2))] - #| ;; should work but don't (test harness problems) - [tc-e (for/list ([(k v) (in-hash #hash((1 . 2)))]) 0) (-lst -Zero)] - [tc-e (in-list (list 1 2 3)) (-seq -Integer)] - [tc-e (in-vector (vector 1 2 3)) (-seq -Integer)] - |# - [tc-e (in-hash #hash((1 . 2))) (-seq -Integer -Integer)] - [tc-e (in-hash-keys #hash((1 . 2))) (-seq -Integer)] - [tc-e (in-hash-values #hash((1 . 2))) (-seq -Integer)] - + ;;Path tests (tc-e (bytes->path #"foo" 'unix) -SomeSystemPath) (tc-e (bytes->path #"foo") -Path) @@ -1092,46 +1080,7 @@ (tc-e (filesystem-root-list) (-lst -Path)) - (tc-e (file->string "tmp") -String) - (tc-e (file->string "tmp" #:mode 'binary) -String) - (tc-e (file->string "tmp" #:mode 'text) -String) - - (tc-e (file->bytes "tmp") -Bytes) - (tc-e (file->bytes "tmp" #:mode 'binary) -Bytes) - (tc-e (file->bytes "tmp" #:mode 'text) -Bytes) - - (tc-e (file->list "tmp") (-lst Univ)) - (tc-e ((inst file->list Any) "tmp" #:mode 'binary) (-lst Univ)) - (tc-e ((inst file->list Any) "tmp" #:mode 'text) (-lst Univ)) - - (tc-e (file->list "tmp" (lambda (x) "string")) (-lst -String)) - (tc-e ((inst file->list String) "tmp" (lambda (x) "string") #:mode 'binary) (-lst -String)) - (tc-e ((inst file->list String) "tmp" (lambda (x) "string") #:mode 'text) (-lst -String)) - - (tc-e (file->lines "tmp") (-lst -String)) - (tc-e (file->lines "tmp" #:mode 'text) (-lst -String)) - (tc-e (file->lines "tmp" #:line-mode (first (shuffle '(linefeed return return-linefeed any any-one))) - #:mode 'binary) (-lst -String)) - - - (tc-e (file->bytes-lines "tmp") (-lst -Bytes)) - (tc-e (file->bytes-lines "tmp" #:mode 'text) (-lst -Bytes)) - (tc-e (file->bytes-lines "tmp" #:line-mode (first (shuffle '(linefeed return return-linefeed any any-one))) - #:mode 'binary) (-lst -Bytes)) - - (tc-e (display-to-file "a" "tmp" #:mode (if (= 1 2) 'binary 'text) - #:exists (first (shuffle '(error append update replace truncate truncate/replace)))) - -Void) - - (tc-e (write-to-file "a" "tmp" #:mode (if (= 1 2) 'binary 'text) - #:exists (first (shuffle '(error append update replace truncate truncate/replace)))) - -Void) - - - (tc-e (display-lines-to-file (list 2 'esha "esht") "tmp" #:separator #f - #:mode (if (= 1 2) 'binary 'text) - #:exists (first (shuffle '(error append update replace truncate truncate/replace)))) - -Void) + (tc-e (copy-directory/files "tmp/src" "tmp/dest") -Void) (tc-e (delete-directory/files "tmp/src") -Void) @@ -1152,18 +1101,11 @@ (tc-e (make-temporary-file "ee~a" 'directory) -Path) (tc-e (make-temporary-file "ee~a" "temp" "here") -Path) - (tc-e (get-preference 'pref (lambda () 'error) 'timestamp #f #:use-lock? #t #:timeout-lock-there #f #:lock-there #f) Univ) + (tc-e (put-preferences (list 'sym 'sym2) (list 'v1 'v2)) -Void) (tc-e (preferences-lock-file-mode) (one-of/c 'exists 'file-lock)) - (tc-e (make-handle-get-preference-locked .3 'sym (lambda () 'eseh) 'timestamp #f #:lock-there #f #:max-delay .45) - (t:-> -Pathlike ManyUniv)) - - (tc-e (call-with-file-lock/timeout #f 'exclusive (lambda () 'res) (lambda () 'err) - #:lock-file "lock" - #:delay .01 - #:max-delay .2) (one-of/c 'res 'err)) (tc-e (make-lock-file-name "tmp.file") -Pathlike) (tc-e (make-lock-file-name "tmp.dir" "tmp.file") -Pathlike) @@ -1193,10 +1135,7 @@ (tc-e (syntax-span #'here) (-opt -Nat)) - ;Parameters - (tc-e (make-derived-parameter current-input-port - (lambda: ((s : String)) (open-input-file s)) - object-name) (-Param -String Univ)) + ;Parameters (tc-e (parameter-procedure=? current-input-port current-output-port) B) ;Namespaces @@ -1357,9 +1296,6 @@ (promise-running? p)) B) |# - ;; excetion handling - [tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" "")) - #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))] ;Kernel Structs, check that their hidden identifiers type (tc-e (void exn