From 71bb63c128f8331dc19455bb75a8918dc5055e03 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 1 Jul 2010 16:49:02 -0400
Subject: [PATCH] Better typing for `make-sequence'.

---
 collects/tests/typed-scheme/succeed/for-ann.rkt |  3 +++
 collects/typed-scheme/typecheck/tc-app.rkt      | 12 +++++++++++-
 2 files changed, 14 insertions(+), 1 deletion(-)
 create mode 100644 collects/tests/typed-scheme/succeed/for-ann.rkt

diff --git a/collects/tests/typed-scheme/succeed/for-ann.rkt b/collects/tests/typed-scheme/succeed/for-ann.rkt
new file mode 100644
index 0000000000..a400999a9d
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/for-ann.rkt
@@ -0,0 +1,3 @@
+#lang typed/racket
+
+(ann (for ([#{i : Integer} '(1 2 3)]) (display i)) Void)
\ No newline at end of file
diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt
index 2bcecb0faa..ee589873b8 100644
--- a/collects/typed-scheme/typecheck/tc-app.rkt
+++ b/collects/typed-scheme/typecheck/tc-app.rkt
@@ -461,6 +461,16 @@
                [(tc-result1: t) 
                 (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
                 (loop (cddr args))]))))]
+    ;; use the additional but normally ignored first argument to make-sequence to provide a better instantiation
+    [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) (~and quo ((~literal quote) (i:id))) arg:expr)
+     #:when (type-annotation #'i)     
+     (match (single-value #'op)
+         [(tc-result1: (and t Poly?))
+          (tc-expr/check #'quo (ret Univ))
+          (tc/funapp #'op #'(quo arg) 
+                     (ret (instantiate-poly t (list (type-annotation #'i))))
+                     (list (ret Univ) (single-value #'arg))
+                     expected)])]
     ;; unsafe struct operations
     [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr)
      (let ([e-t (single-value #'e)])
@@ -990,7 +1000,7 @@
              (open-Result r o-a t-a)))
          (ret t-r f-r o-r)))]
     [((arr: _ _ _ drest '()) _)
-     (int-err "funapp with drest args ~a NYI" drest)]
+     (int-err "funapp with drest args ~a ~a NYI" drest argtys)]
     [((arr: _ _ _ _ kws) _)
      (int-err "funapp with keyword args ~a NYI" kws)]))