Revamp handling of Any as a contract.

The contract now has two major differences:
 - It raises an error when it would have to wrap.
 - It uses chaperones to delay errors as long as possible

In general, using `Any` as a type when exporting to untyped
code will now just work, unless the untyped code tries to
communicate values back to the typed side, in which case an
immediate error will be raised.

Much of the implementation comes from the membrane design
from [Strickland et al, OOPSLA 2012].

collects/tests/typed-racket/unit-tests/contract-tests.rkt

@@ -20,7 +20,7 @@
   (test-suite "Contract Tests"
               (t (-Number . -> . -Number))
               (t (-Promise -Number))
-              (t/fail (-set Univ)) 
+              (t (-set Univ)) 
               ))
 
 (define-go contract-tests)

collects/typed-racket/private/type-contract.rkt

@@ -182,11 +182,10 @@
         [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))]
         ;; any/c doesn't provide protection in positive position
         [(Univ:)
-         (if from-typed? 
+         (cond [from-typed? 
-             (begin
+                (set-chaperone!)
-               (set-impersonator!)
+                #'any-wrap/c]
-               #'any-wrap/c)
+               [else #'any/c])]
-               #'any/c)]
         ;; we special-case lists:
         [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
          (if (and (not from-typed?) (type-equal? elem-ty t:Univ))
@@ -293,7 +292,7 @@
          (match-let ([(Mu-name: n-nm _) ty])
            (with-syntax ([(n*) (generate-temporaries (list n-nm))])
              (parameterize ([vars (cons (list n #'n*) (vars))]
-                            [current-contract-kind flat-sym])
+                            [current-contract-kind (contract-kind-min kind chaperone-sym)])
                (define ctc (t->c b))
                #`(letrec ([n* (recursive-contract
                                 #,ctc
@@ -329,7 +328,8 @@
                   (with-syntax* ([rec (generate-temporary 'rec)])
                     (define required-recursive-kind
                        (contract-kind-min kind (if mut? impersonator-sym chaperone-sym)))
-                    (parameterize ((current-contract-kind flat-sym))
+                    ;(printf "kind: ~a mut-k: ~a req-rec-kind: ~a\n" kind (if mut? impersonator-sym chaperone-sym) required-recursive-kind)
+                    (parameterize ((current-contract-kind (contract-kind-min kind chaperone-sym)))
                       (let ((fld-ctc (t->c fty #:seen (cons (cons ty #'rec) structs-seen)
                                            #:kind required-recursive-kind)))
                         #`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind)))))

collects/typed-racket/types/printer.rkt

@@ -213,6 +213,7 @@
     [(Name: stx) (fp "~a" (syntax-e stx))]
     [(app has-name? (? values name))
      (fp "~a" name)]
+    [(StructType: (Struct: nm _ _ _ _ _)) (fp "(StructType ~a)" (syntax-e nm))]
     [(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))]
     [(BoxTop:) (fp "Box")]
     [(ChannelTop:) (fp "Channel")]

collects/typed-racket/types/subtype.rkt

@@ -52,7 +52,7 @@
   (define k (cons (unsafe-struct-ref s 0) (unsafe-struct-ref t 0)))
   (define (new-val) 
     (define result (handle-failure (and (subtype* (current-seen) s t) #t)))
-    (printf "subtype cache miss ~a ~a\n" s t)
+    ;(printf "subtype cache miss ~a ~a\n" s t)
     result)
   (hash-ref! subtype-cache k new-val))
 

collects/typed-racket/utils/any-wrap.rkt

@@ -2,44 +2,72 @@
 
 (require racket/match racket/contract/base racket/contract/combinator)
 
-(define-struct any-wrap (val)
-  #:property prop:custom-write
-  (lambda (v p write?)
-    (fprintf p "#<Typed Value: ~a>" (any-wrap-val v))))
-
 (define undef (letrec ([x x]) x))
 
-(define (traverse wrap?)
+(define (traverse b)
+  (define (fail v)
+    (raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`"))
+
   (define (t v)
+    (define (wrap-struct s)
+      (define (extract-functions struct-type)
+        (define-values (sym init auto ref set! imms par skip?)
+          (struct-type-info type))
+        (when skip? (fail s)) ;; "Opaque struct type!")
+        (define-values (fun/chap-list _)
+          (for/fold ([res null]
+                     [imms imms])
+              ([n (in-range (+ init auto))])
+            (if (and (pair? imms) (= (car imms) n))
+                ;; field is immutable
+                (values 
+                 (list* (make-struct-field-accessor ref n)
+                        (lambda (s v) (t v))
+                        res)
+                 (cdr imms))
+                ;; field is mutable
+                (values
+                 (list* (make-struct-field-accessor ref n)
+                        (lambda (s v) (t v))
+                        (make-struct-field-mutator set! n)
+                        (lambda (s v) (fail s))
+                        res)
+                 imms))))
+        (cond
+          [par (cons fun/chap-list (extract-functions par))]
+          [else fun/chap-list]))
+      (define-values (type skipped?) (struct-info s))
+      (when skipped? (fail s));  "Opaque struct type!"
+      (apply chaperone-struct s (extract-functions type)))
+
     (match v
-      [(? (lambda (e) (and (any-wrap? e) (not wrap?)))) (any-wrap-val v)]
       [(? (lambda (e)
             (or (number? e) (string? e) (char? e) (symbol? e)
                 (null? e) (regexp? e) (eq? undef e)
                 (keyword? e) (bytes? e) (boolean? e) (void? e))))
        v]
       [(cons x y) (cons (t x) (t y))]
-      [(and (? immutable?) (? vector?)) 
+      [(? vector?) (chaperone-vector v
-       (for/vector #:length (vector-length v)
+                                     (lambda (v i e) (t e))
-         ([i (in-vector v)]) (t i))]
+                                     (lambda (v i e) (fail v)))]
-      [(and (? immutable?) (box v)) (box (t v))]
+      [(? box?) (chaperone-box v
-      [(and (? immutable?) (? hash? v))
+                               (lambda (v e) (t e))
-       ((cond [(hash-eq? v) make-immutable-hasheq]
+                               (lambda (v e) (fail v)))]
-              [(hash-eqv? v) make-immutable-hasheqv]
+      [(? hash?) (chaperone-hash v
-              [else make-immutable-hash])
+                                 (lambda (h k) (values k (lambda (h k v) (t v)))) ;; ref
-        (for/list ([(k v) (in-hash v)])
+                                 (lambda (h k n) (if (immutable? v) (values k n) (fail v))) ;; set
-          (cons (t k) (t v))))]
+                                 (lambda (h v) v) ;; remove
-      #; ;; need to check immutablity
+                                 (lambda (h k) (t k)))] ;; key
-      [(? prefab-struct-key)
+      [(? evt?) (chaperone-evt v (lambda (e) (values e t)))]
-       (let* ([k (prefab-struct-key v)]
+      [(? struct?) (wrap-struct v)]
-              [vals (struct->vector v)])
+      [(? procedure?) (chaperone-procedure v (lambda _ (fail v)))]
-         (apply make-prefab-struct k (for/list ([i (in-vector vals 1)]) i)))]
+      [_ (fail v)]))
-      [_ (if wrap? (make-any-wrap v) v)]))
   t)
 
 (define any-wrap/c
-  (make-contract
+  (make-chaperone-contract
    #:name 'Any
-   #:projection (compose traverse blame-original?)))
+   #:first-order (lambda (x) #t)
+   #:projection traverse))
 
 (provide any-wrap/c)