From 5cd5f772d699c9a66627caeab93ae5d1569864c9 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@cs.indiana.edu>
Date: Wed, 22 Jul 2015 14:22:34 -0400
Subject: [PATCH] Don't allow promises created with `delay/name` as `(Promise
 T)`.

Since these promises re-evaluate their bodies every time they
are forced, allowing them makes `force` not idempotent and not
safe to treat as a path.

This change is slightly backwards-incompatible, since programs
that previously passed `delay/name` promises across the typed
boundary will now fail at runtime. The alternative is also
incompatible: stop treating `force` as a path. Since `delay/name`
is quite obscure, this approach seems like the safer choice.
---
 .../combinators/structural.rkt                |  3 +-
 typed-racket-test/fail/promise-delay-name.rkt | 29 +++++++++++++++++++
 2 files changed, 31 insertions(+), 1 deletion(-)
 create mode 100644 typed-racket-test/fail/promise-delay-name.rkt

diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
index bcb6379a..ba8c418f 100644
--- a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
+++ b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
@@ -14,6 +14,7 @@
                        racket/set
                        racket/async-channel
                        unstable/contract
+                       racket/promise
                        "../../utils/evt-contract.rkt")
          racket/contract
          racket/async-channel)
@@ -152,7 +153,7 @@
   ((set/sc (#:covariant #:chaperone)) set/c #:flat)
   ((vector/sc . (#:invariant)) vector/c #:chaperone)
   ((vectorof/sc (#:invariant)) vectorof #:chaperone)
-  ((promise/sc (#:covariant)) promise/c #:chaperone)
+  ((promise/sc (#:covariant)) (and/c promise/c (not/c promise/name?)) #:chaperone)
   ((syntax/sc (#:covariant #:flat)) syntax/c #:flat)
   ((hash/sc (#:invariant #:flat) (#:invariant)) hash/c #:chaperone)
   ((box/sc (#:invariant)) box/c #:chaperone)
diff --git a/typed-racket-test/fail/promise-delay-name.rkt b/typed-racket-test/fail/promise-delay-name.rkt
new file mode 100644
index 00000000..2028ebb0
--- /dev/null
+++ b/typed-racket-test/fail/promise-delay-name.rkt
@@ -0,0 +1,29 @@
+#;
+(exn-pred "delay/name")
+#lang racket
+
+;; delay/name is a macro, so we wrap it with a function so we can type it:
+(module untyped racket
+  (provide delay/name/thunk)
+  (define (delay/name/thunk f) (delay/name (f))))
+
+;; Now we require/typed our function
+(module typed-delay/name/thunk typed/racket
+  (require/typed (submod ".." untyped) [delay/name/thunk (∀ (T) (→ (→ T) (Promise T)))])
+  (provide delay/name/thunk))
+
+;; This module shows the bug:
+(module bug typed/racket
+  (require (submod ".." typed-delay/name/thunk))
+
+  (define mutable : (U 'a 'b) 'a)
+
+  (define ab-mut (delay/name/thunk (λ () (begin0 mutable
+                                                 (set! mutable 'b))))) ;; BAD BAD BAD!
+
+  (ann (if (eq? (force ab-mut) 'a) ;; Here, (eq? (force ab-mut) 'a)
+           (force ab-mut) ;; But here, (eq? (force ab-mut) 'b)
+           #f)
+       (U 'a #f))) ;; This typechecks, and throws no warning, but prints 'b !!!
+
+(require 'bug)