diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index f0c30fc9..a14e53da 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -194,6 +194,11 @@ (loop t 'both recursive-values)) (define (t->sc/method t) (t->sc/function t fail typed-side recursive-values loop #t)) (define (t->sc/fun t) (t->sc/function t fail typed-side recursive-values loop #f)) + + (define (only-untyped sc) + (if (from-typed? typed-side) + (fail #:reason "contract generation not supported for this type") + sc)) (match type ;; Applications of implicit recursive type aliases ;; @@ -322,6 +327,18 @@ (λ () (error 'type->static-contract "Recursive value lookup failed. ~a ~a" recursive-values v))) typed-side)] + [(VectorTop:) (only-untyped vector?/sc)] + [(BoxTop:) (only-untyped box?/sc)] + [(ChannelTop:) (only-untyped channel?/sc)] + [(HashtableTop:) (only-untyped hash?/sc)] + [(MPairTop:) (only-untyped mpair?/sc)] + [(ThreadCellTop:) (only-untyped thread-cell?/sc)] + [(Prompt-TagTop:) (only-untyped prompt-tag?/sc)] + [(Continuation-Mark-KeyTop:) (only-untyped continuation-mark-key?/sc)] + ;; TODO Figure out how this should work + ;[(StructTop: s) (struct-top/sc s)] + + [(Poly: vs b) (if (not (from-untyped? typed-side)) ;; in positive position, no checking needed for the variables diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt index fcef3a14..12f0deea 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt @@ -5,7 +5,7 @@ ;; Ex: (listof/sc any/sc) => list?/sc (require "simple.rkt" "structural.rkt" - (for-template racket/base racket/list racket/set racket/promise)) + (for-template racket/base racket/list racket/set racket/promise racket/mpair)) (provide (all-defined-out)) (define identifier?/sc (flat/sc #'identifier?)) @@ -16,6 +16,8 @@ (define cons?/sc (flat/sc #'cons?)) (define list?/sc (flat/sc #'list?)) +(define mpair?/sc (flat/sc #'mpair?)) + (define set?/sc (flat/sc #'set?)) (define empty-set/sc (and/sc set?/sc (flat/sc #'set-empty?))) @@ -23,3 +25,8 @@ (define hash?/sc (flat/sc #'hash?)) (define empty-hash/sc (and/sc hash?/sc (flat/sc #'(λ (h) (zero? (hash-count h)))))) + +(define channel?/sc (flat/sc #'channel?)) +(define thread-cell?/sc (flat/sc #'thread-cell?)) +(define prompt-tag?/sc (flat/sc #'continuation-prompt-tag?)) +(define continuation-mark-key?/sc (flat/sc #'continuation-mark-key?)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/make-top-predicate.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/make-top-predicate.rkt new file mode 100644 index 00000000..c0750844 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/make-top-predicate.rkt @@ -0,0 +1,13 @@ +#lang typed/racket + +(make-predicate VectorTop) +(make-predicate BoxTop) +(make-predicate ChannelTop) +(make-predicate HashTableTop) +(make-predicate MPairTop) +(make-predicate Thread-CellTop) +(make-predicate Prompt-TagTop) +(make-predicate Continuation-Mark-KeyTop) + + +