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^) (extract-prop-specified-type-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)
@@ -199,17 +201,17 @@
                 . opts))]))
 
 
-;; This function tries to extract the type annotation on a lambda
-;; expression for prop:precedure.
+;; This function tries to extract the type annotation from values for
+;; prop:procedure or prop:evt
 ;;
 ;; 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
 ;; structure type, sty-stx is in the form (structure-name type-vars ...)
 ;;
-;; val: the value expression for prop:procedure
+;; val: the value expression for the property
 ;;
 ;;Syntax Expr -> (values Syntax Syntax)
-(define-for-syntax (maybe-extract-prop-proc-ty-ann sty-stx val)
+(define-for-syntax (extract-prop-specified-type-ann sty-stx val)
   (syntax-parse val
     #:literals (-lambda ann)
     [(-lambda formals:lambda-formals ret-ty:return-ann _)

typed-racket-lib/typed-racket/env/init-envs.rkt

@@ -265,11 +265,11 @@
      `(make-Name (quote-syntax ,stx) ,args ,struct?)]
     [(fld: t acc mut)
      `(make-fld ,(type->sexp t) (quote-syntax ,acc) ,mut)]
-    [(Struct: name parent flds proc poly? pred-id properties)
+    [(Struct: name parent flds extra-tys poly? pred-id properties)
      `(make-Struct (quote-syntax ,name)
                    ,(and parent (type->sexp parent))
                    (list ,@(map type->sexp flds))
-                   ,(and proc (type->sexp proc))
+                   ,(and extra-tys `(list ,@(map type->sexp extra-tys)))
                    ,poly?
                    (quote-syntax ,pred-id)
                    (immutable-free-id-set (list ,@(for/list ([p (in-free-id-set properties)])

typed-racket-lib/typed-racket/infer/infer-unit.rkt

@@ -681,14 +681,17 @@
 
         ;; two structs with the same name
         ;; just check pairwise on the fields
-        [((Struct: nm _ flds proc _ _ _) (Struct: nm* _ flds* proc* _ _ _))
+        [((Struct: nm _ flds extra-ty _ _ _) (Struct: nm* _ flds* extra-ty* _ _ _))
          #:when (free-identifier=? nm nm*)
-         (let ([proc-c
-                (cond [(and proc proc*)
-                       (cg proc proc*)]
-                      [proc* #f]
+         (let ([extra-ty-c
+                (cond [(and extra-ty extra-ty*)
+                       (for/fold ([acc empty])
+                                  ([p extra-ty]
+                                   [p* extra-ty*])
+                         (% cset-meet acc (cg p p*)))]
+                      [extra-ty* #f]
                       [else empty])])
-           (% cset-meet proc-c (cgen/flds context flds flds*)))]
+           (% cset-meet extra-ty-c (cgen/flds context flds flds*)))]
 
         ;; two prefab structs with the same key
         [((Prefab: k ss) (Prefab: k* ts))

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/private/type-contract.rkt

@@ -727,10 +727,10 @@
                               " with unknown return values"))]
           [(Values: (list (Result: rngs _ _) ...))
            (unit/sc imports-specs exports-specs init-depends-ids (map t->sc rngs))])]
-       [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? props)
+       [(Struct: nm par (list (fld: flds acc-ids mut?) ...) extra-tys poly? pred? props)
         (cond
           [(hash-ref recursive-values nm #f)]
-          [proc (fail #:reason "procedural structs are not supported")]
+          [extra-tys (fail #:reason "structs with prop:procedure or prop:evt attached are not supported")]
           [poly?
            (struct->recursive-sc #'n* nm flds
                                            (lambda (ftsc)

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

@@ -76,7 +76,7 @@
                      [Struct:* Struct:]
                      [Row* make-Row]
                      [make-Mu unsafe-make-Mu]
-                     [Struct-proc* Struct-proc]
+                     [Struct-extra-tys* Struct-extra-tys]
                      [make-Struct* make-Struct]
                      [Mu-names: Mu-maybe-name:]
                      [Mu-body Mu-body-unsafe]
@@ -776,38 +776,42 @@
                   ;; we can only put a function type of this box when checking the property value
                   ;; for prop:procedure, which happens after a Struct rep
                   ;; instance is created.
-                  [proc (box/c (or/c #f Fun?))]
+                  [extra-tys (box/c (or/c #f (listof Type?)))]
                   [poly? boolean?]
                   [pred-id identifier?]
                   [properties (free-id-set/c identifier?)])
-  #:no-provide (Struct: Struct-proc make-Struct)
-  [#:frees (f) (combine-frees (map f (append (let ([bv (unbox proc)])
-                                               (if bv (list bv) null))
+  #:no-provide (Struct: Struct-extra-tys make-Struct)
+  [#:frees (f) (combine-frees (map f (append (let ([bv (unbox extra-tys)])
+                                               (if bv bv null))
                                              (if parent (list parent) null)
                                              flds)))]
   [#:fmap (f) (make-Struct name
                            (and parent (f parent))
                            (map f flds)
-                           (let ([bv (unbox proc)])
-                             (box (and bv (f bv))))
+                           (let ([bv (unbox extra-tys)])
+                             (box (and bv (map f bv))))
                            poly?
                            pred-id
                            properties)]
   [#:for-each (f)
    (when parent (f parent))
    (for-each f flds)
-   (when proc (f proc))]
+   (let ([bv (unbox extra-tys)])
+     (when bv (for-each f bv)))]
   ;; This should eventually be based on understanding of struct properties.
   [#:mask (mask-union mask:struct mask:procedure)]
   [#:custom-constructor
    (let ([name (normalize-id name)]
          [pred-id (normalize-id pred-id)])
-     (make-Struct name parent flds proc poly? pred-id properties))])
+     (make-Struct name parent flds extra-tys poly? pred-id properties))])
 
 
-(define/cond-contract (Struct-proc* sty)
-  (-> Struct? (or/c #f Fun?))
-  (define b (Struct-proc sty))
+(define/cond-contract (Struct-extra-tys* sty)
+  (-> (or/c Poly? Struct?) (or/c #f (listof Type?)))
+  (define sty^ (match sty
+                 [(? Struct?) sty]
+                 [(Poly: _ (? Struct? sty)) sty]))
+  (define b (Struct-extra-tys sty^))
   (and b (unbox b)))
 
 (define (make-Struct* name parent flds proc poly? pred-id properties)
@@ -816,8 +820,8 @@
 (define-match-expander Struct:*
   (lambda (stx)
     (syntax-case stx ()
-      [(_ name parent flds proc poly? pred-id properties)
-       #'(Struct: name parent flds (box proc) poly? pred-id properties)])))
+      [(_ name parent flds extra-tys poly? pred-id properties)
+       #'(Struct: name parent flds (box extra-tys) poly? pred-id properties)])))
 
 
 (def-type StructTop ([name Struct?])