Move from type-ascription-property to add-ann.

endobson · Oct 20, 2013 · c7b37a0 · c7b37a0
1 parent 1690b48
commit c7b37a0
Show file tree

Hide file tree

Showing 2 changed files with 36 additions and 32 deletions.
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt
@@ -138,10 +138,3 @@
            #: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/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
@@ -384,7 +384,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
 (define-syntax (ann stx)
   (syntax-parse stx #:literals (:)
     [(_ (~or (~seq arg : ty) (~seq arg ty)))
-     (type-ascription-property #'arg #'ty)]))
+     (add-ann #'arg #'ty)]))
+
+(define-for-syntax (add-ann expr-stx ty-stx)
+  (type-ascription-property expr-stx ty-stx))
+
 
 (define-syntax (inst stx)
   (syntax-parse stx #:literals (:)
@@ -809,8 +813,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ (~optional (~seq : Void))
         ;; c is not always an expression, could be a break-clause
         clauses c ...) ; no need to annotate the type, it's always Void
-     (let ((body #`(; break-clause ...
-                    #,@(type-ascription-property #'(c ...) #'Void))))
+     (let ((body #'(; break-clause ...
+                    c ...)))
        (let loop ((clauses #'clauses))
          (define-splicing-syntax-class for-clause
            ;; single-valued seq-expr
@@ -833,14 +837,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
                     #:with replace-with #'unless))
          (syntax-parse clauses
            [(head:for-clause next:for-clause ... kw:for-kw rest ...)
-            (type-ascription-property
+            (add-ann
              (quasisyntax/loc stx
                (for
                 (head.expand ... next.expand ... ...)
                 #,(loop #'(kw rest ...))))
              #'Void)]
            [(head:for-clause ...) ; we reached the end
-            (type-ascription-property
+            (add-ann
              (quasisyntax/loc stx
                (for
                 (head.expand ... ...)
@@ -855,10 +859,20 @@ This file defines two sorts of primitives. All of them are provided into any mod
               (kw.replace-with guard
                 #,(loop #'(rest ...))))])))]))
 
-(define-for-syntax (maybe-annotate-body body ty)
-  (if (syntax-e ty)
-      (type-ascription-property body ty)
-      body))
+(begin-for-syntax
+  (define-splicing-syntax-class standalone-annotation
+    #:attributes (ty)
+    #:literals (:)
+    (pattern (~seq : ty)))
+
+  (define-splicing-syntax-class optional-standalone-annotation
+    #:attributes (ty annotate)
+    (pattern (~optional :standalone-annotation)
+             #:attr annotate
+                    (λ (stx)
+                       (if (attribute ty)
+                           (add-ann stx #'ty)
+                           stx)))))
 
 ;; Handling #:when clauses manually, like we do with for: above breaks
 ;; the semantics of for/list and co.
@@ -872,14 +886,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
       [(_ a:optional-standalone-annotation
           clause:for-clauses
           c ...) ; c is not always an expression, can be a break-clause
-       (maybe-annotate-body
+       ((attribute a.annotate)
         (quasisyntax/loc stx
           (#,name
            (clause.expand ... ...)
-           #,@(maybe-annotate-body
-               #'(c ...)
-               #'a.ty)))
-        #'a.ty)])))
+           c ...)))])))
+
 (define-syntax (define-for-variants stx)
   (syntax-parse stx
     [(_ (name untyped-name) ...)
@@ -904,7 +916,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
         ((var:optionally-annotated-name) ...)
         clause:for-clauses
         c ...) ; c is not always an expression, can be a break-clause
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/lists (var.ann-name ...)
           (clause.expand ... ...)
@@ -913,7 +925,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ ((var:annotated-name) ...)
         clause:for-clauses
         c ...)
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/lists (var.ann-name ...)
           (clause.expand ... ...)
@@ -925,7 +937,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
         ((var:optionally-annotated-name init:expr) ...)
         clause:for-clauses
         c ...) ; c is not always an expression, can be a break-clause
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/fold ((var.ann-name init) ...)
           (clause.expand ... ...)
@@ -934,7 +946,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ accum:accumulator-bindings
         clause:for-clauses
         c ...)
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/fold ((accum.ann-name accum.init) ...)
           (clause.expand ... ...)
@@ -958,11 +970,10 @@ This file defines two sorts of primitives. All of them are provided into any mod
       [(_ a:optional-standalone-annotation
           clause:for-clauses
           c ...) ; c is not always an expression, can be a break-clause
-       (maybe-annotate-body
+       ((attribute a.annotate)
         (quasisyntax/loc stx
           (#,name (clause.expand ... ...)
-                  c ...))
-        #'a.ty)])))
+                  c ...)))])))
 (define-syntax (define-for*-variants stx)
   (syntax-parse stx
     [(_ (name no-colon-name) ...)
@@ -983,7 +994,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
         ((var:optionally-annotated-name) ...)
         clause:for-clauses
         c ...) ; c is not always an expression, can be a break-clause
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/lists (var.ann-name ...)
           (clause.expand* ... ...)
@@ -992,7 +1003,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ ((var:annotated-name) ...)
         clause:for-clauses
         c ...)
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/lists (var.ann-name ...)
           (clause.expand* ... ...)
@@ -1004,7 +1015,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
         ((var:optionally-annotated-name init:expr) ...)
         clause:for-clauses
         c ...) ; c is not always an expression, can be a break-clause
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/fold ((var.ann-name init) ...)
           (clause.expand* ... ...)
@@ -1013,7 +1024,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ ((var:annotated-name init:expr) ...)
         clause:for-clauses
         c ...)
-     (type-ascription-property
+     (add-ann
       (quasisyntax/loc stx
         (for/fold ((var.ann-name init) ...)
           (clause.expand* ... ...)