From e34a2484512b94d7f829a013694caf46e360420c Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Wed, 5 Mar 2014 10:05:06 -0800 Subject: [PATCH] Changes printer to be more consistent. Also make printer tests part of the unit tests. --- .../typed-racket/typecheck/check-below.rkt | 4 ++-- .../typed-racket/types/printer.rkt | 2 +- .../typed-racket/unit-tests/all-tests.rkt | 1 + .../unit-tests/check-below-tests.rkt | 21 +++++++++++++++++-- .../unit-tests/type-printer-tests.rkt | 3 +++ 5 files changed, 26 insertions(+), 5 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt index 65379ed5cf..5c2937647a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt @@ -18,7 +18,7 @@ (define (print-object o) (match o - [(Empty:) "no object"] + [(or (NoObject:) (Empty:)) "no object"] [_ (format "object ~a" o)])) ;; If expected is #f, then just return tr1 @@ -101,7 +101,7 @@ (type-mismatch f2 f1 "mismatch in filter")] [(and (filter-better? f1 f2) (not (object-better? o1 o2))) - (type-mismatch o2 o1 "mismatch in object")] + (type-mismatch (print-object o2) (print-object o1) "mismatch in object")] [(and (not (filter-better? f1 f2)) (not (object-better? o1 o2))) (type-mismatch (format "`~a' and `~a'" f2 (print-object o2)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt index 956213b08f..95d4937833 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt @@ -505,7 +505,7 @@ [(Instance: (? Class? cls)) (class->sexp cls #:object? #t)] [(ClassTop:) 'ClassTop] [(? Class?) (class->sexp type)] - [(Result: t (FilterSet: (Top:) (Top:)) (Empty:)) (type->sexp t)] + [(Result: t (or (NoFilter:) (FilterSet: (Top:) (Top:))) (or (NoObject:) (Empty:))) (type->sexp t)] [(Result: t fs (Empty:)) `(,(type->sexp t) : ,(filter->sexp fs))] [(Result: t fs lo) `(,(type->sexp t) : ,(filter->sexp fs) : ,(object->sexp lo))] [(MPair: s t) `(MPairof ,(t->s s) ,(t->s t))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 02d31a1c7a..bbaf0b5345 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -33,6 +33,7 @@ "special-env-typecheck-tests.rkt" "contract-tests.rkt" "interactive-tests.rkt" + "type-printer-tests.rkt" "class-tests.rkt" "class-util-tests.rkt" "check-below-tests.rkt" diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/check-below-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/check-below-tests.rkt index 5b999bd8d0..4464163777 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/check-below-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/check-below-tests.rkt @@ -1,9 +1,9 @@ #lang racket/base (require "test-utils.rkt" - rackunit + rackunit racket/list (types abbrev union tc-result) - (rep filter-rep) + (rep filter-rep object-rep) (typecheck check-below) (for-syntax racket/base syntax/parse)) @@ -31,6 +31,23 @@ (ret (list -Symbol) (list -top-filter) (list -no-obj)) (ret (list Univ) (list -true-filter) (list -no-obj))) + (test-below #:fail #rx"no object" + (ret (list -Symbol) (list -top-filter) (list -no-obj)) + (ret (list Univ) (list -top-filter) (list (make-Path empty #'x)))) + + (test-below #:fail #rx"no object" + (ret (list -Symbol) (list -top-filter) (list -empty-obj)) + (ret (list Univ) (list -top-filter) (list (make-Path empty #'x)))) + + (test-below #:fail #rx"no object" + (ret (list -Symbol) (list -top-filter) (list -no-obj)) + (ret (list Univ) (list -true-filter) (list (make-Path empty #'x)))) + + (test-below #:fail #rx"no object" + (ret (list -Symbol) (list -top-filter) (list -empty-obj)) + (ret (list Univ) (list -true-filter) (list (make-Path empty #'x)))) + + ;; Enable these once check-below is fixed #; (test-below #:fail diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt index b227e31715..379f452545 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt @@ -71,6 +71,9 @@ (check-prints-as? (-> -Input-Port (make-Values (list (-result -String -true-filter) (-result -String -true-filter)))) "(-> Input-Port (values (String : (Top | Bot)) (String : (Top | Bot))))") + (check-prints-as? (-> Univ (make-Values (list (-result -String -top-filter -empty-obj) + (-result -String -no-filter -no-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)")