From 8e8df77fc4675a5f8a9ae8090ac87b35c36dfaf7 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Wed, 12 Feb 2014 23:56:53 -0500
Subject: [PATCH] Apply All's rules for parentheses omission for :

---
 .../typed-racket/base-env/colon.rkt           | 10 +++-------
 .../typed-racket/private/parse-classes.rkt    | 20 +++++++++++++++++--
 .../typed-racket/private/parse-type.rkt       | 17 +++-------------
 3 files changed, 24 insertions(+), 23 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/colon.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/colon.rkt
index 6e9bd4fbcc..bce93dc5f6 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/colon.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/colon.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require (for-syntax racket/base syntax/parse unstable/sequence unstable/syntax
+                     "../private/parse-classes.rkt"
                      "../utils/disappeared-use.rkt"
                      (only-in "../utils/tc-utils.rkt" tc-error/stx))
          "../typecheck/internal-forms.rkt"
@@ -28,14 +29,9 @@
     [_
      #:when (eq? 'expression ctx)
      (err stx "must be used in a definition context")]
-    [(: id (~and kw :) x ...)
-     #:fail-unless (for/first ([i (in-syntax #'(x ...))]
-                               #:when (identifier? i)
-                               #:when (free-identifier=? i #'t:->))
-                     i)
-     #f
+    [(: id (~and kw :) . more:omit-parens)
      (add-disappeared-use #'kw)
-     (wrap stx #`(:-helper #,top-level? id (x ...)))]
+     (wrap stx #`(:-helper #,top-level? id more.type))]
     [(: id : . more)
      (wrap stx #`(:-helper #,top-level? id . more))]
     [(: e ...) (wrap stx #`(:-helper #,top-level? e ...))]))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-classes.rkt
index 6e6b6db15e..06ac9c5631 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-classes.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-classes.rkt
@@ -1,7 +1,11 @@
 #lang racket/base
 
-(require syntax/parse)
-(provide star ddd ddd/bound)
+(require syntax/parse
+         "../utils/literal-syntax-class.rkt"
+         (for-label "../base-env/base-types-extra.rkt"))
+(provide star ddd ddd/bound omit-parens)
+
+(define-literal-syntax-class #:for-label ->)
 
 (define-syntax-class star
   #:description "*"
@@ -24,3 +28,15 @@
            #:fail-unless (equal? "..." (substring (attribute s) 0 3)) "missing ..."
            #:attr bound (datum->syntax #'i (string->symbol (substring (attribute s) 3)) #'i #'i))
   (pattern (~seq _:ddd bound:id)))
+
+;; The body of a Forall type or type annotation after the second :
+;; Allows one level of parentheses to be omitted for infix -> types
+(define-syntax-class omit-parens
+  #:attributes (type)
+  ;; FIXME: the error message when a failure is triggered by this case
+  ;;        is not very good, but I have been unsuccessful with ~fail
+  ;;        or with #:fail-when. -- AT
+  (pattern (~and (:->^ x y ~! z ...) (~fail))
+           #:with type 'dummy)
+  (pattern (~and type ((~or (~once :->^) (~not :->^)) ...)))
+  (pattern (type)))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
index 5f60b60919..4475f25b61 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
@@ -61,20 +61,9 @@
   (let* ([stx* (datum->syntax loc datum loc loc)])
     (p stx*)))
 
-;; The body of a Forall type
-(define-syntax-class all-body
-  #:attributes (type)
-  ;; FIXME: the error message when a failure is triggered by this case
-  ;;        is not very good, but I have been unsuccessful with ~fail
-  ;;        or with #:fail-when. -- AT
-  (pattern (~and (:->^ x y ~! z ...) (~fail))
-           #:with type 'dummy)
-  (pattern (~and type ((~or (~once :->^) (~not :->^)) ...)))
-  (pattern (type)))
-
 (define (parse-literal-alls stx)
   (syntax-parse stx
-    [(:All^ (~or (vars:id ... v:id dd:ddd) (vars:id ...)) . t:all-body)
+    [(:All^ (~or (vars:id ... v:id dd:ddd) (vars:id ...)) . t:omit-parens)
      (define vars-list (syntax->list #'(vars ...)))
      (cons (if (attribute v)
                (list vars-list #'v)
@@ -88,7 +77,7 @@
 (define (parse-all-type stx)
   ;(printf "parse-all-type: ~a \n" (syntax->datum stx))
   (syntax-parse stx
-    [(:All^ (vars:id ... v:id dd:ddd) . t:all-body)
+    [(:All^ (vars:id ... v:id dd:ddd) . t:omit-parens)
      (when (check-duplicate-identifier (syntax->list #'(vars ... v)))
        (tc-error "All: duplicate type variable or index"))
      (let* ([vars (stx-map syntax-e #'(vars ...))]
@@ -96,7 +85,7 @@
        (extend-indexes v
          (extend-tvars vars
            (make-PolyDots (append vars (list v)) (parse-type #'t.type)))))]
-    [(:All^ (vars:id ...) . t:all-body)
+    [(:All^ (vars:id ...) . t:omit-parens)
      (when (check-duplicate-identifier (syntax->list #'(vars ...)))
        (tc-error "All: duplicate type variable"))
      (let* ([vars (stx-map syntax-e #'(vars ...))])