From ef623a46b652d553bc25175b479c019dc26f9426 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 16 Sep 2010 11:21:21 -0400
Subject: [PATCH] Made annotations optional for let: and variants.

original commit: 8aab96faa6cac4fd20b7464693152d1f9a3ad106
---
 .../typed-scheme/private/annotate-classes.rkt | 37 +++++++++++++++++++
 collects/typed-scheme/private/prims.rkt       |  4 +-
 2 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/collects/typed-scheme/private/annotate-classes.rkt b/collects/typed-scheme/private/annotate-classes.rkt
index ba822974..78af9997 100644
--- a/collects/typed-scheme/private/annotate-classes.rkt
+++ b/collects/typed-scheme/private/annotate-classes.rkt
@@ -37,11 +37,37 @@
   (pattern (~and whole [:annotated-name rhs:expr])
            #:with binding (syntax/loc #'whole [ann-name rhs])))
 
+(define-syntax-class optionally-annotated-binding
+  #:attributes (name ann-name binding rhs)
+  #:description "optionally type-annotated binding"
+  #:literals (:)
+  (pattern b:annotated-binding
+           #:with name #'b.name
+           #:with ann-name #'b.ann-name
+           #:with binding #'b.binding
+           #:with rhs #'b.rhs)
+  (pattern (~and whole [n:id rhs:expr])
+           #:with name #'n
+           #:with ann-name #'n
+           #:with binding #'whole))
+
 (define-syntax-class annotated-values-binding
   #:attributes ((name 1) (ty 1) (ann-name 1) binding rhs)
   (pattern (~and whole [(~describe "sequence of type-annotated identifiers" ([:annotated-name] ...)) rhs:expr])
            #:with binding (syntax/loc #'whole [(ann-name ...) rhs])))
 
+(define-syntax-class optionally-annotated-values-binding
+  #:attributes ((name 1) (ann-name 1) binding rhs)
+  (pattern b:annotated-values-binding
+           #:with (name ...) #'(b.name ...)
+           #:with (ann-name ...) #'(b.ann-name ...)
+           #:with binding #'b.binding
+           #:with rhs #'b.rhs)
+  (pattern (~and whole [(~describe "sequence of optionally type-annotated identifiers" (n:optionally-annotated-formal ...)) rhs:expr])
+           #:with (name ...) #'(n.name ...)
+           #:with (ann-name ...) #'(n.ann-name ...)
+           #:with binding #'whole))
+
 (define-splicing-syntax-class annotated-star-rest
   #:attributes (name ann-name ty formal-ty)
   #:literals (:)  
@@ -64,6 +90,17 @@
   #:attributes (name ty ann-name)
   (pattern [:annotated-name]))
 
+(define-syntax-class optionally-annotated-formal
+  #:description "optionally annotated variable of the form [x : T] or just x"
+  #:opaque
+  #:attributes (name ann-name)
+  (pattern f:annotated-formal
+           #:with name #'f.name
+           #:with ann-name #'f.ann-name)
+  (pattern f:id
+           #:with name #'f
+           #:with ann-name #'f))
+
 (define-syntax-class annotated-formals
   #:attributes (ann-formals (arg-ty 1))
   #:literals (:)
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index 82773469..92e9247f 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -238,7 +238,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (let ([mk (lambda (form)
               (lambda (stx)
                 (syntax-parse stx
-                  [(_ (bs:annotated-binding ...) . body)
+                  [(_ (bs:optionally-annotated-binding ...) . body)
                    (quasisyntax/loc stx (#,form (bs.binding ...) . body))])))])
     (values (mk #'let) (mk #'let*) (mk #'letrec))))
 
@@ -246,7 +246,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (let ([mk (lambda (form)
               (lambda (stx)
                 (syntax-parse stx
-                  [(_ (bs:annotated-values-binding ...) . body)
+                  [(_ (bs:optionally-annotated-values-binding ...) . body)
                    (quasisyntax/loc stx (#,form (bs.binding ...) . body))])))])
     (values (mk #'let-values) (mk #'let*-values) (mk #'letrec-values))))