From 48c3edca8421b7eecfbc509aa6e055b3ab35a078 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 27 May 2010 16:46:10 -0400
Subject: [PATCH] Added the for/lists: and for/fold: macros.

original commit: 1ec6bd448b4dc325603ed41ec81cf04cc33866b8
---
 collects/typed-scheme/private/for-clauses.rkt | 28 ++++++++++++-----
 collects/typed-scheme/private/prims.rkt       | 30 +++++++++++++++++++
 2 files changed, 50 insertions(+), 8 deletions(-)

diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt
index 57d65685..eff3358f 100644
--- a/collects/typed-scheme/private/for-clauses.rkt
+++ b/collects/typed-scheme/private/for-clauses.rkt
@@ -4,19 +4,20 @@
          "annotate-classes.rkt"
          (for-template racket/base))
 
-(provide convert-for-clauses)
+(provide convert-for-clauses
+         for-clause)
 
 ;; we need handle #:when clauses manually because we need to annotate
 ;; the type of each nested for
 (define (convert-for-clauses name clauses body ty)
   (let loop ((clauses clauses))
-    (define-splicing-syntax-class for-clause
-    ;; single-valued seq-expr
-    (pattern (var:annotated-name seq-expr:expr)
-             #:with expand #'(var.ann-name seq-expr))
-    ;; multi-valued seq-expr
-    (pattern ((v:annotated-name ...) seq-expr:expr)
-             #:with expand #'((v.ann-name ...) seq-expr)))
+    (define-syntax-class for-clause
+      ;; single-valued seq-expr
+      (pattern (var:annotated-name seq-expr:expr)
+               #:with expand #'(var.ann-name seq-expr))
+      ;; multi-valued seq-expr
+      (pattern ((v:annotated-name ...) seq-expr:expr)
+               #:with expand #'((v.ann-name ...) seq-expr)))
     (syntax-parse clauses
       [(head:for-clause next:for-clause ... #:when rest ...)
        (syntax-property
@@ -42,3 +43,14 @@
        (quasisyntax/loc clauses
          (when guard
            #,(loop #'(rest ...))))])))
+
+(define-splicing-syntax-class for-clause
+    ;; single-valued seq-expr
+    (pattern (var:annotated-name seq-expr:expr)
+             #:with (expand ...) (list #'(var.ann-name seq-expr)))
+    ;; multi-valued seq-expr
+    (pattern ((v:annotated-name ...) seq-expr:expr)
+             #:with (expand ...) (list #'((v.ann-name ...) seq-expr)))
+    ;; when clause
+    (pattern (~seq #:when guard:expr)
+             #:with (expand ...) (list #'#:when #'guard)))
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index 048cd7f0..f9fc56f9 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -403,6 +403,36 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (for/first: for/first)
   (for/last: for/last))
 
+;; these 2 don't expand into nested for/X:s, #:when clauses are handled during
+;; the expansion of the untyped versions of these macros
+;; for this reason, uses of these macros with #:when clauses may not typecheck
+(define-syntax (for/lists: stx)
+  (syntax-parse stx #:literals (:)
+    [(_ : ty
+        ((var:annotated-name) ...)
+        (clause:for-clause ...)
+        c:expr ...)
+     (syntax-property
+      (syntax/loc stx
+        (for/lists (var.ann-name ...)
+          (clause.expand ... ...)
+          c ...))
+      'type-ascription
+      #'ty)]))
+(define-syntax (for/fold: stx)
+  (syntax-parse stx #:literals (:)
+    [(_ : ty
+        ((var:annotated-name init:expr) ...)
+        (clause:for-clause ...)
+        c:expr ...)
+     (syntax-property
+      (syntax/loc stx
+        (for/fold ((var.ann-name init) ...)
+          (clause.expand ... ...)
+          c ...))
+      'type-ascription
+      #'ty)]))
+
 (define-syntax (provide: stx)
   (syntax-parse stx
     [(_ [i:id t] ...)