From d3fac7c24a35cdd67a8cdf42dd916e6aacbcee44 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 16 Nov 2015 15:41:56 -0500 Subject: [PATCH] Revise handling of #:opaque types, and Any. Guard opaque predicates with an (-> Any Any) contract. This uses the contract generation infrastructure to avoid wrapping struct predicates. Also, relax `any-wrap/c` (the contract used for `Any` in positive position) to allow opaque structures. This also requires an enumeration of all the other kinds of values that TR understands, so that they are not confused with opaque structures. Joint work with @bennn. Closes #202. Closes #203. Closes #241. --- .../typed-racket/base-env/prims-contract.rkt | 10 +- .../typed-racket/private/type-contract.rkt | 8 +- .../typed-racket/types/abbrev.rkt | 2 +- .../typed-racket/utils/any-wrap.rkt | 68 +++- .../{fail => succeed}/exn-any.rkt | 2 - .../succeed/pr241-variation-0.rkt | 17 + .../succeed/pr241-variation-1.rkt | 21 ++ .../succeed/pr241-variation-2.rkt | 18 + .../succeed/pr241-variation-3.rkt | 19 + .../succeed/pr241-variation-4.rkt | 10 + .../succeed/pr241-variation-5.rkt | 349 ++++++++++++++++++ 11 files changed, 506 insertions(+), 18 deletions(-) rename typed-racket-test/{fail => succeed}/exn-any.rkt (89%) create mode 100644 typed-racket-test/succeed/pr241-variation-0.rkt create mode 100644 typed-racket-test/succeed/pr241-variation-1.rkt create mode 100644 typed-racket-test/succeed/pr241-variation-2.rkt create mode 100644 typed-racket-test/succeed/pr241-variation-3.rkt create mode 100644 typed-racket-test/succeed/pr241-variation-4.rkt create mode 100644 typed-racket-test/succeed/pr241-variation-5.rkt 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 90da2c27..a744dfd2 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -252,6 +252,7 @@ (define (make-contract-def-rhs type flat? maker?) (contract-def-property #'#f `#s(contract-def ,type ,flat? ,maker? untyped))) + (define (define-predicate stx) (syntax-parse stx [(_ name:id ty:expr) @@ -324,20 +325,25 @@ (define-syntax-class name-exists-kw (pattern #:name-exists)) (syntax-parse stx + [_ #:when (eq? 'module-begin (syntax-local-context)) + ;; it would be inconvenient to find the correct #%module-begin here, so we rely on splicing + #`(begin #,stx (begin))] [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...) (with-syntax ([hidden (generate-temporary #'pred)]) + (define pred-cnt + (syntax-local-lift-expression + (make-contract-def-rhs #'(-> Any Boolean) #f #f))) (quasisyntax/loc stx (begin ;; register the identifier for the top-level (see require/typed) #,@(if (eq? (syntax-local-context) 'top-level) (list #'(define-syntaxes (hidden) (values))) null) - #,(ignore #'(define pred-cnt (any/c . c-> . boolean?))) #,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred)))) #,(if (attribute ne) (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) (syntax/loc stx (define-type-alias ty (Opaque pred)))) - #,(ignore #'(require/contract pred hidden pred-cnt lib)))))])) + #,(ignore #`(require/contract pred hidden #,pred-cnt lib)))))])) diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index a8b662de..c734ccff 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -10,7 +10,7 @@ (env type-name-env row-constraint-env) (rep rep-utils) (types resolve union utils printer) - (prefix-in t: (types abbrev numeric-tower)) + (prefix-in t: (types abbrev numeric-tower subtype)) (private parse-type syntax-properties) racket/match racket/syntax racket/list racket/format @@ -383,7 +383,7 @@ (apply or/sc (map t->sc elems)))] [(and t (Function: arrs)) #:when (any->bool? arrs) - ;; Avoid putting (-> any boolean) contracts on struct predicates + ;; Avoid putting (-> any T) contracts on struct predicates (where Boolean <: T) ;; 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?)] @@ -804,9 +804,9 @@ (define (any->bool? arrs) (match arrs [(list (arr: (list (Univ:)) - (Values: (list (Result: (== -Boolean) _ _))) + (Values: (list (Result: t _ _))) #f #f '())) - #t] + (t:subtype -Boolean t)] [_ #f])) (module predicates racket/base diff --git a/typed-racket-lib/typed-racket/types/abbrev.rkt b/typed-racket-lib/typed-racket/types/abbrev.rkt index 816bce74..59fb9572 100644 --- a/typed-racket-lib/typed-racket/types/abbrev.rkt +++ b/typed-racket-lib/typed-racket/types/abbrev.rkt @@ -213,7 +213,7 @@ (make-Base 'Special-Comment #'special-comment? special-comment?)) (define/decl -Custodian (make-Base 'Custodian #'custodian? custodian?)) (define/decl -Parameterization (make-Base 'Parameterization #'parameterization? parameterization?)) -(define/decl -Inspector (make-Base 'Inspector #'inspector inspector?)) +(define/decl -Inspector (make-Base 'Inspector #'inspector? inspector?)) (define/decl -Namespace-Anchor (make-Base 'Namespace-Anchor #'namespace-anchor? namespace-anchor?)) (define/decl -Variable-Reference (make-Base 'Variable-Reference #'variable-reference? variable-reference?)) (define/decl -Internal-Definition-Context diff --git a/typed-racket-lib/typed-racket/utils/any-wrap.rkt b/typed-racket-lib/typed-racket/utils/any-wrap.rkt index 5b8c7a3d..0a673c14 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/typed-racket-lib/typed-racket/utils/any-wrap.rkt @@ -1,21 +1,65 @@ #lang racket/base (require racket/match racket/contract/combinator + racket/class racket/unit racket/fixnum racket/flonum racket/extflonum racket/set racket/undefined + (only-in racket/async-channel async-channel?) + (only-in racket/future future? fsemaphore?) + (only-in racket/pretty pretty-print-style-table?) + (only-in racket/udp udp?) (only-in (combine-in racket/private/promise) promise? prop:force promise-forcer)) (define (base-val? e) (or (number? e) (string? e) (char? e) (symbol? e) - (null? e) (regexp? e) (eq? undefined e) (path? e) - (regexp? e) (keyword? e) (bytes? e) (boolean? e) (void? e) + (null? e) (eq? undefined e) (path? e) (eof-object? e) + (regexp? e) (pregexp? e) (byte-regexp? e) (byte-pregexp? e) + (keyword? e) (bytes? e) (boolean? e) (void? e) + (bytes-converter? e) + (impersonator-property? e) + (inspector? e) + (logger? e) + (module-path? e) (resolved-module-path? e) + (pretty-print-style-table? e) + (pseudo-random-generator? e) + (semaphore? e) (fsemaphore? e) + (thread-group? e) + (udp? e) ;; Base values because you can only store flonums/fixnums in these ;; and not any higher-order values. This isn't sound if we ever ;; introduce bounded polymorphism for Flvector/Fxvector. - (flvector? e) (fxvector? e) (extflvector? e))) + (flvector? e) (fxvector? e) (extflvector? e) (extflonum? e))) + +(define (unsafe-val? e) + (or ;; TODO: async-channel and special-comment should be safe + (async-channel? e) + (special-comment? e) + ;; -- + (class? e) + (compiled-expression? e) + (compiled-module-expression? e) + (continuation-mark-key? e) ;; Stricter than necessary if key holds a base value + (continuation-mark-set? e) + (continuation-prompt-tag? e) + (custodian-box? e) + (custodian? e) + (ephemeron? e) + (future? e) + (internal-definition-context? e) + (mpair? e) + (namespace-anchor? e) + (namespace? e) + (parameterization? e) + (security-guard? e) + (struct-type-property? e) + (syntax? e) + (thread-cell? e) + (unit? e) + (variable-reference? e) + (weak-box? e))) (define (val-first-projection b) (define (fail neg-party v) @@ -28,7 +72,6 @@ (define (extract-functions struct-type) (define-values (sym init auto ref set! imms par skip?) (struct-type-info struct-type)) - (when skip? (fail neg-party s)) ;; "Opaque struct type!") (define-values (fun/chap-list _) (for/fold ([res null] [imms imms]) @@ -52,13 +95,15 @@ [par (append fun/chap-list (extract-functions par))] [else fun/chap-list])) (define-values (type skipped?) (struct-info s)) - (when skipped? (fail neg-party s)); "Opaque struct type!" + ;; It's ok to just ignore skipped? -- see https://github.com/racket/typed-racket/issues/203 (apply chaperone-struct s (extract-functions type))) (define (any-wrap/traverse neg-party v) (match v [(? base-val?) v] + [(? unsafe-val?) + (fail neg-party v)] [(cons x y) (cons (any-wrap/traverse neg-party x) (any-wrap/traverse neg-party y))] [(? vector? (? immutable?)) ;; fixme -- should have an immutable for/vector @@ -66,6 +111,9 @@ (for/vector #:length (vector-length v) ([i (in-vector v)]) (any-wrap/traverse neg-party i)))] [(? box? (? immutable?)) (box-immutable (any-wrap/traverse neg-party (unbox v)))] + [(? box?) (chaperone-box v + (lambda (v e) (any-wrap/traverse neg-party e)) + (lambda (v e) (fail neg-party v)))] ;; fixme -- handling keys properly makes it not a chaperone ;; [(? hasheq? (? immutable?)) ;; (for/hasheq ([(k v) (in-hash v)]) (values k v))] @@ -80,9 +128,6 @@ [(? vector?) (chaperone-vector v (lambda (v i e) (any-wrap/traverse neg-party e)) (lambda (v i e) (fail neg-party v)))] - [(? box?) (chaperone-box v - (lambda (v e) (any-wrap/traverse neg-party e)) - (lambda (v e) (fail neg-party v)))] [(? hash?) (chaperone-hash v (lambda (h k) (values k (lambda (h k v) (any-wrap/traverse neg-party v)))) ;; ref @@ -110,7 +155,12 @@ (λ (promise) (values (λ (val) (any-wrap/traverse neg-party val)) promise)))))] - [_ (fail neg-party v)])) + [(? channel?) + ;;bg; Should be able to take `Any` from the channel, but can't put anything in + (chaperone-channel v + (lambda (e) (values v (any-wrap/traverse neg-party v))) + (lambda (e) (fail neg-party v)))] + [_ (chaperone-struct v)])) (λ (v) (λ (neg-party) (any-wrap/traverse neg-party v)))) (define any-wrap/c diff --git a/typed-racket-test/fail/exn-any.rkt b/typed-racket-test/succeed/exn-any.rkt similarity index 89% rename from typed-racket-test/fail/exn-any.rkt rename to typed-racket-test/succeed/exn-any.rkt index 48b4dab9..131aec6e 100644 --- a/typed-racket-test/fail/exn-any.rkt +++ b/typed-racket-test/succeed/exn-any.rkt @@ -1,5 +1,3 @@ -#; -(exn-pred "Any") #lang racket/load (module m typed/racket diff --git a/typed-racket-test/succeed/pr241-variation-0.rkt b/typed-racket-test/succeed/pr241-variation-0.rkt new file mode 100644 index 00000000..bd2c02ed --- /dev/null +++ b/typed-racket-test/succeed/pr241-variation-0.rkt @@ -0,0 +1,17 @@ +#lang racket/base + +;; #:opaque structs should be allowed + +(module untyped racket/base + (struct s ()) + (define val (s)) + (provide val (struct-out s))) + +(module typed typed/racket/base + (require/typed (submod ".." untyped) + [#:opaque S s?] + [val S]) + (s? 4) + (s? val)) + +(require 'typed) diff --git a/typed-racket-test/succeed/pr241-variation-1.rkt b/typed-racket-test/succeed/pr241-variation-1.rkt new file mode 100644 index 00000000..85642571 --- /dev/null +++ b/typed-racket-test/succeed/pr241-variation-1.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +;; #:opaque predicates should not change the type of their arguments + +(module untyped racket/base + (define (bad x) + (set-box! x 5) + #t) + (provide bad)) + +(module typed typed/racket/base + (require/typed (submod ".." untyped) + [#:opaque T bad]) + (: b (Boxof String)) + (define b (box "hi")) + (with-handlers ([exn:fail:contract? (lambda (e) (void))]) + (bad b) + (void)) + (string-append (unbox b) "")) + +(require 'typed) diff --git a/typed-racket-test/succeed/pr241-variation-2.rkt b/typed-racket-test/succeed/pr241-variation-2.rkt new file mode 100644 index 00000000..6395b412 --- /dev/null +++ b/typed-racket-test/succeed/pr241-variation-2.rkt @@ -0,0 +1,18 @@ +#lang racket/base + +;; Pure functions are fine predicates + +(module untyped racket/base + (define (color? x) + (and (memq x '(red green blue)) #t)) + (provide color?)) + +(module typed typed/racket/base + (require/typed (submod ".." untyped) + [#:opaque Color color?]) + (color? 'blue) + (color? 4) + (struct s ()) + (color? s)) + +(require 'typed) diff --git a/typed-racket-test/succeed/pr241-variation-3.rkt b/typed-racket-test/succeed/pr241-variation-3.rkt new file mode 100644 index 00000000..ebfa7490 --- /dev/null +++ b/typed-racket-test/succeed/pr241-variation-3.rkt @@ -0,0 +1,19 @@ +#lang racket/base + +;; Generic struct predicates are OK + +(module u racket/base + (require racket/generic) + (define-generics foo) + (struct foo-struct () #:methods gen:foo []) + (define f1 (foo-struct)) + (provide f1 foo?)) + +(module t typed/racket/base + (require/typed (submod ".." u) + (#:opaque Foo foo?) + (f1 Foo)) + (foo? 3) + (foo? f1)) + +(require 't) diff --git a/typed-racket-test/succeed/pr241-variation-4.rkt b/typed-racket-test/succeed/pr241-variation-4.rkt new file mode 100644 index 00000000..25446ae5 --- /dev/null +++ b/typed-racket-test/succeed/pr241-variation-4.rkt @@ -0,0 +1,10 @@ +#lang racket + +;; Wrapping opaque structs should succeed + +;; From Issue #203 +;; https://github.com/racket/typed-racket/issues/203 + +(require typed-racket/utils/any-wrap) +(struct s ()) +(contract any-wrap/c (s) 'a 'b) diff --git a/typed-racket-test/succeed/pr241-variation-5.rkt b/typed-racket-test/succeed/pr241-variation-5.rkt new file mode 100644 index 00000000..20d28fe0 --- /dev/null +++ b/typed-racket-test/succeed/pr241-variation-5.rkt @@ -0,0 +1,349 @@ +#lang racket/base + +;; Check that any-wrap/c handles all base types +;; We do this by: +;; - enumerating the base types from `base-env/base-types.rkt` +;; - for each type: +;; - define a value +;; - typecheck the value +;; - wrap the value as 'Any', check failure / use in untyped code + +(require + (for-syntax racket/base) + racket/require) + +;; When #t, print a warning if some base-types do not have tests +(define-for-syntax WARN-MISSING #t) + +;; `known-base-types` is a list of triples: +;; [TYPE VALUE USE] +;; TYPE is a base type exported by Typed Racket +;; VALUE is an expression with type TYPE +;; USE is an untyped function of 1 argument, or #f. +;; If a function, a test will apply (USE (contract VALUE any-wrap/c)). +;; If #f, a test will assert that (contract VALUE any-wrap/c) fails. +;; These USE functions should exercise specific functionality +;; and not be dummy functions like (lambda (x) x). +(define-for-syntax known-base-types '( + ;; --- TODO missing value for these types + ;[Read-Table (or (current-readtable) (error 'noo)) #f] + ;[Internal-Definition-Context (syntax-local-make-definition-context) #f] + ;[Place (place hi (void)) place-kill] + + ;; --- Types that should NOT be passes as 'Any' are marked with #f + [Async-ChannelTop (make-async-channel) #f] + [ClassTop object% #f] + [Compiled-Expression (compile-syntax #'#t) #f] + [Continuation-Mark-KeyTop (make-continuation-mark-key) #f] + [Continuation-Mark-Set (current-continuation-marks) #f] + [Custodian (current-custodian) #f] + [Identifier (syntax exit) #f] + [MPairTop (mcons 1 1) #f] + [Namespace (make-empty-namespace) #f] + [Parameterization (current-parameterization) #f] + [Prompt-TagTop (make-continuation-prompt-tag) #f] + [Security-Guard (current-security-guard) #f] + [Special-Comment (make-special-comment 'hi) #f] + [Struct-Type-Property (let-values ([(n g s) (make-struct-type-property 'foo)]) n) #f] + [Syntax (syntax 'B) #f] + [Syntax-E (syntax-e (syntax 'A)) #f] + [Thread-CellTop (make-thread-cell 'X) #f] + [UnitTop (unit (import) (export)) #f] + [Variable-Reference (let ([x 4]) (#%variable-reference x)) #f] + [Weak-BoxTop (make-weak-box 3) #f] + + ;; -- Normal base types + [Subprocess + (let*-values ([(sp _out _in _err) (subprocess #f #f #f ".")]) + (close-output-port _in) + (close-input-port _out) + (close-input-port _err) + sp) + choice-evt] + [Single-Flonum-Complex 1f0+1f0i add1] + [ExtFlonum-Zero 0.0t0 extflround] + [ExtFlonum-Negative-Zero -0.0t0 extflround] + [ExtFlonum-Positive-Zero +0.0t0 extflround] + [Complex 0 add1] + [Number 0 add1] + [Inexact-Complex (let ([n (exact->inexact 1/3+1/3i)]) (if (not (real? n)) n (error 'pr241 "Failed to make Inexact-Complex"))) zero?] + [Float-Complex 1.0+1i add1] + [Exact-Number 0 add1] + [Real 0 add1] + [Nonpositive-Real 0 add1] + [Negative-Real -1 add1] + [Nonnegative-Real 0 add1] + [Positive-Real 1 add1] + [Real-Zero 0 add1] + [Inexact-Real (exact->inexact 1/3) add1] + [Single-Flonum 1.0f0 add1] + [Nonpositive-Inexact-Real (- (exact->inexact 1/3)) add1] + [Nonpositive-Single-Flonum -1.0f0 add1] + [Negative-Inexact-Real -1.0f0 add1] + [Negative-Single-Flonum -1.0f0 add1] + [Positive-Single-Flonum +1.0f0 add1] + [Nonnegative-Inexact-Real (exact->inexact 1/3) add1] + [Nonnegative-Single-Flonum 1.0f0 add1] + [Positive-Inexact-Real 1.0f0 add1] + [Inexact-Real-Nan +nan.0 zero?] + [Inexact-Real-Zero 0.0 add1] + [Inexact-Real-Negative-Zero -0.0 add1] + [Inexact-Real-Positive-Zero 0.0 add1] + [Single-Flonum-Nan +nan.f add1] + [Single-Flonum-Zero 0f0 add1] + [Single-Flonum-Negative-Zero -0f0 add1] + [Single-Flonum-Positive-Zero 0f0 add1] + [Float 1.0 add1] + [Flonum 1.0 add1] + [Nonpositive-Float -1.0 add1] + [Nonpositive-Flonum -1.0 add1] + [Negative-Float -1.0 add1] + [Negative-Flonum -1.0 add1] + [Nonnegative-Float 1.0 add1] + [Nonnegative-Flonum 1.0 add1] + [Positive-Float 1.0 add1] + [Positive-Flonum 1.0 add1] + [Float-Nan +nan.0 add1] + [Flonum-Nan +nan.0 add1] + [Float-Zero 0.0 add1] + [Flonum-Zero 0.0 add1] + [Float-Negative-Zero -0.0 add1] + [Flonum-Negative-Zero -0.0 add1] + [Float-Positive-Zero 0.0 add1] + [Flonum-Positive-Zero 0.0 add1] + [Exact-Rational 1/3 add1] + [Nonpositive-Exact-Rational 0/1 add1] + [Negative-Exact-Rational -3/2 add1] + [Nonnegative-Exact-Rational 1 add1] + [Positive-Exact-Rational 4/3 add1] + [Integer 0 add1] + [Nonpositive-Integer 0 add1] + [Negative-Integer -2 add1] + [Exact-Nonnegative-Integer 0 add1] + [Nonnegative-Integer 0 add1] + [Natural 62 add1] + [Exact-Positive-Integer 6 add1] + [Positive-Integer 6 add1] + [Fixnum 9 add1] + [Negative-Fixnum -3 add1] + [Nonpositive-Fixnum -4 add1] + [Nonnegative-Fixnum 4 add1] + [Positive-Fixnum 2 add1] + [Index 3 add1] + [Positive-Index 3 add1] + [Byte 0 add1] + [Positive-Byte 1 add1] + [Zero 0 add1] + [One 1 add1] + [ExtFlonum pi.t extflround] + [Nonpositive-ExtFlonum (->extfl -1) extflround] + [Negative-ExtFlonum (->extfl -1) extflround] + [Nonnegative-ExtFlonum (->extfl 1) extflround] + [Positive-ExtFlonum (->extfl 1) extflround] + [ExtFlonum-Nan +nan.t (lambda (n) (extfl= n n))] + + [Any 'a boolean?] + [Boolean #f not] + [BoxTop (box 5) boolean?] + [Byte-PRegexp (byte-pregexp #"\\d\\d") (lambda (p) (regexp-match? p "013a"))] + [Byte-Regexp (byte-regexp #"hi$") (lambda (p) (regexp-match? p "hi"))] + [Bytes #"hello" bytes-length] + [Bytes-Converter (or (bytes-open-converter "UTF-8" "UTF-8") (error 'pr241 "Failed to make bytes converter")) bytes-close-converter] + [ChannelTop (make-channel) channel-try-get] + [Char #\space char->integer] + [Datum 'A (lambda (x) (datum->syntax #f x))] + [EOF eof eof-object?] + [ExtFlVector (extflvector pi.t) extflvector-length] + [FSemaphore (make-fsemaphore 0) fsemaphore-post] + [False #f not] + [FlVector (flvector 1.14 2.14 3.14) flvector-length] + [FxVector (fxvector 1) fxvector-length] + [HashTableTop (hash) (lambda (h) (hash-ref h 'a #f))] + [Impersonator-Property (let-values ([(i i? i-val) (make-impersonator-property 'i)]) i) (lambda (i) (impersonate-procedure (lambda () (void)) #f i 2))] + [Input-Port (current-input-port) port?] + [Inspector (current-inspector) (lambda (i) (parameterize ([current-inspector i]) (void)))] + [Keyword (string->keyword "hi") keyword->string] + [Log-Level 'info symbol->string] + [Log-Receiver (make-log-receiver (current-logger) 'info) choice-evt] + [Logger (current-logger) (lambda (l) (log-level? l 'info))] + [Module-Path "hello.rkt" module-path?] + [Null '() length] + [Output-Port (current-output-port) port?] + [PRegexp #px"\\d\\d" (lambda (p) (regexp-match? p "013a"))] + [Path (current-directory) path->string] + [Path-For-Some-System (current-directory) path->string] + [Path-String "foo/bar" relative-path?] + [Place-Channel (let-values ([(p1 p2) (place-channel)]) p1) choice-evt] + [Port (current-input-port) port?] + [Pretty-Print-Style-Table (pretty-print-current-style-table) (lambda (x) (pretty-print-extend-style-table x '() '()))] + [Procedure (lambda (x) x) (lambda (f) (procedure-arity-includes? f 1))] + [Pseudo-Random-Generator (current-pseudo-random-generator) pseudo-random-generator->vector] + [Regexp #rx"hi$" (lambda (p) (regexp-match? p "hi"))] + [Resolved-Module-Path (make-resolved-module-path (current-directory)) resolved-module-path-name] + [Semaphore (make-semaphore) semaphore-post] + [Sexp (syntax->datum (syntax 'foo)) (lambda (x) x)] + [String "yolo" string->symbol] + [Symbol 'a symbol->string] + [TCP-Listener (tcp-listen 0) choice-evt] + [Thread (thread (lambda () (void))) choice-evt] + [Thread-Group (current-thread-group) make-thread-group] + [True #t not] + [UDP-Socket (udp-open-socket) udp-close] + [VectorTop (vector 1 2 3) (lambda (x) (vector-ref x 0))] + [Void (void) void?] + [Will-Executor (make-will-executor) choice-evt] +)) + +(define-values-for-syntax (base-untyped* base-typed*) + (for/fold ([u* '()] [t* '()]) + ([tvf (in-list known-base-types)]) + (unless (and (list? tvf) (= 3 (length tvf))) + (error 'pr241 "Expected (TYPE VAL FUN)")) + (with-syntax ([type (car tvf)] + [val (cadr tvf)] + [use (caddr tvf)] + [pos-blame 'pr241-test] + [neg-blame 'known-base-types] + [id (gensym (car tvf))]) + ;; Wrap value in contract, pass it to `use` or assert a wrap failure + ;; Ignore the result + (define u-stx + (if (eq? #f (caddr tvf)) + #'(with-handlers ([exn:fail:contract? (lambda (e) (void))]) + (contract any-wrap/c val 'pos-blame 'neg-blame) + (error 'pr241 (format "Higher-Order value '~a' incorrectly allowed as Any" val))) + #'((lambda any* (void)) + (use (contract any-wrap/c val 'pos-blame 'neg-blame))))) + ;; Bind the value to a typed identifier + (define t-stx + #'(begin (: id type) (define id val))) + (values + (cons u-stx u*) + (cons t-stx t*))))) + +;; `known-polymorphic-types` is a list of 4-lists: +;; [TYPE-TAG TYPE VALUE USE] +;; TYPE-TAG is a polymorphic type exported by Typed Racket +;; TYPE is an instantiation of TYPE-TAG +;; VALUE is an expression with type TYPE +;; USE is the same as for `known-base-types` +(define-for-syntax known-poly-types '( + ;; --- Higher-Order polymorphic types + [Async-Channelof (Async-Channelof Any) (make-async-channel) #f] + [Continuation-Mark-Keyof (Continuation-Mark-Keyof Any) (make-continuation-mark-key 'X) #f] + [Custodian-Boxof (Custodian-Boxof Integer) (make-custodian-box (current-custodian) 1) #f] + [Ephemeronof (Ephemeronof Integer) (make-ephemeron 'key 4) #f] + [Evtof (Evtof String) never-evt choice-evt] + [Futureof (Futureof Integer) (future (lambda () 4)) #f] + [MPairof (MPairof Integer String) (mcons 4 "ad") #f] + [MListof (MListof Integer) (mcons 4 '()) #f] + [Prompt-Tagof (Prompt-Tagof Any Any) (make-continuation-prompt-tag) #f] + [Syntaxof (Syntaxof Integer) #'1 #f] + [Thread-Cellof (Thread-Cellof Integer) (make-thread-cell 1) #f] + [Weak-Boxof (Weak-Boxof Integer) (make-weak-box 1) #f] + + ;; -- Wrappable polymorphic types + [Boxof (Boxof Integer) (box 3) (lambda (v) (add1 (unbox v)))] + [Channelof (Channelof Integer) (make-channel) channel-try-get] + [HashTable (HashTable Symbol String) (hash) (lambda (h) (hash-ref h 'a #f))] + [Listof (Listof Integer) (list 1) (lambda (xs) (add1 (car xs)))] + [Option (Option Integer) 1 add1] + [Pair (Pair Integer Boolean) (cons 1 #t) (lambda (v) (add1 (car v)))] + [Pairof (Pairof Integer Boolean) (cons 1 #f) (lambda (v) (add1 (car v)))] + [Promise (Promise Integer) (delay 3) force] + [Sequenceof (Sequenceof Natural) '(1 2 3) sequence->list] + [Setof (Setof Integer) (set) set-empty?] + [Sexpof (Sexpof Integer) (syntax->datum #'(1 2 3)) (lambda (xs) (add1 (car xs)))] + [Vectorof (Vectorof Integer) (vector 1) (lambda (v) (add1 (vector-ref v 0)))] +)) + +;; We don't have values to test these types with, but trust they're wrapped correctly +(define-for-syntax whitelist '( + (Undefined . #f) + (Nothing . #f) + (Struct-TypeTop . #f) + (Module-Path-Index . #f) + (Compiled-Module-Expression . #f) + (Namespace-Anchor . "See `variation-6` for PR https://github.com/racket/typed-racket/pull/248") +)) + +(define-values-for-syntax (poly-untyped* poly-typed*) + (for/fold ([u* '()] [t* '()]) + ([gtvf (in-list known-poly-types)]) + (unless (and (list? gtvf) (= 4 (length gtvf))) + (error 'pr241 "Expected (TYPE-TAG TYPE VAL FUN)")) + (with-syntax ([_tag (car gtvf)] ;; Unused here + [type (cadr gtvf)] + [val (caddr gtvf)] + [use (cadddr gtvf)] + [pos-blame 'pr241-test] + [neg-blame 'known-poly-types] + [id (gensym (car gtvf))]) + ;; Wrap value in contract, pass it to `use` or assert a wrap failure + ;; Ignore the result + (define u-stx + (if (eq? #f (cadddr gtvf)) + #'(with-handlers ([exn:fail:contract? (lambda (e) (void))]) + (contract any-wrap/c val 'pos-blame 'neg-blame) + (error 'pr241 (format "Higher-Order value '~a' incorrectly allowed as Any" val))) + #'((lambda any* (void)) + (use (contract any-wrap/c val 'pos-blame 'neg-blame))))) + ;; Bind the value to a typed identifier + (define t-stx + #'(begin (: id type) (define id val))) + (values + (cons u-stx u*) + (cons t-stx t*))))) + +(define-syntax (known-types->tests stx) + ;; Put the `use-` list in an untyped module, + ;; put the `declare-` list in a typed module. + #`(begin + (module check-uses racket + (require + racket/async-channel + racket/flonum + racket/extflonum + racket/fixnum + typed-racket/utils/any-wrap) + #,@base-untyped* + #,@poly-untyped* + (printf "Successfully used ~a wrapped values\n" + #,(+ (length base-untyped*) (length poly-untyped*)))) + (module check-types typed/racket + (require + racket/flonum + racket/fixnum + racket/extflonum) + (require/typed racket/base + [variable-reference->module-path-index (-> Any Module-Path-Index)]) + (require/typed racket/async-channel + [make-async-channel (-> (Async-Channelof Any))]) + #,@base-typed* + #,@poly-typed* + (printf "Successfully typechecked ~a identifiers\n" + #,(+ (length base-typed*) (length poly-typed*)))))) + +(define-for-syntax (known-string? str) + (define s (string->symbol str)) + (member* s known-base-types known-poly-types whitelist)) + +(define-for-syntax (member* s . x**) + (for*/or ([x* (in-list x**)] + [x (in-list x*)]) + (eq? s (car x)))) + +(require + (filtered-in + (if WARN-MISSING + (lambda (str) + (when (not (known-string? str)) (printf "WARNING: Missing test for base type '~a'\n" str)) + #f) + (lambda (str) #f)) + typed-racket/base-env/base-types)) + +(known-types->tests) + +(require + 'check-uses + 'check-types)