wip

Author: capfredf

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,7 +378,7 @@
   (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))])
+                              (Struct-proc sty))])
       (if maybe-proc-ty (intersect st-type-alias maybe-proc-ty)
           st-type-alias)) )
 
@@ -463,84 +456,107 @@
       (struct-names-type-name (parsed-struct-names parsed-struct))))
   (refine-variance! names stys tvarss))
 
+
+(define ((make-extract predicate mismatched-field-type-errors customized-proc property-lambda-rng-chck)
+         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))
+     (unless (predicate ty)
+       (tc-error/fields
+        (format "field ~a is not a ~a" (syntax-e (list-ref fld-names n)) (car mismatched-field-type-errors))
+        "expected"
+        (cdr mismatched-field-type-errors)
+        "given"
+        ty
+        #:stx 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))]
+     (match ty
+       [(Fun: (list arrs ...))
+        (make-Fun
+         (map (lambda (arr)
+                (Arrow-update
+                 arr
+                 dom
+                 rng
+                 (lambda (doms rng)
+                   (match (car doms)
+                     [(Name/simple: n)
+                      #:when (free-identifier=? n st-name)
+                      (void)]
+                     [(App: (Name/simple: rator) vars)
+                      #:when (free-identifier=? rator st-name)
+                      (void)]
+                     [(Univ:)
+                      (void)]
+                     [(or (Name/simple: (app syntax-e n)) n)
+                      (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))])
+                   (when property-lambda-rng-chck
+                     (property-lambda-rng-chck rng))
+                   (values (cdr doms) rng))))
+              arrs))]
+       [_
+        (tc-error/fields "type mismatch"
+                         "expected"
+                         "Procedure"
+                         "given"
+                         ty
+                         #:stx #'ty-stx)])]
+    [_
+     (customized-proc ty-stx)]))
+
+(define-syntax-rule (define-property-handling-table (name predicate msg-parts custimized-handling rng-chck) ...)
+  (make-immutable-free-id-table (list (cons name (make-extract predicate msg-parts custimized-handling rng-chck))
+                                      ...)))
+
+(define property-handling-table
+  (define-property-handling-table
+    (#'prop:procedure Fun? (cons "function" "Procedure")
+     (lambda (ty-stx)
+       (tc-error/stx ty-stx
+                     "expected: a nonnegative integer literal or an annotated lambda"))
+     #f)))
+
+
+
 ;; extract the type annotation of prop:procedure value
-(define/cond-contract (extract-proc-ty proc-ty-stx desc fld-names st-name)
+(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) 1)
+
+  (unless (equal? (length proc-ty-stx-li) 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))
-       (unless (Fun? ty)
-         (tc-error/fields
-          (format "field ~a is not a function" (syntax-e (list-ref fld-names n)))
-          "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))]
-       (match ty
-         [(Fun: (list arrs ...))
-          (make-Fun
-           (map (lambda (arr)
-                  (Arrow-update
-                   arr
-                   dom
-                   (lambda (doms)
-                     (match (car doms)
-                       [(Name/simple: n)
-                        #:when (free-identifier=? n st-name)
-                        (void)]
-                       [(App: (Name/simple: rator) vars)
-                        #:when (free-identifier=? rator st-name)
-                        (void)]
-                       [(Univ:)
-                        (void)]
-                       [(or (Name/simple: (app syntax-e n)) n)
-                        (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))])
-
-                     (cdr doms))))
-                arrs))]
-         [_
-          (tc-error/fields "type mismatch"
-                           "expected"
-                           "Procedure"
-                           "given"
-                           ty
-                           #:stx #'ty-stx)])]
-      [_
-       (tc-error/stx proc-ty-stx
-                     "expected: a nonnegative integer literal or an annotated lambda")])))
+  ;; 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/struct-props.rkt

@@ -21,8 +21,6 @@
   #: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])