f9c5a534d0
This pull request is largely a renaming effort to clean up the TR codebase. There are two primary things I wanted to change: 1. Replace all occurrences of "filter" with "prop" or "proposition" - The word "filter" is a meaningless opaque term at this point in the Typed Racket implementation. If anything, it just adds confusion to why things are the way the are. We should use "proposition" instead, since that's what they actually are. 2. Avoid using "Top" and "Bottom" in both the type and proposition realm. - Currently the top type is called Univ and the bottom type is called bottom, while the top proposition is called Top and the bottom proposition is called Bot. This is just unnecessarily confusing, doesn't really line up w/ the user-space names, and doesn't line up with the names we use in TR formalisms. Worse, all of the top types of primitive types---e.g. the type of all structs, StructTop--- use Top, so it is really easy to get confused about what name to use for these sorts of things. With these issues in mind, I made the following changes to names: Top -> TrueProp Bot -> FalseProp TypeFilter -> TypeProp NotTypeFilter -> NotTypeProp AndFilter -> AndProp OrFilter -> OrProp -filter t o -> -is-type o t -not-filter t o -> -not-type o t FilterSet -> PropSet NoFilter -> #f NoObject -> #f -FS -> -PS -top -> -tt -bot -> -ff implied-atomic? q p -> implies-atomic? p q filter-rec-id -> prop-rec-id -no-filter -> -no-propset -top-filter -> -tt-propset -bot-filter -> -ff-propset -true-filter -> -true-propset -false-filter -> -false-propset PredicateFilter: -> PredicateProp: add-unconditional-filter-all-args add-unconditional-prop-all-args
151 lines
6.3 KiB
Racket
151 lines
6.3 KiB
Racket
#lang racket
|
|
|
|
(require "test-utils.rkt"
|
|
"evaluator.rkt"
|
|
(for-syntax racket/base)
|
|
(for-template racket/base)
|
|
(rep type-rep prop-rep object-rep)
|
|
(for-syntax (rename-in (types utils union numeric-tower abbrev prop-ops)
|
|
[Un t:Un]
|
|
[-> t:->]))
|
|
(utils tc-utils utils)
|
|
(utils mutated-vars)
|
|
|
|
rackunit rackunit/text-ui
|
|
syntax/parse
|
|
racket/file racket/port
|
|
syntax/location
|
|
(for-syntax syntax/kerncase syntax/parse racket/syntax
|
|
(types abbrev numeric-tower utils)
|
|
(utils mutated-vars) (env mvar-env)
|
|
(utils tc-utils) (typecheck typechecker))
|
|
typed-racket/base-env/prims
|
|
typed-racket/base-env/base-types
|
|
(for-syntax typed-racket/standard-inits))
|
|
(provide tests)
|
|
(gen-test-main)
|
|
|
|
(begin-for-syntax (do-standard-inits))
|
|
|
|
(define-syntax-rule (tc-e/t e t) (tc-e e #:ret (ret t -true-propset)))
|
|
|
|
(define-syntax (tc-e stx)
|
|
(syntax-parse stx
|
|
[(tc-e expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))]
|
|
[(id a #:ret b)
|
|
(syntax/loc stx
|
|
(test-case (format "~a ~a" (quote-line-number id) 'a)
|
|
(let-values
|
|
([(res1 expanded)
|
|
(phase1-phase0-eval
|
|
(let ([ex (local-expand #'a 'expression null)])
|
|
(find-mutated-vars ex mvar-env)
|
|
#`(values '#,(tc-expr ex) '#,(syntax->datum ex))))]
|
|
[(res2) (phase1-phase0-eval #`'#,b)])
|
|
(with-check-info (['expanded expanded])
|
|
(unless (tc-result-equal/test? res1 res2)
|
|
(fail-check "Expression didn't have expected type."))))))]))
|
|
|
|
(define tests
|
|
(test-suite
|
|
"Special 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 (in-hash-pairs #hash((1 . 2))) (-seq (-pair -Integer -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 Univ))
|
|
|
|
(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))
|
|
(list -true-propset -true-propset))]
|
|
|
|
(tc-e (make-temporary-file) -Path)
|
|
(tc-e (make-temporary-file "ee~a") -Path)
|
|
(tc-e (make-temporary-file "ee~a" 'directory) -Path)
|
|
(tc-e (make-temporary-file "ee~a" "temp" "here") -Path)
|
|
|
|
;; more sequences
|
|
[tc-e (sequence-ref (in-directory) 0) -Path]
|
|
[tc-e (sequence-ref (in-directory "foo" (λ (p) #t)) 0) -Path]
|
|
[tc-e (in-mlist (ann (mcons 'a null) (MListof 'a))) (-seq (-val 'a))]
|
|
[tc-e (in-producer (λ () 'hi)) (-seq (-val 'hi))]
|
|
[tc-e (in-producer (λ: ([x : String]) 'hi) symbol? "foo")
|
|
(-seq (-val 'hi))]
|
|
[tc-e (in-value 'hi) (-seq (-val 'hi))]
|
|
[tc-e (in-indexed '(a b c)) (-seq (one-of/c 'a 'b 'c) -Nat)]
|
|
[tc-e (in-sequences '(a b) '(z y)) (-seq (one-of/c 'a 'b 'z 'y))]
|
|
[tc-e (in-cycle '(a b) '(z y)) (-seq (one-of/c 'a 'b 'z 'y))]
|
|
[tc-e (in-parallel '(a b) '(z y)) (-seq (one-of/c 'a 'b) (one-of/c 'z 'y))]
|
|
[tc-e (in-values-sequence (in-parallel '(a b) '(z y)))
|
|
(-seq (-lst* (one-of/c 'a 'b) (one-of/c 'z 'y)))]
|
|
[tc-e (in-values-sequence '(a b c))
|
|
(-seq (-lst* (one-of/c 'a 'b 'c)))]
|
|
[tc-e (in-values*-sequence (in-parallel '(a b) '(z y)))
|
|
(-seq (-lst* (one-of/c 'a 'b) (one-of/c 'z 'y)))]
|
|
[tc-e (in-values*-sequence '(a b c))
|
|
(-seq (one-of/c 'a 'b 'c))]
|
|
))
|