From a5bccaffe1994d27582582b6ff6c1cd66ad8cbfb Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 13 Jun 2011 16:58:03 -0400
Subject: [PATCH] Allow omitting type annotation in most of the for: forms.

---
 .../typed-scheme/succeed/for-no-body-anns.rkt |  9 +++++
 .../base-env/annotate-classes.rkt             |  8 ++++
 collects/typed-scheme/base-env/prims.rkt      | 37 ++++++++++---------
 3 files changed, 36 insertions(+), 18 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/for-no-body-anns.rkt

diff --git a/collects/tests/typed-scheme/succeed/for-no-body-anns.rkt b/collects/tests/typed-scheme/succeed/for-no-body-anns.rkt
new file mode 100644
index 0000000000..e1f5ed82b7
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/for-no-body-anns.rkt
@@ -0,0 +1,9 @@
+#lang typed/racket
+
+(ann (for/list ([#{i : Number} (in-list '(1 2 3))]) i) (Listof Number))
+(ann (for/list: ([i : Number (in-list '(1 2 3))]) i) (Listof Number))
+
+(+ (for/fold: ([acc : Number 0])
+       ([i (in-list '(1 2 3))])
+     (+ i acc))
+   1)
diff --git a/collects/typed-scheme/base-env/annotate-classes.rkt b/collects/typed-scheme/base-env/annotate-classes.rkt
index 1496edf0fa..7ef0a8130e 100644
--- a/collects/typed-scheme/base-env/annotate-classes.rkt
+++ b/collects/typed-scheme/base-env/annotate-classes.rkt
@@ -133,3 +133,11 @@
                        (~or rest:annotated-star-rest rest:annotated-dots-rest)))
            #:with ann-formals #'(n.ann-name ... . rest.ann-name)
            #:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))
+
+(define-splicing-syntax-class standalone-annotation
+  #:literals (:)
+  (pattern (~seq : t)
+           #:with ty #'t))
+(define-splicing-syntax-class optional-standalone-annotation
+  (pattern (~optional a:standalone-annotation)
+           #:with ty (if (attribute a) #'a.ty #f)))
diff --git a/collects/typed-scheme/base-env/prims.rkt b/collects/typed-scheme/base-env/prims.rkt
index e9a320cdd6..3d6184eb63 100644
--- a/collects/typed-scheme/base-env/prims.rkt
+++ b/collects/typed-scheme/base-env/prims.rkt
@@ -491,6 +491,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
               (when guard
                 #,(loop #'(rest ...))))])))]))
 
+(define-for-syntax (maybe-annotate-body body ty)
+  (if (syntax-e ty)
+      (syntax-property body 'type-ascription ty)
+      body))
+
 ;; Handling #:when clauses manually, like we do with for: above breaks
 ;; the semantics of for/list and co.
 ;; We must leave it to the untyped versions of the macros.
@@ -500,19 +505,17 @@ This file defines two sorts of primitives. All of them are provided into any mod
 (define-for-syntax (define-for-variant name)
   (lambda (stx)
     (syntax-parse stx #:literals (:)
-      [(_ : ty
+      [(_ a:optional-standalone-annotation
           (clause:for-clause ...)
           c:expr ...)
-       (syntax-property
+       (maybe-annotate-body
         (quasisyntax/loc stx
-         (#,name
-          (clause.expand ... ...)
-          #,@(syntax-property
-              #'(c ...)
-              'type-ascription
-              #'ty)))
-        'type-ascription
-        #'ty)])))
+          (#,name
+           (clause.expand ... ...)
+           #,@(maybe-annotate-body
+               #'(c ...)
+               #'a.ty)))
+        #'a.ty)])))
 (define-syntax (define-for-variants stx)
   (syntax-parse stx
     [(_ (name untyped-name) ...)
@@ -537,17 +540,16 @@ This file defines two sorts of primitives. All of them are provided into any mod
 ;; clauses with these 2.
 (define-syntax (for/lists: stx)
   (syntax-parse stx #:literals (:)
-    [(_ : ty
+    [(_ a:optional-standalone-annotation
         ((var:optionally-annotated-name) ...)
         (clause:for-clause ...)
         c:expr ...)
-     (syntax-property
+     (maybe-annotate-body
       (quasisyntax/loc stx
         (for/lists (var.ann-name ...)
           (clause.expand ... ...)
           c ...))
-      'type-ascription
-      #'ty)]))
+      #'a.ty)]))
 (define-syntax (for/fold: stx)
   (syntax-parse stx #:literals (:)
     [(_ : ty
@@ -591,15 +593,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
 (define-for-syntax (define-for*-variant name)
   (lambda (stx)
     (syntax-parse stx #:literals (:)
-      [(_ : ty
+      [(_ a:optional-standalone-annotation
           (clause:for-clause ...)
           c:expr ...)
-       (syntax-property
+       (maybe-annotate-body
         (quasisyntax/loc stx
           (#,name (clause.expand ... ...)
                   c ...))
-        'type-ascription
-        #'ty)])))
+        #'a.ty)])))
 (define-syntax (define-for*-variants stx)
   (syntax-parse stx
     [(_ (name no-*-name) ...)