diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index 7f96ad89..90da2c27 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/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 diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 2f0461c0..d2f6ec47 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/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? diff --git a/typed-racket-lib/typed-racket/utils/any-wrap.rkt b/typed-racket-lib/typed-racket/utils/any-wrap.rkt index d1951185..5b8c7a3d 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/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) diff --git a/typed-racket-test/succeed/pr226-variation-1.rkt b/typed-racket-test/succeed/pr226-variation-1.rkt new file mode 100644 index 00000000..974d4880 --- /dev/null +++ b/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")) diff --git a/typed-racket-test/succeed/pr226-variation-2.rkt b/typed-racket-test/succeed/pr226-variation-2.rkt new file mode 100644 index 00000000..1519665c --- /dev/null +++ b/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)) diff --git a/typed-racket-test/succeed/pr226-variation-3.rkt b/typed-racket-test/succeed/pr226-variation-3.rkt new file mode 100644 index 00000000..9800405e --- /dev/null +++ b/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")) diff --git a/typed-racket-test/unit-tests/contract-tests.rkt b/typed-racket-test/unit-tests/contract-tests.rkt index e416d313..2890b104 100644 --- a/typed-racket-test/unit-tests/contract-tests.rkt +++ b/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]))