From 69f5da8531da6b1c06c5cbee763b6a4b76e7875b Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Sat, 26 Apr 2014 09:48:11 -0700
Subject: [PATCH] Add a test suite for infer.

original commit: d38737836e483b78cc6697a474f9fcb26573d092
---
 .../typed-racket/unit-tests/infer-tests.rkt   | 66 +++++++++++++++++--
 1 file changed, 62 insertions(+), 4 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
index 83c04df7..ffefbced 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
@@ -1,7 +1,13 @@
 #lang racket/base
-(require "test-utils.rkt"
-         rackunit
-         (types numeric-tower utils abbrev))
+(require
+  "test-utils.rkt"
+  rackunit
+  racket/list
+  (for-syntax racket/base syntax/parse)
+  (rep type-rep)
+  (r:infer infer)
+
+  (types numeric-tower utils abbrev))
 
 (provide tests)
 (gen-test-main)
@@ -13,7 +19,27 @@
                 (fv ty*)
                 (list (quote elems) ...))))
 
-(define tests
+(define-syntax (infer-t stx)
+  (define-splicing-syntax-class vars
+    (pattern (~seq) #:with vars #'empty)
+    (pattern (~seq #:vars vars:expr) ))
+  (define-splicing-syntax-class indices
+    (pattern (~seq) #:with indices #'empty)
+    (pattern (~seq #:indices indices:expr) ))
+  (define-splicing-syntax-class pass
+    (pattern (~seq) #:with pass #'#t)
+    (pattern #:pass #:with pass #'#t)
+    (pattern #:fail #:with pass #'#f))
+  (syntax-parse stx
+    ([_ S:expr T:expr :vars :indices :pass]
+     #'(test-case "foobar"
+         (define result (infer vars indices (list S) (list T) #f))
+         (unless (equal? result pass)
+           (fail-check "Could not infer a substitution"))))))
+
+
+
+(define fv-tests
   (test-suite "Tests for fv"
               (fv-t -Number)
               [fv-t (-v a) a]
@@ -26,3 +52,35 @@
 
               [fv-t (->* null (-v a) -Number) a] ;; check that a is CONTRAVARIANT
               ))
+
+(define infer-tests
+  (test-suite "Tests for infer"
+    (infer-t Univ Univ)
+    (infer-t (-v a) Univ)
+    (infer-t Univ (-v a) #:fail)
+    (infer-t Univ (-v a) #:vars '(a))
+    (infer-t (-v a) Univ #:vars '(a))
+    (infer-t (-v a) -Bottom #:vars '(a))
+    (infer-t (-v a) (-v b) #:fail)
+    (infer-t (-v a) (-v b) #:vars '(a))
+    (infer-t (-v a) (-v b) #:vars '(b))
+
+    (infer-t (make-ListDots -Symbol 'b) (-lst -Symbol) #:indices '(b))
+    (infer-t (make-ListDots (-v b) 'b) (-lst Univ) #:indices '(b))
+    (infer-t (make-ListDots (-v a) 'b) (make-ListDots -Symbol 'b)  #:vars '(a))
+    (infer-t (make-ListDots (-v b) 'b) (make-ListDots (-v b) 'b) #:indices '(b))
+    (infer-t (make-ListDots (-v b) 'b) (make-ListDots Univ 'b) #:indices '(b))
+
+    ;; Currently Broken
+    ;(infer-t (make-ListDots (-v b) 'b) (-lst -Symbol) #:indices '(b))
+    ;(infer-t (-lst -Symbol) (make-ListDots -Symbol 'b) #:indices '(b))
+    ;(infer-t (make-ListDots (-v b) 'b) (make-ListDots -Symbol 'b) #:indices '(b))
+    ;(infer-t (make-ListDots -Symbol 'b) (make-ListDots (-v b) 'b) #:indices '(b))
+    ;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b))
+  ))
+
+
+(define tests
+  (test-suite "All inference tests"
+    fv-tests
+    infer-tests))