Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@capfredf
capfredf committed Apr 20, 2022
1 parent 5482ed7 commit 01e0b82
Show file tree
Hide file tree
Showing 4 changed files with 87 additions and 57 deletions.
2 changes: 1 addition & 1 deletion typed-racket-lib/typed-racket/base-env/base-env.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (-evt Univ)) -Nat) #'evt?)]
[current-evt-pseudo-random-generator
(-Param -Pseudo-Random-Generator -Pseudo-Random-Generator)]

Expand Down
110 changes: 55 additions & 55 deletions typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -458,7 +458,7 @@
(refine-variance! names stys tvarss))


(define ((make-extract check-field-type customized-proc check-doms-rng)
(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)
Expand Down Expand Up @@ -487,45 +487,12 @@

[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))])
(if check-doms-rng
(check-doms-rng #'ty-stx (cdr doms) 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 check-field-type custimized-handling rng-chck) ...)
(make-immutable-free-id-table (list (cons name (make-extract check-field-type custimized-handling rng-chck))
(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
Expand All @@ -541,25 +508,58 @@
ty
#:stx ty-stx))
ty)
(lambda (ty-stx)
(tc-error/stx ty-stx
"expected: a nonnegative integer literal or an annotated lambda"))
#f)
(#'prop:evt?
(lambda (ty-stx ty st-name)
(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)]))
"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)
(tc-error/stx ty-stx
"expected: a nonnegative integer literal, an annotated lambda that returns an event, or an event"))
(lambda (ty-stx doms rng)
(unless (zero? (length doms))
(tc-error/stx ty-stx
"expected: a function that takes only one argument"))
(if (Evt? rng)
(values doms rng)
(values doms (-mu x (make-Evt x))))))))
(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
(-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")))



Expand Down
30 changes: 30 additions & 0 deletions typed-racket-test/succeed/prop-evt.rkt
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
#lang typed/racket/base


(struct aaa0 ((evt : (Evtof Number)))
#:property prop:evt (struct-field-index evt))

(ann (sync (aaa0 (make-channel))) Number)


(struct aaa1 ([evt : (Evtof Number)])
#:property prop:evt 0)

(ann (sync (aaa1 (make-channel))) Number)

(struct aaa2 ([evt : (Evtof Number)])
#:property prop:evt (lambda ([self : aaa2]) : (Evtof Number)
(aaa2-evt self)))

(ann (sync (aaa2 (make-channel))) Number)

(struct aaa3 ([evt : (Evtof String)])
#:property prop:evt (ann (make-channel) (Evtof String)))

(ann (sync (aaa3 (make-channel))) String)


(struct aaa4 ([evt : (Evtof String)])
#:property prop:evt (make-channel))

(ann (sync (aaa3 (make-channel))) String)
2 changes: 1 addition & 1 deletion typed-racket-test/succeed/struct-props.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -28,7 +28,7 @@
(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)

Expand Down

0 comments on commit 01e0b82

Please sign in to comment.