From 01a0bb28a78618f979bb464033a989cd9b4aa724 Mon Sep 17 00:00:00 2001
From: Stephen Chang <stchang@ccs.neu.edu>
Date: Wed, 6 Apr 2016 17:10:46 -0400
Subject: [PATCH] improve rackunit-typechecking

- speed up by eliminating duplicate expansion in check-type
- use given type annotation as expected-type
  - eliminates unneeded type annotations
---
 tapl/stlc+tup.rkt                     |  3 +-
 tapl/tests/rackunit-typechecking.rkt  | 25 ++++++++-------
 tapl/tests/stlc+occurrence-tests.rkt  | 44 +++++++++++++--------------
 tapl/tests/stlc+overloading-tests.rkt | 14 ++++-----
 4 files changed, 43 insertions(+), 43 deletions(-)

diff --git a/tapl/stlc+tup.rkt b/tapl/stlc+tup.rkt
index ba9a7e1..03e3726 100644
--- a/tapl/stlc+tup.rkt
+++ b/tapl/stlc+tup.rkt
@@ -16,7 +16,8 @@
    #:with ty-expected (get-expected-type stx)
    #:with (e_ann ...) (if (syntax-e #'ty-expected)
                           (syntax-parse (local-expand #'ty-expected 'expression null)
-                           [(~× ty_exp ...) #'((add-expected e ty_exp) ...)])
+                           [(~× ty_exp ...) #'((add-expected e ty_exp) ...)]
+                           [_ #'(e ...)])
                           #'(e ...))
    #:with ([e- τ] ...) (infers+erase #'(e_ann ...))
    (⊢ (list e- ...) : (× τ ...))])
diff --git a/tapl/tests/rackunit-typechecking.rkt b/tapl/tests/rackunit-typechecking.rkt
index e189d24..06ecc53 100644
--- a/tapl/tests/rackunit-typechecking.rkt
+++ b/tapl/tests/rackunit-typechecking.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 (require (for-syntax rackunit) rackunit "../typecheck.rkt")
-(provide (all-defined-out))
+(provide check-type typecheck-fail check-not-type check-props)
 
 (begin-for-syntax
   (define (add-esc s) (string-append "\\" s))
@@ -18,11 +18,18 @@
 
 (define-syntax (check-type stx)
   (syntax-parse stx #:datum-literals (: ⇒ ->)
-    [(_ e : τ (~or ⇒ ->) v)
-     (syntax/loc stx
-       (check-type-and-result e : τ ⇒ v))]
+    ;; duplicate code to avoid redundant expansions
+    [(_ e : τ-expected (~or ⇒ ->) v)
+     #:with e+ (expand/df #'(add-expected e τ-expected))
+     #:with τ (typeof #'e+)
+     #:fail-unless (typecheck? #'τ ((current-type-eval) #'τ-expected))
+                   (format
+                    "Expression ~a [loc ~a:~a] has type ~a, expected ~a"
+                    (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e)
+                    (type->str #'τ) (type->str #'τ-expected))
+     (syntax/loc stx (check-equal? e+ (add-expected v τ-expected)))]
     [(_ e : τ-expected)
-     #:with τ (typeof (expand/df #'e))
+     #:with τ (typeof (expand/df #'(add-expected e τ-expected)))
      #:fail-unless
      (typecheck? #'τ ((current-type-eval) #'τ-expected))
      (format
@@ -81,11 +88,3 @@
               "Expected type check failure but expression ~a has valid type, OR wrong err msg received."
               (syntax->datum #'e)))
      #'(void)]))
-
-(define-syntax (check-type-and-result stx)
-  (syntax-parse stx #:datum-literals (: ⇒)
-    [(_ e : τ ⇒ v)
-     #`(begin
-         (check-type e : τ)
-         #,(syntax/loc stx
-             (check-equal? e v)))]))
diff --git a/tapl/tests/stlc+occurrence-tests.rkt b/tapl/tests/stlc+occurrence-tests.rkt
index 0b3f7f5..cd03d9c 100644
--- a/tapl/tests/stlc+occurrence-tests.rkt
+++ b/tapl/tests/stlc+occurrence-tests.rkt
@@ -118,13 +118,13 @@
           #t
           #f))
  : (→ (∪ Boolean Int) Boolean))
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Boolean Int)])
      (test (Boolean ? x)
            #t
            #f)) #t)
   : Boolean ⇒ #t)
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Boolean Int)])
      (test (Boolean ? x)
            #t
@@ -138,19 +138,19 @@
           (+ 1 x)
           0))
  : (→ (∪ Int Boolean) (∪ Num Nat)))
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int Boolean)])
     (test (Int ? x)
           (+ 1 x)
           0)) #f)
  : Num ⇒ 0)
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int Boolean)])
     (test (Int ? x)
           (+ 1 x)
           1)) #t)
  : Num ⇒ 1)
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int Boolean)])
     (test (Int ? x)
           (+ 1 x)
@@ -190,7 +190,7 @@
           x))
  : (→ (∪ Boolean Int) (∪ Nat Boolean)))
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int Boolean)])
      (test (Num ? x)
            #f
@@ -199,7 +199,7 @@
  ⇒ #t)
 
 ;; Should filter all the impossible types 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Nat Int Num Boolean)])
      (test (Num ? x)
            #f
@@ -208,7 +208,7 @@
  ⇒ #t)
 
 ;; Can refine non-union types
-(check-type-and-result
+(check-type
  ((λ ([x : Top])
     (test (Str ? x)
           x
@@ -304,7 +304,7 @@
           (x 1 0))))
  : (→ (∪ (→ Int Int Int) (→ Int Int)) Int))
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)])
     (test ((→ Int Int) ? x)
           (x 0)
@@ -313,7 +313,7 @@
           (x 1 0)))) 1)
  : Int ⇒ 1)
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)])
     (test ((→ Int Int) ? x)
           (x 0)
@@ -322,7 +322,7 @@
           (x 1 0)))) (λ ([y : Int]) 5))
  : Int ⇒ 5)
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)])
     (test ((→ Int Int) ? x)
           (x 0)
@@ -362,21 +362,21 @@
           "bool"))
  : (→ (∪ Int Str Boolean) Str))
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Str Boolean)])
      (test ((∪ Int Nat Num) ? x)
            x
            (+ 1 2))) "hi")
  : Num ⇒ 3)
 
