From 231026ac8ec9bda9742e26d27fe33e8b8d726d76 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 21 May 2014 23:41:41 -0700
Subject: [PATCH] Fix typechecking of andmap/ormap on dotted lists.

original commit: c60b3d8b03cc095796f634c81ba04567bf192ec3
---
 .../typecheck/tc-app/tc-app-list.rkt            | 17 ++++++++++++-----
 .../typed-racket/unit-tests/typecheck-tests.rkt |  9 +++++++++
 2 files changed, 21 insertions(+), 5 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
index 3651d0d2..88ae5511 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
@@ -22,6 +22,12 @@
   #:for-label
   (reverse k:reverse list list* cons map andmap ormap))
 
+(define-syntax-class boolmap
+  #:literal-sets (list-literals)
+  #:attributes (default)
+  (pattern andmap #:attr default #t)
+  (pattern ormap #:attr default #f))
+
 (define-tc/app-syntax-class (tc/app-list expected)
   #:literal-sets (list-literals)
   (pattern (~and form (map f arg0 arg ...))
@@ -58,17 +64,18 @@
       ;; TODO fix double typechecking
       [(res0 res) (tc/app-regular #'form expected)]))
   ;; ormap/andmap of ... argument
-  (pattern (~and form ((~or andmap ormap) f arg))
-    (match-let* ([arg-ty (single-value #'arg)]
+  (pattern (~and form (m:boolmap f arg))
+    (match-let* ([arg-ty (tc-expr/t #'arg)]
                  [ft (tc-expr #'f)])
       (match (match arg-ty
                ;; if the argument is a ListDots
-               [(tc-result1: (ListDots: t bound))
+               [(ListDots: t bound)
                 ;; just check that the function applies successfully to the element type
-                (tc/funapp #'f #'(arg) ft (list (ret (substitute Univ bound t))) expected)]
+                (extend-tvars (list bound)
+                  (tc/funapp #'f #'(arg) ft (list (ret t)) expected))]
                ;; otherwise ...
                [_ #f])
-        [(tc-result1: t) (ret (Un (-val #f) t))]
+        [(tc-result1: t) (ret (Un (-val (attribute m.default)) t))]
         ;; if it's not a ListDots, defer to the regular function typechecking
         ;; TODO fix double typechecking
         [_ (tc/app-regular #'form expected)])))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
index 34634005..6f08593b 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
@@ -2978,6 +2978,15 @@
          #:ret (ret (-polydots (a ...) (->... (list) (a a) (-values-dots (list (t:-> -Symbol -Symbol)) a 'a))))
          #:expected (ret (-polydots (a ...) (->... (list) (a a) (-values-dots (list (t:-> -Symbol -Symbol)) a 'a))))]
 
+       [tc-err
+         (lambda xs (andmap (lambda: ([x : (Vectorof Any)]) x) xs))
+         #:ret (ret (-polydots (a ...) (->... (list) ((-vec a) a) (t:Un (-val #f) (-vec Univ)))))
+         #:expected (ret (-polydots (a ...) (->... (list) ((-vec a) a) (t:Un (-val #f) (-vec Univ)))))]
+       [tc-err
+         (lambda xs (andmap (lambda: ([x : #f]) x) xs))
+         #:ret (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))
+         #:expected (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))]
+
         )
   (test-suite
    "tc-literal tests"