support prop:evt

typed-racket-lib/typed-racket/base-env/base-env.rkt

@@ -1553,7 +1553,7 @@
 [system-idle-evt (-> (-evt -Void))]
 [alarm-evt (-> -Real (-mu x (-evt x)))]
 [handle-evt? (asym-pred Univ B (-PS (-is-type 0 (-evt Univ)) -tt))]
-[prop:evt (-struct-property (Un (-evt Univ) (-> -Self ManyUniv) -Nat) #'evt?)]
+[prop:evt (-struct-property (Un (-evt Univ) (-> -Self Univ) -Nat) #'evt?)]
 [current-evt-pseudo-random-generator
  (-Param -Pseudo-Random-Generator -Pseudo-Random-Generator)]
 

typed-racket-lib/typed-racket/base-env/prims-struct.rkt

@@ -102,13 +102,15 @@
                                ([val (attribute prop-val)]
                                 [name (attribute prop)])
                        (cond
-                         [(free-identifier=? name #'prop:procedure)
+                         [(or (free-identifier=? name #'prop:procedure)
+                              (free-identifier=? name #'prop:evt))
                           (define tname (or (attribute type) st-name))
                           (define sty-stx (if (null? type-vars)
                                               tname
                                               (quasisyntax/loc tname
                                                 (#,tname #,@type-vars))))
-                          (maybe-extract-prop-proc-ty-ann sty-stx val)]
+                          (define-values (val^ ty^) (maybe-extract-prop-proc-ty-ann sty-stx val))
+                          (values val^ (assoc-struct-property-name-property ty^ name))]
                          [else (values val #f)])))]
              #:attr proc-ty (if (null? proc-tys) #f
                                 proc-tys)
@@ -200,7 +202,7 @@
 
 
 ;; This function tries to extract the type annotation on a lambda
-;; expression for prop:precedure.
+;; expression for prop:procedure.
 ;;
 ;; sty-stx: the syntax that represents a structure type. For a monomorhpic
 ;; structure type, sty-stx is the identifier for its name. For a polymorphic

typed-racket-lib/typed-racket/private/syntax-properties.rkt

@@ -61,6 +61,7 @@
   (type-inst type-inst)
   (row-inst row-inst)
   (st-proc-ty st-proc-ty)
+  (assoc-struct-property-name assoc-struct-property-name)
   (type-label type-label)
   (optional-non-immediate-arg optional-non-immediate-arg)
   (optional-immediate-arg optional-immediate-arg)

typed-racket-lib/typed-racket/rep/type-rep.rkt

@@ -806,8 +806,11 @@
 
 
 (define/cond-contract (Struct-proc* sty)
-  (-> Struct? (or/c #f Fun?))
-  (define b (Struct-proc sty))
+  (-> (or/c Poly? Struct?) (or/c #f Type?))
+  (define sty^ (match sty
+                 [(? Struct?) sty]
+                 [(Poly: _ (? Struct? sty)) sty]))
+  (define b (Struct-proc sty^))
   (and b (unbox b)))
 
 (define (make-Struct* name parent flds proc poly? pred-id properties)

typed-racket-lib/typed-racket/typecheck/tc-structs.rkt

@@ -91,13 +91,6 @@
   (syntax-parse stx
     [t:typed-struct #'t.type-name]))
 
-;; a simple wrapper to get proc from a polymorphic or monomorhpic structure
-(define/cond-contract (get-struct-proc sty)
-  (c:-> (c:or/c Struct? Poly?) (c:or/c #f Fun?))
-  (Struct-proc (match sty
-                 [(? Struct?) sty]
-                 [(Poly: names (? Struct? sty)) sty])))
-
 
 (define/cond-contract (tc/struct-prop-values st-tname pnames pvals)
   (c:-> identifier? (c:listof identifier?) (c:listof syntax?) void?)
@@ -385,8 +378,9 @@
   (define st-type-alias (mk-type-alias type-name tvars))
   (define st-type-alias-maybe-with-proc
     (let ([maybe-proc-ty (and (or (Poly? sty) (Struct? sty))
-                              (get-struct-proc sty))])
-      (if maybe-proc-ty (intersect st-type-alias maybe-proc-ty)
+                              (Struct-proc sty))])
+      (if maybe-proc-ty
+          (intersect st-type-alias maybe-proc-ty)
           st-type-alias)) )
 
   ;; simple abstraction for handling field getters or setters
@@ -463,49 +457,58 @@
       (struct-names-type-name (parsed-struct-names parsed-struct))))
   (refine-variance! names stys tvarss))
 
-;; extract the type annotation of prop:procedure value
-(define/cond-contract (extract-proc-ty proc-ty-stx desc fld-names st-name)
-  (c:-> (c:listof syntax?) struct-desc? (c:listof identifier?) identifier? Type?)
-
-  (unless (equal? (length proc-ty-stx) 1)
-    (tc-error "prop:procedure can only have one value assigned to it"))
 
-  (let ([proc-ty-stx (car proc-ty-stx)])
-    (syntax-parse proc-ty-stx
-      #:literals (struct-field-index)
-      ;; a field index is provided
-      [n_:exact-nonnegative-integer
-       (define n (syntax-e #'n_))
-       (define max-idx (sub1 (length (struct-desc-self-fields desc))))
-       (unless (<= n max-idx)
-         (tc-error/fields
-          "index too large"
-          "index"
-          n
-          "maximum allowed index"
-          max-idx
-          #:stx proc-ty-stx))
-       (define ty (list-ref (struct-desc-self-fields desc) n))
+(define ((make-extract check-field-type check-doms-rng error-msg)
+         ty-stx st-name fld-names desc)
+  (syntax-parse ty-stx
+    #:literals (struct-field-index)
+    ;; a field index is provided
+    [n_:exact-nonnegative-integer
+     (define n (syntax-e #'n_))
+     (define max-idx (sub1 (length (struct-desc-self-fields desc))))
+     (unless (<= n max-idx)
+       (tc-error/fields
+        "index too large"
+        "index"
+        n
+        "maximum allowed index"
+        max-idx
+        #:stx ty-stx))
+     (define ty (list-ref (struct-desc-self-fields desc) n))
+     (check-field-type ty-stx (list-ref fld-names n) ty)]
+
+    ;; a field name is provided (via struct-field-index)
+    [(struct-field-index fld-nm:id)
+     (define idx (index-of fld-names #'fld-nm
+                           free-identifier=?))
+     ;; fld-nm must be valid, because invalid field names have been reported by
+     ;; struct-field-index at this point
+     (list-ref (struct-desc-self-fields desc) idx)]
+
+    [ty-stx:st-proc-ty^
+     #:do [(define ty (parse-type #'ty-stx))]
+     (check-doms-rng #'ty-stx ty st-name)
+     ]
+    [_ (tc-error/stx ty-stx error-msg)]))
+
+(define-syntax-rule (define-property-handling-table (name check-field-type rng-chck error-msg) ...)
+  (make-immutable-free-id-table (list (cons name (make-extract check-field-type rng-chck error-msg))
+                                      ...)))
+
+(define property-handling-table
+  (define-property-handling-table
+    (#'prop:procedure
+     (lambda (ty-stx fld-name ty)
        (unless (Fun? ty)
          (tc-error/fields
-          (format "field ~a is not a function" (syntax-e (list-ref fld-names n)))
+          (format "field ~a is not a function" (syntax-e fld-name))
           "expected"
           "Procedure"
           "given"
           ty
-          #:stx proc-ty-stx))
-       ty]
-
-      ;; a field name is provided (via struct-field-index)
-      [(struct-field-index fld-nm:id)
-       (define idx (index-of fld-names #'fld-nm
-                             free-identifier=?))
-       ;; fld-nm must be valid, because invalid field names have been reported by
-       ;; struct-field-index at this point
-       (list-ref (struct-desc-self-fields desc) idx)]
-
-      [ty-stx:st-proc-ty^
-       #:do [(define ty (parse-type #'ty-stx))]
+          #:stx ty-stx))
+       ty)
+     (lambda (ty-stx ty st-name)
        (match ty
          [(Fun: (list arrs ...))
           (make-Fun
@@ -527,8 +530,7 @@
                         (tc-error/fields "type mismatch in the first parameter of the function for prop:procedure"
                                          "expected" (syntax-e st-name)
                                          "got" n
-                                         #:stx (st-proc-ty-property #'ty-stx))])
-
+                                         #:stx (st-proc-ty-property ty-stx))])
                      (cdr doms))))
                 arrs))]
          [_
@@ -537,10 +539,43 @@
                            "Procedure"
                            "given"
                            ty
-                           #:stx #'ty-stx)])]
-      [_
-       (tc-error/stx proc-ty-stx
-                     "expected: a nonnegative integer literal or an annotated lambda")])))
+                           #:stx ty-stx)]))
+     "expected: a nonnegative integer literal or an annotated lambda")
+    (#'prop:evt
+     (lambda (ty-stx field-name ty)
+       (if (Evt? ty)
+           ty
+           (make-Evt (Un))))
+     (lambda (ty-stx ty st-name)
+       (match ty
+         [(Fun: (list (Arrow: doms _ _ (Values: (list (Result: rng_t _ _))))))
+          (unless (= (length doms) 1)
+            (tc-error/stx ty-stx
+                          "expected: a function that takes only one argument"))
+          (if (Evt? rng_t)
+              rng_t
+              ;; fixme: return struct type alias, not always ready
+              (-mu x (make-Evt x)))]
+         [_ (if (Evt? ty)
+                ty
+                (tc-error/stx ty-stx
+                              "expected: a nonnegative integer literal, an annotated lambda that returns an event, or an event"))]))
+     "expected: a nonnegative integer literal, an annotated lambda that returns an event, or an event")))
+
+
+
+;; extract the type annotation of prop:procedure value
+(define/cond-contract (extract-proc-ty proc-ty-stx-li desc fld-names st-name)
+  (c:-> (c:listof syntax?) struct-desc? (c:listof identifier?) identifier? Type?)
+
+
+  (unless (equal? (length proc-ty-stx-li) 1)
+    (tc-error "prop:procedure can only have one value assigned to it"))
+
+  ;; fixme for/first -> for/list
+  (for/first ([proc-ty-stx (in-list proc-ty-stx-li)])
+    (define property-name (assoc-struct-property-name-property proc-ty-stx))
+    ((free-id-table-ref property-handling-table property-name) proc-ty-stx st-name fld-names desc)))
 
 ;; check and register types for a define struct
 ;; tc/struct : Listof[identifier] (U identifier (list identifier identifier))

typed-racket-test/succeed/prop-evt.rkt

@@ -0,0 +1,39 @@
+#lang typed/racket/base
+
+(define ch ((inst make-channel Number)))
+
+
+(struct aaa0 ((evt : (Evtof Number)))
+  #:property prop:evt (struct-field-index evt))
+
+(thread (lambda ()
+          (channel-put ch 10)))
+
+(ann (sync (aaa0 ch)) Number)
+
+
+(struct aaa1 ([evt : (Evtof Number)])
+  #:property prop:evt 0)
+
+(thread (lambda ()
+          (channel-put ch 10)))
+
+(ann (sync (aaa1 ch)) Number)
+
+(struct aaa2 ([evt : (Evtof Number)])
+  #:property prop:evt (lambda ([self : aaa2]) : (Evtof Number)
+                        (aaa2-evt self)))
+
+(thread (lambda ()
+          (channel-put ch 10)))
+(ann (sync (aaa2 ch)) Number)
+
+
+(define ch2 ((inst make-channel String)))
+(struct aaa3 ()
+  #:property prop:evt (ann ch2 (Evtof String)))
+
+(thread (lambda ()
+          (channel-put ch2 "10")))
+
+(ann (sync (aaa3)) String)

typed-racket-test/succeed/struct-props.rkt

@@ -21,16 +21,14 @@
   #:property prop:custom-write
   (lambda ([self : foo] [p : Output-Port] [m : (U Boolean 1 0)]) : Void
           (displayln (+ (foo-x self) 20) p))
-  #:property prop:evt 0
-
   #:property prop:custom-print-quotable 'always)
 
 (struct foobar^ foo ([y : Number])
   #:property prop:custom-write
   (lambda ([self : foobar^] [p : Output-Port] [m : (U Boolean 1 0)]) : Void
           (displayln (+ (foobar^-y self) 20) p))
 
-  #:property prop:evt (make-channel)
+  #:property prop:evt (ann (make-channel) (Evtof Any))
 
   #:property prop:custom-print-quotable 'self)