-(check-type-and-result
+(check-type
   ((λ ([x : (∪ Str Int Boolean)])
       (test ((∪ Int Str) ? x)
             x
             "error")) 1)
   : (∪ Str Int) ⇒ 1)
 
-(check-type-and-result
+(check-type
   ((λ ([x : (∪ Str Int Boolean)])
       (test ((∪ Int Str) ? x)
             x
@@ -415,7 +415,7 @@
           0))
  : (→ (× (∪ Int Str) Int) Num))
 
-(check-type-and-result
+(check-type
  ((λ ([v : (× (∪ Int Str) Int)])
     (test (Int ? (proj v 0))
           (+ (proj v 0) (proj v 1))
@@ -423,7 +423,7 @@
   (tup ((λ ([x : (∪ Int Str)]) x) -2) -3))
  : Num ⇒ -5)
 
-(check-type-and-result
+(check-type
  ((λ ([v : (× (∪ Int Str) Int)])
     (test (Int ? (proj v 0))
           (+ (proj v 0) (proj v 1))
@@ -440,7 +440,7 @@
           (+ (proj x 0) (+ (proj x 1) (proj x 2)))))
  : (→ (∪ (× Int Int Int) Int) Num))
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int (× Int Int Int))])
      (test (Int ? x)
            (+ 1 x)
@@ -448,7 +448,7 @@
   0)
  : Num ⇒ 1)
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int (× Int Int Int))])
      (test (Int ? x)
            (+ 1 x)
@@ -456,7 +456,7 @@
   (tup 2 2 2))
  : Num ⇒ 6)
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int (× Str Nat) (× Int Int Int))])
      (test (Int ? x)
            (+ 1 x)
@@ -466,7 +466,7 @@
   (tup 2 2 2))
  : Num ⇒ 6)
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int (× Str Nat) (× Int Int Int))])
      (test (Int ? x)
            (+ 1 x)
@@ -478,7 +478,7 @@
 
 ;; -- All together now
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int (× Boolean Boolean) (× Int (∪ Str Int)))])
      (test (Int ? x)
            "just an int"
@@ -490,7 +490,7 @@
   (tup 33 "success"))
  : Str ⇒ "success")
 
-(check-type-and-result
+(check-type
  ((λ ([x : (∪ Int (× Int Int) (× Int (∪ Str Int)))])
      (test (Int ? x)
            "just an int"
diff --git a/tapl/tests/stlc+overloading-tests.rkt b/tapl/tests/stlc+overloading-tests.rkt
index 0729bd6..447dfd5 100644
--- a/tapl/tests/stlc+overloading-tests.rkt
+++ b/tapl/tests/stlc+overloading-tests.rkt
@@ -36,7 +36,7 @@
 (instance (to-string Str)
   (λ ([x : Str]) "string"))
 
-(check-type-and-result
+(check-type
  (to-string 3)
  : Str ⇒ "nat")
 
@@ -47,25 +47,25 @@
 (instance (to-string Num)
   (λ ([x : Num]) "num"))
 
-(check-type-and-result
+(check-type
  (to-string (+ 2 2))
  : Str ⇒ "num")
 
-(check-type-and-result
+(check-type
  (to-string -1)
  : Str ⇒ "num")
 
-(check-type-and-result
+(check-type
  (to-string "hi")
  : Str ⇒ "string")
 
 ;; -- use 'resolve' to get exact matches
 
-(check-type-and-result
+(check-type
  ((resolve to-string Nat) 1)
  : Str ⇒ "nat")
 
-(check-type-and-result
+(check-type
  ((resolve to-string Num) 1)
  : Str ⇒ "num")
 
@@ -112,7 +112,7 @@
 (instance (to-string (List Nat))
           (λ ([x : (List Nat)]) "listnat"))
 
-(check-type-and-result
+(check-type
  (to-string (cons 1 (cons 2 (nil {Nat}))))
  : Str ⇒ "listnat")