safe & efficient (-> Any Boolean) contract

New strategy for compiling the (-> Any Boolean) type to a contract.
When possible, uses `struct-predicate-procedure?` instead of
 wrapping in `(-> any-wrap/c boolean?)`.
Makes exceptions for untyped chaperones/impersonators over struct predicates;
 those are always wrapped with `(-> any-wrap/c boolean?)`.

This change also affects (require/typed ... [#:struct ...]), but not #:opaque

typed-racket-lib/typed-racket/base-env/prims-contract.rkt

@@ -72,6 +72,7 @@
          racket/struct-info
          syntax/struct
          syntax/location
+         (for-template "../utils/any-wrap.rkt")
          "../utils/tc-utils.rkt"
          "../private/syntax-properties.rkt"
          "../typecheck/internal-forms.rkt"
@@ -468,7 +469,7 @@
                                   si))
 
                          (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only)
-                         #,(ignore #'(require/contract pred hidden (any/c . c-> . boolean?) lib))
+                         #,(ignore #'(require/contract pred hidden (or/c struct-predicate-procedure?/c (c-> any-wrap/c boolean?)) lib))
                          #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm)))
                          (require/typed #:internal (maker-name real-maker) nm lib
                                         #:struct-maker parent

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

@@ -16,7 +16,7 @@
  racket/format
  racket/dict
  syntax/flatten-begin
- (only-in (types abbrev) -Bottom)
+ (only-in (types abbrev) -Bottom -Boolean)
  (static-contracts instantiate optimize structures combinators)
  ;; TODO make this from contract-req
  (prefix-in c: racket/contract)
@@ -380,6 +380,17 @@
          (if numeric-sc
              (apply or/sc numeric-sc (map t->sc non-numeric))
              (apply or/sc (map t->sc elems)))]
+        [(and t (Function: arrs))
+         #:when (any->bool? arrs)
+         ;; Avoid putting (-> any boolean) contracts on struct predicates
+         ;; Optimization: if the value is typed, we can assume it's not wrapped
+         ;;  in a type-unsafe chaperone/impersonator and use the unsafe contract
+         (let* ([unsafe-spp/sc (flat/sc #'struct-predicate-procedure?)]
+                [safe-spp/sc (flat/sc #'struct-predicate-procedure?/c)]
+                [optimized/sc (if (from-typed? typed-side)
+                                  unsafe-spp/sc
+                                  safe-spp/sc)])
+           (or/sc optimized/sc (t->sc/fun t)))]
         [(and t (Function: _)) (t->sc/fun t)]
         [(Set: t) (set/sc (t->sc t))]
         [(Sequence: ts) (apply sequence/sc (map t->sc ts))]
@@ -788,6 +799,15 @@
           [_ type])]))
     #f))
 
