81b134cbb9
This PR adds about half of the needed primitives and logic for reasoning about linear integer arithmetic in programs with interesting dependent types. Things have been added in a way s.t. programs will still continue to typecheck as they did, but if you want integer literals and certain operations (e.g. *,+,<,<=,=,>=,>) to include linear inequality information by default, you need to include the '#:with-linear-integer-arithmetic' keyword at the top of your module. The other features needed to get TR to be able to check things like verified vector operations will be to ajust function types so dependencies can exist between arguments and a minor tweak to get type inference to consider the symbolic objects of functions arguments. These features should be coming shortly in a future pull request.
252 lines
14 KiB
Racket
252 lines
14 KiB
Racket
#lang racket/base
|
|
|
|
;; Tests for type, prop, object, etc. printers for Typed Racket
|
|
|
|
(require "test-utils.rkt"
|
|
rackunit
|
|
racket/match
|
|
typed-racket/standard-inits
|
|
typed-racket/tc-setup
|
|
typed-racket/rep/type-rep
|
|
typed-racket/rep/values-rep
|
|
typed-racket/types/abbrev
|
|
typed-racket/types/prop-ops
|
|
typed-racket/types/numeric-tower
|
|
typed-racket/types/printer
|
|
typed-racket/utils/tc-utils
|
|
(submod typed-racket/base-env/base-types initialize))
|
|
|
|
(provide tests)
|
|
(gen-test-main)
|
|
|
|
(define y #'y)
|
|
(define z #'z)
|
|
|
|
(define (prints-as? thing expected)
|
|
(cond
|
|
[(string? expected) (string=? (format "~a" thing) expected)]
|
|
[(procedure? expected) (expected (format "~a" thing))]
|
|
[else (error 'prints-as? "unsupported expected ~a" expected)]))
|
|
|
|
(define (pretty-prints-as? thing str)
|
|
(string=? (pretty-format-rep thing) str))
|
|
|
|
(define-binary-check (check-prints-as? prints-as? actual expected))
|
|
(define-binary-check (check-pretty-prints-as? pretty-prints-as? actual expected))
|
|
|
|
;; Using `do-standard-inits` here does not work when the file is invoked
|
|
;; individually (rather than through the test harness)
|
|
(initialize-type-names)
|
|
(current-type-names (init-current-type-names))
|
|
|
|
(define tests
|
|
(test-suite
|
|
"Printing tests"
|
|
(test-suite
|
|
"Type printing tests"
|
|
(check-prints-as? (-val 3) "3")
|
|
(check-prints-as? (-val 'a) "'a")
|
|
(check-prints-as? (-val #\a) "#\\a")
|
|
(check-prints-as? Univ "Any")
|
|
(check-prints-as? (Un (-val #t) (-val #f)) "Boolean")
|
|
(check-prints-as? (-lst -Nat) "(Listof Nonnegative-Integer)")
|
|
(check-prints-as? (make-App (-poly (a) (-lst a)) (list -Nat))
|
|
"(Listof Nonnegative-Integer)")
|
|
(check-prints-as? (make-Mu 'x (Un -Null (-pair -Nat (make-F 'x))))
|
|
"(Listof Nonnegative-Integer)")
|
|
(check-prints-as? (-lst* -String -Symbol) "(List String Symbol)")
|
|
|
|
;; next three cases for PR 14552
|
|
(check-prints-as? (-mu x (Un (-pair x x) -Null))
|
|
"(Rec x (U (Pairof x x) Null))")
|
|
(check-prints-as? (-mu x (Un (-pair (-box x) x) -Null))
|
|
"(Rec x (U (Pairof (Boxof x) x) Null))")
|
|
(check-prints-as? (-mu x (Un (-mpair x x) -Null))
|
|
"(Rec x (U (MPairof x x) Null))")
|
|
|
|
(check-prints-as? -Custodian "Custodian")
|
|
(check-prints-as? (make-Opaque #'integer?) "(Opaque integer?)")
|
|
(check-prints-as? (make-Vector -Nat) "(Vectorof Nonnegative-Integer)")
|
|
(check-prints-as? (make-HeterogeneousVector (list -Symbol -String))
|
|
"(Vector Symbol String)")
|
|
(check-prints-as? (-box (-val 3)) "(Boxof 3)")
|
|
(check-prints-as? (make-Future -Void) "(Futureof Void)")
|
|
(check-prints-as? (-> -String -Void) "(-> String Void)")
|
|
(check-prints-as? (Un -String -Void) "(U String Void)")
|
|
(check-prints-as? (-pair -String -Void) "(Pairof String Void)")
|
|
(check-prints-as? (make-ListDots -Boolean 'x) "(List Boolean ... x)")
|
|
(check-prints-as? (make-F 'X) "X")
|
|
(check-prints-as? (make-Values (list (-result -String) (-result -Symbol)))
|
|
"(values String Symbol)")
|
|
(check-prints-as? (make-ValuesDots (list (-result -String) (-result -Symbol)) (make-F 'x) 'x)
|
|
"(values String Symbol x ... x)")
|
|
(check-prints-as? (-polydots (a b) (->... (list a) (b b) a))
|
|
"(All (a b ...) (-> a b ... b a))")
|
|
(check-prints-as? (-mu x (-lst x)) "(Rec x (Listof x))")
|
|
(check-prints-as? (-seq -String -Symbol) "(Sequenceof String Symbol)")
|
|
(check-prints-as? (-poly (a) (-> a -Void)) "(All (a) (-> a Void))")
|
|
(check-prints-as? (-> -Input-Port (make-Values (list (-result -String -true-propset)
|
|
(-result -String -true-propset))))
|
|
"(-> Input-Port (values (String : (Top | Bot)) (String : (Top | Bot))))")
|
|
(check-prints-as? (make-pred-ty -String)
|
|
"(-> Any Boolean : String)")
|
|
(check-prints-as? (asym-pred Univ -Boolean (-PS (-is-type 0 -String) -tt))
|
|
"(-> Any Boolean : #:+ String)")
|
|
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type 0 -String) -tt))
|
|
"(-> Any Any Boolean)")
|
|
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type 1 -String) -tt))
|
|
"(-> Any Any Boolean)")
|
|
;; PR 14510 (next three tests)
|
|
(check-prints-as? (-> Univ (-> Univ -Boolean : (-PS (-is-type '(1 . 0) -String)
|
|
(-not-type '(1 . 0) -String))))
|
|
"(-> Any (-> Any Boolean))")
|
|
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type '(0 . 1) -String)
|
|
(-not-type '(0 . 1) -String)))
|
|
"(-> Any Any Boolean)")
|
|
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type '(0 . 0) -String)
|
|
(-not-type '(0 . 0) -String)))
|
|
"(-> Any Any Boolean)")
|
|
(check-prints-as? (-> Univ (make-Values (list (-result -String -tt-propset -empty-obj)
|
|
(-result -String -tt-propset -empty-obj))))
|
|
"(-> Any (values String String))")
|
|
;; this case tests that the Number union is printed with its name
|
|
;; rather than its expansion (a former bug)
|
|
(check-prints-as? (->* '() -Number -Void) "(-> Number * Void)")
|
|
(check-prints-as? (->key Univ -Pathlike
|
|
#:exists
|
|
(one-of/c 'error 'append 'update 'replace
|
|
'truncate 'truncate/replace)
|
|
#f
|
|
#:mode
|
|
(one-of/c 'binary 'text)
|
|
#f
|
|
-Void)
|
|
(string-append "(-> Any Path-String [#:exists (U 'append"
|
|
" 'error 'replace 'truncate 'truncate/replace"
|
|
" 'update)] [#:mode (U"
|
|
" 'binary 'text)] Void)"))
|
|
(check-prints-as? (-> Univ (-AnyValues -tt)) "(-> Any AnyValues)")
|
|
(check-prints-as? (-> Univ (-AnyValues (-is-type '(0 . 0) -String)))
|
|
"(-> Any AnyValues : (: (0 0) String))")
|
|
(check-prints-as? (-AnyValues -tt) "AnyValues")
|
|
(check-prints-as? (-AnyValues (-is-type '(0 . 0) -String))
|
|
"(AnyValues : (: (0 0) String))")
|
|
|
|
(check-prints-as? (->opt Univ [] -Void) "(-> Any Void)")
|
|
(check-prints-as? (->opt [-String] -Void) "(->* () (String) Void)")
|
|
(check-prints-as? (->opt Univ [-String] -Void) "(->* (Any) (String) Void)")
|
|
(check-prints-as? (->opt Univ -Symbol [-String] -Void)
|
|
"(->* (Any Symbol) (String) Void)")
|
|
(check-prints-as? (->optkey Univ [-String] #:x -String #f -Void)
|
|
"(->* (Any) (String #:x String) Void)")
|
|
(check-prints-as? (->optkey Univ [-String] #:x -String #t -Void)
|
|
"(->* (Any #:x String) (String) Void)")
|
|
(check-prints-as? (->optkey Univ [-String] #:x -String #t -Void)
|
|
"(->* (Any #:x String) (String) Void)")
|
|
(check-prints-as? (->optkey Univ [-String] #:rest -String #:x -String #t -Void)
|
|
"(->* (Any #:x String) (String) #:rest String Void)")
|
|
(check-prints-as? (cl->* (->opt -Pathlike [-String] -Void)
|
|
(->optkey Univ [-String] #:rest -String #:x -String #t -Void))
|
|
(string-append "(case-> (->* (Path-String) (String) Void) "
|
|
"(->* (Any #:x String) (String) #:rest String Void))"))
|
|
(check-prints-as? (make-Unit null null null (-values (list -String)))
|
|
"(Unit (import) (export) (init-depend) String)")
|
|
;; Setup for slightly more complex unit printing test
|
|
(let* ([a^ (make-Signature #'a^ #f null)]
|
|
[a-sub^ (make-Signature #'a-sub^ #'a^ (list (cons #'a -String)))]
|
|
[b^ (make-Signature #'b^ #f (list (cons #'b -Integer)))]
|
|
[c^ (make-Signature #'c^ #f (list (cons #'c -Symbol)))]
|
|
[d^ (make-Signature #'d^ #f (list (cons #'d -String)))])
|
|
(check-prints-as? (make-Unit (list a^) null null (-values (list -String)))
|
|
"(Unit (import a^) (export) (init-depend) String)")
|
|
(check-prints-as? (make-Unit (list a^) (list b^) null (-values (list -String)))
|
|
"(Unit (import a^) (export b^) (init-depend) String)")
|
|
(check-prints-as? (make-Unit (list a^) (list b^) (list a^) (-values (list -String)))
|
|
"(Unit (import a^) (export b^) (init-depend a^) String)")
|
|
(check-prints-as? (make-Unit (list a-sub^) null null (-values (list -String)))
|
|
"(Unit (import a-sub^) (export) (init-depend) String)")
|
|
(check-prints-as? (make-Unit (list a-sub^) null (list a-sub^) (-values (list -String)))
|
|
"(Unit (import a-sub^) (export) (init-depend a-sub^) String)")
|
|
(check-prints-as? (make-Unit null (list a-sub^) null (-values (list -String)))
|
|
"(Unit (import) (export a-sub^) (init-depend) String)")
|
|
(check-prints-as? (make-Unit (list a^ b^) (list c^ d^) null (-values (list -String)))
|
|
"(Unit (import a^ b^) (export c^ d^) (init-depend) String)")
|
|
(check-prints-as? (make-Unit (list a^ b^) null null (-values (list -String)))
|
|
"(Unit (import a^ b^) (export) (init-depend) String)")
|
|
(check-prints-as? (make-Unit null (list c^ d^) null (-values (list -String)))
|
|
"(Unit (import) (export c^ d^) (init-depend) String)")
|
|
(check-prints-as? (make-Unit (list a^ b^) (list c^ d^) (list b^) (-values (list -String)))
|
|
"(Unit (import a^ b^) (export c^ d^) (init-depend b^) String)")
|
|
(check-prints-as? (make-Unit (list a^ b^) (list c^ d^) (list b^ a^) (-values (list -String)))
|
|
"(Unit (import a^ b^) (export c^ d^) (init-depend b^ a^) String)"))
|
|
(check-prints-as? -UnitTop "UnitTop")
|
|
(check-prints-as? (-refine/fresh x -Int (-leq (-lexp x) (-lexp 42)))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : Integer] (<= ,x 42)) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x (-pair -Int -Int) (-leq (-lexp (-car-of (-id-path x)))
|
|
(-lexp (-cdr-of (-id-path x)))))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : (Pairof Integer Integer)] (<= (car ,x) (cdr ,x))) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x (-vec Univ) (-leq (-lexp (-vec-len-of (-id-path x)))
|
|
(-lexp 42)))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : (Vectorof Any)] (<= (vector-length ,x) 42)) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 42))
|
|
(-leq (-lexp 42) (-lexp x))
|
|
(-leq (-lexp 1 x) (-lexp #'y))))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : Integer] (and (= ,x 42) (< ,x y))) #t]
|
|
[`(Refine [,x : Integer] (and (= 42 ,x) (< ,x y))) #t]
|
|
[`(Refine [,x : Integer] (and (< ,x y) (= ,x 42))) #t]
|
|
[`(Refine [,x : Integer] (and (< ,x y) (= ,x 42))) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 42))
|
|
(-leq (-lexp 42) (-lexp x))))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : Integer] (= ,x 42)) #t]
|
|
[`(Refine [,x : Integer] (= 42 ,x)) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x -Int (-is-type #'y -Int))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : Integer] (: y Integer)) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x -Int (-not-type #'y -Int))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : Integer] (! y Integer)) #t]
|
|
[_ #f])))
|
|
(check-prints-as? (-refine/fresh x -Int (-or (-is-type #'y -Int)
|
|
(-is-type #'z -String)))
|
|
(λ (str) (match (read (open-input-string str))
|
|
[`(Refine [,x : Integer] (or (: y Integer) (: z String))) #t]
|
|
[`(Refine [,x : Integer] (or (: z String) (: y Integer))) #t]
|
|
[_ #f]))))
|
|
(test-suite
|
|
"Pretty printing tests"
|
|
(check-pretty-prints-as? (-val 3) "3")
|
|
(check-pretty-prints-as? (-val 'a) "'a")
|
|
(check-pretty-prints-as? (-val #\a) "#\\a")
|
|
(check-pretty-prints-as? Univ "Any")
|
|
(check-pretty-prints-as? (Un (-val #t) (-val #f)) "Boolean")
|
|
(check-pretty-prints-as? (-lst -Nat) "(Listof Nonnegative-Integer)")
|
|
(check-pretty-prints-as?
|
|
(-polydots (c a b)
|
|
(cl->*
|
|
(-> (-> a c) (-pair a (-lst a)) (-pair c (-lst c)))
|
|
((list
|
|
((list a) (b b) . ->... . c)
|
|
(-lst a))
|
|
((-lst b) b) . ->... .(-lst c))))
|
|
(string-append "(All (c a b ...)\n"
|
|
" (case->\n"
|
|
" (-> (-> a c) (Pairof a (Listof a)) (Pairof c (Listof c)))\n"
|
|
" (-> (-> a b ... b c) (Listof a) (Listof b) ... b (Listof c))))"))
|
|
(check-pretty-prints-as?
|
|
(-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a))
|
|
(-> (-Syntax Univ) Univ Univ)))
|
|
(string-append "(All (a)\n"
|
|
" (case-> (-> (Syntaxof a) Any Any (Syntaxof a)) (-> (Syntaxof Any) Any Any)))")))))
|
|
|