diff --git a/collects/tests/typed-racket/succeed/promise.rkt b/collects/tests/typed-racket/succeed/promise.rkt new file mode 100644 index 00000000..e61e6821 --- /dev/null +++ b/collects/tests/typed-racket/succeed/promise.rkt @@ -0,0 +1,14 @@ +#lang typed/racket + +(require typed/rackunit) + +;; Test path reasoning for promises + +(: foo : (Promise (U Integer String)) -> (U Number False)) +(define (foo del) + (if (integer? (force del)) + (+ 1 (force del)) + (string->number (force del)))) + +(check-equal? (foo (delay 5)) 6) +(check-equal? (foo (delay "5")) 5) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 90b7f308..397893ef 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -2672,7 +2672,7 @@ ;Section 9.3 (Delayed Evaluation) [promise? (make-pred-ty (-Promise Univ))] -[force (-poly (a) (-> (-Promise a) a))] +[force (-poly (a) (->acc (list (-Promise a)) a (list -force)))] [promise-forced? (-poly (a) (-> (-Promise a) B))] [promise-running? (-poly (a) (-> (-Promise a) B))] diff --git a/collects/typed-racket/rep/object-rep.rkt b/collects/typed-racket/rep/object-rep.rkt index 9f5877a3..296a5e95 100644 --- a/collects/typed-racket/rep/object-rep.rkt +++ b/collects/typed-racket/rep/object-rep.rkt @@ -1,11 +1,17 @@ #lang racket/base +;; Representation of "objects" --- these describe the +;; part of an environment that an expression accesses +;; +;; See "Logical Types for Untyped Languages" pg.3 + (require "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt" "../utils/utils.rkt" (contract-req)) (provide object-equal?) (def-pathelem CarPE () [#:fold-rhs #:base]) (def-pathelem CdrPE () [#:fold-rhs #:base]) (def-pathelem SyntaxPE () [#:fold-rhs #:base]) +(def-pathelem ForcePE () [#:fold-rhs #:base]) ;; t is always a Name (can't put that into the contract b/c of circularity) (def-pathelem StructPE ([t Type/c] [idx natural-number/c]) [#:frees (λ (f) (f t))] diff --git a/collects/typed-racket/typecheck/tc-envops.rkt b/collects/typed-racket/typecheck/tc-envops.rkt index 8c8e4cfe..238402eb 100644 --- a/collects/typed-racket/typecheck/tc-envops.rkt +++ b/collects/typed-racket/typecheck/tc-envops.rkt @@ -38,6 +38,12 @@ [((Syntax: t) (NotTypeFilter: u (list rst ... (SyntaxPE:)) x)) (make-Syntax (update t (-not-filter u x rst)))] + ;; promise op + [((Promise: t) (TypeFilter: u (list rst ... (ForcePE:)) x)) + (make-Promise (update t (-filter u x rst)))] + [((Promise: t) (NotTypeFilter: u (list rst ... (ForcePE:)) x)) + (make-Promise (update t (-not-filter u x rst)))] + ;; struct ops [((Struct: nm par flds proc poly pred) (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index 8d858f4e..54e71de6 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -284,6 +284,7 @@ (define -car (make-CarPE)) (define -cdr (make-CdrPE)) (define -syntax-e (make-SyntaxPE)) +(define -force (make-ForcePE)) ;; convenient syntax diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index 034d73c0..b34feb2e 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -83,6 +83,7 @@ (match c [(CarPE:) (fp "car")] [(CdrPE:) (fp "cdr")] + [(ForcePE:) (fp "force")] [(StructPE: t i) (fp "(~a ~a)" t i)] [else (fp "(Unknown Path Element: ~a)" (struct->vector c))]))