+;; True if the arities `arrs` are what we'd expect from a struct predicate
+(define (any->bool? arrs)
+  (match arrs
+    [(list (arr: (list (Univ:))
+                 (Values: (list (Result: (== -Boolean) _ _)))
+                 #f #f '()))
+     #t]
+    [_ #f]))
+
 (module predicates racket/base
   (require racket/extflonum)
   (provide nonnegative? nonpositive?

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

@@ -120,4 +120,10 @@
    #:projection (λ (blame) (λ (val) (((val-first-projection blame) val) #f)))
    #:val-first-projection val-first-projection))
 
-(provide any-wrap/c)
+;; Contract for "safe" struct predicate procedures.
+;; We can trust that these obey the type (-> Any Boolean).
+(define (struct-predicate-procedure?/c x)
+  (and (struct-predicate-procedure? x)
+       (not (impersonator? x))))
+
+(provide any-wrap/c struct-predicate-procedure?/c)

typed-racket-test/succeed/pr226-variation-1.rkt

@@ -0,0 +1,18 @@
+#lang typed/racket
+
+;; Struct predicates should not be wrapped in a contract
+;;  when they cross a typed/untyped boundary.
+;; We know they're safe! Don't suffer the indirection cost.
+
+(module untyped racket
+  (struct s ())
+  (provide (struct-out s)))
+
+(require/typed 'untyped
+  [#:struct s ()])
+
+(require/typed racket/contract/base
+  [has-contract? (-> Any Boolean)])
+
+(when (has-contract? s?)
+  (error 'pr226 "safe struct predicate was wrapped in a contract"))

typed-racket-test/succeed/pr226-variation-2.rkt

@@ -0,0 +1,20 @@
+#lang typed/racket
+
+;; Chaperoned struct predicates must be wrapped in a contract.
+;; (Even though `struct-predicate-procedure?` will return
+;;  true for these values)
+
+(module untyped racket
+  (struct s ())
+  (define s?? (chaperone-procedure s? (lambda (x) (x) x)))
+  ;; provide enough names to trick #:struct
+  (provide s struct:s (rename-out [s?? s?])))
+
+(require/typed 'untyped
+  [#:struct s ()])
+
+(define (fail-if-called)
+  (error 'pr226 "Untyped code invoked a higher-order value passed as 'Any'"))
+
+(with-handlers ([exn:fail:contract? (lambda (e) 'success)])
+  (s? fail-if-called))

typed-racket-test/succeed/pr226-variation-3.rkt

@@ -0,0 +1,25 @@
+#lang typed/racket
+
+;; Untyped should not be able to pass arbitrary code in
+;;  in place of a struct predicate.
+
+(module untyped racket
+  (struct s ())
+  (define (s?? x)
+    (when (box? x)
+      (set-box! x (void)))
+    #t)
+  (provide s struct:s (rename-out [s?? s?])))
+
+(require/typed 'untyped
+  [#:struct s ()])
+
+(: suitcase (Boxof '$$$))
+(define suitcase (box '$$$))
+
+(with-handlers ([exn:fail:contract? (lambda (x) (void))])
+  (s? suitcase)
+  (void))
+
+(unless (and (eq? '$$$ (unbox suitcase)))
+  (error 'pr226 "THEY SLIPPED US A RINGER"))

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

@@ -224,6 +224,44 @@
               (t-sc (-lst Univ) (listof/sc any-wrap/sc))
               (t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc)))
 
+              ;; Github pull request #226
+              (let ([ctc (-> Univ -Boolean)])
+                ;; Ordinary functions should have a contract
+                (t-int ctc
+                       (lambda (f) (f 6))
+                       (lambda (x) #t)
+                       #:untyped)
+                (t-int/fail ctc
+                            (lambda (f) (f 6))
+                            (lambda (x) 'bad)
+                            #:untyped
+                            #:msg #rx"promised: \\(or/c #f #t\\).*produced: 'bad.*blaming: untyped")
+                ;; Struct predicates should not have a contract
+                (t-int ctc
+                       (lambda (foo?)
+                         (when (has-contract? foo?)
+                           (error "Regression failed for PR #266: struct predicate has a contract"))
+                         (foo? foo?))
+                       (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
+                         foo?)
+                       #:untyped)
+                ;; Unless the struct predicate is guarded by an untyped chaperone
+                (t-int/fail ctc
+                            (lambda (foo?) (foo? string-append))
+                            (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
+                              (chaperone-procedure foo? (lambda (x) (x 0) x)))
+                            #:untyped
+                            #:msg #rx"broke its own contract")
+                ;; Typed chaperones are okay, though
+                (t-int ctc
+                       (lambda (foo?)
+                         (when (has-contract? foo?)
+                           (error "Regression failed for PR #266: typed chaperone has a contract"))
+                         (foo? foo?))
+                       (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
+                         (chaperone-procedure foo? #f))
+                       #:typed))
+
               ;; classes
               (t-sc (-class) (class/sc #f null null))
               (t-sc (-class #:init ([x -Number #f] [y -Number #f]))