From aac25b42c92ccdcff8e36d89bf33b81dd9f6331a Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 17 Jan 2013 23:52:37 -0800 Subject: [PATCH] Make AnyValues but don't actually start using it yet. --- .../unit-tests/special-env-typecheck-tests.rkt | 2 +- .../typed-racket/unit-tests/typecheck-tests.rkt | 2 ++ collects/typed-racket/base-env/base-env.rkt | 2 +- collects/typed-racket/rep/type-rep.rkt | 16 ++++++++++++---- .../typed-racket/typecheck/tc-app-helper.rkt | 2 +- .../typecheck/tc-app/tc-app-apply.rkt | 5 +++-- .../typed-racket/typecheck/tc-metafunctions.rkt | 2 +- collects/typed-racket/types/abbrev.rkt | 8 ++++---- collects/typed-racket/types/printer.rkt | 5 ++++- collects/typed-racket/types/subtype.rkt | 5 +++-- 10 files changed, 32 insertions(+), 17 deletions(-) diff --git a/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt index 37904f64ac..dbc88f0286 100644 --- a/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt @@ -97,7 +97,7 @@ (tc-e (make-handle-get-preference-locked .3 'sym (lambda () 'eseh) 'timestamp #f #:lock-there #f #:max-delay .45) - (t:-> -Pathlike ManyUniv)) + (t:-> -Pathlike Univ)) (tc-e (call-with-file-lock/timeout #f 'exclusive (lambda () 'res) (lambda () 'err) #:lock-file "lock" diff --git a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt index d73eea1035..37d9c30d27 100644 --- a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -1388,6 +1388,8 @@ ;Wills (tc-e (make-will-executor) -Will-Executor) + ;; FIXME: Broken because ManyUniv doesn't have a corresponding tc-result + #; (tc-e (let: ((w : Will-Executor (make-will-executor))) (will-register w 'a (lambda: ((s : Symbol)) (void))) (will-execute w)) ManyUniv) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 3b67946438..70a2aea063 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -1970,7 +1970,7 @@ [make-security-guard (->opt -Security-Guard (-> Sym (-opt -Path) (-lst Sym) ManyUniv) - (-> Sym (-opt -String) (-opt -PosInt) (Un (one-of/c 'server 'client) ManyUniv)) + (-> Sym (-opt -String) (-opt -PosInt) (one-of/c 'server 'client) ManyUniv) [(-opt (-> Sym -Path -Path ManyUniv))] -Security-Guard)] [current-security-guard (-Param -Security-Guard -Security-Guard)] diff --git a/collects/typed-racket/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt index fec7c85deb..5fdfeb69c0 100644 --- a/collects/typed-racket/rep/type-rep.rkt +++ b/collects/typed-racket/rep/type-rep.rkt @@ -23,19 +23,24 @@ (not (fld? e)) (not (Values? e)) (not (ValuesDots? e)) + (not (AnyValues? e)) (not (Result? e))))) ;; (or/c Type/c Values? Results?) +;; Anything that can be treated as a Values by sufficient expansion (define Values/c? (λ (e) (and (Type? e) (not (Scope? e)) (not (arr? e)) (not (fld? e)) - (not (ValuesDots? e))))) + (not (ValuesDots? e)) + (not (AnyValues? e))))) + (define Type/c (flat-named-contract 'Type Type/c?)) (define Values/c (flat-named-contract 'Values Values/c?)) +(define SomeValues/c (or/c Values? AnyValues? ValuesDots?)) ;; Name = Symbol @@ -222,6 +227,10 @@ [#:frees (λ (f) (combine-frees (map f rs)))] [#:fold-rhs (*Values (map type-rec-id rs))]) + +(def-type AnyValues () + [#:fold-rhs #:base]) + (def-type ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)]) [#:frees (if (symbol? dbound) (free-vars-remove (combine-frees (map free-vars* (cons dty rs))) dbound) @@ -234,7 +243,7 @@ ;; arr is NOT a Type (def-type arr ([dom (listof Type/c)] - [rng (or/c Values? ValuesDots?)] + [rng SomeValues/c] [rest (or/c #f Type/c)] [drest (or/c #f (cons/c Type/c (or/c natural-number/c symbol?)))] [kws (listof Keyword?)]) @@ -770,14 +779,13 @@ Mu? Poly? PolyDots? Filter? Object? Type/c Type/c? - Values/c + Values/c SomeValues/c Poly-n PolyDots-n free-vars* type-compare type string? string?)) . c:->* . tc-results?) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt index 1ec40a8bb6..e07744550b 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt @@ -5,7 +5,7 @@ "utils.rkt" syntax/parse racket/match syntax/parse/experimental/reflect - (typecheck signatures tc-funapp check-below tc-subst) + (typecheck signatures tc-funapp check-below) (types abbrev utils) (rep type-rep) @@ -24,7 +24,8 @@ #:literals (k:apply apply values) (pattern ((~or apply k:apply) values e) (match (single-value #'e) - [(tc-result1: (ListDots: dty dbound)) (values->tc-results (make-ValuesDots null dty dbound) #f)] + [(tc-result1: (ListDots: dty dbound)) + (ret null null null dty dbound)] [(tc-result1: (List: ts)) (ret ts)] [_ (tc/apply #'values #'(e))])) (pattern ((~or apply k:apply) f . args) diff --git a/collects/typed-racket/typecheck/tc-metafunctions.rkt b/collects/typed-racket/typecheck/tc-metafunctions.rkt index a43aa2725f..d75cea7e22 100644 --- a/collects/typed-racket/typecheck/tc-metafunctions.rkt +++ b/collects/typed-racket/typecheck/tc-metafunctions.rkt @@ -13,7 +13,7 @@ (define/cond-contract (abstract-results results arg-names) - (tc-results? (listof identifier?) . -> . (or/c Values? ValuesDots?)) + (tc-results? (listof identifier?) . -> . SomeValues/c) (define keys (for/list ([(nm k) (in-indexed arg-names)]) k)) (match results [(tc-results: ts fs os dty dbound) diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index 1944f97772..2bb2bd3838 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -329,16 +329,16 @@ (define/cond-contract (make-arr* dom rng #:rest [rest #f] #:drest [drest #f] #:kws [kws null] #:filters [filters -no-filter] #:object [obj -no-obj]) - (c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c)) + (c:->* ((listof Type/c) (or/c SomeValues/c Type/c)) (#:rest (or/c #f Type/c) #:drest (or/c #f (cons/c Type/c symbol?)) #:kws (listof Keyword?) #:filters FilterSet? #:object Object?) arr?) - (make-arr dom (if (or (Values? rng) (ValuesDots? rng)) - rng - (make-Values (list (-result rng filters obj)))) + (make-arr dom (if (Type/c? rng) + (make-Values (list (-result rng filters obj))) + rng) rest drest (sort #:key Keyword-kw kws keyword* stx) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index b34feb2e3b..7dcaa04d8e 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -165,6 +165,8 @@ (fp "~a ...~a~a " (car drest) (if (special-dots-printing?) "" " ") (cdr drest))) (match rng + [(AnyValues:) + (fp "-> AnyValues")] [(Values: (list (Result: t (FilterSet: (Top:) (Top:)) (Empty:)))) (fp "-> ~a" t)] [(Values: (list (Result: t @@ -272,7 +274,8 @@ [(ListDots: dty dbound) (fp "(List ~a ...~a~a)" dty (if (special-dots-printing?) "" " ") dbound)] [(F: nm) (fp "~a" nm)] - ;; FIXME + ;; FIXME (Values are not types and shouldn't need to be considered here + [(AnyValues:) (fp "AnyValues")] [(Values: (list v)) (fp "~a" v)] [(Values: (list v ...)) (fp "~s" (cons 'values v))] [(ValuesDots: v dty dbound) diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index d7c7ffb4f0..7885c91c5f 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -48,7 +48,7 @@ ;; is s a subtype of t? ;; type type -> boolean (define/cond-contract (subtype s t) - (c:-> (c:or/c Type/c Values?) (c:or/c Type/c Values?) boolean?) + (c:-> (c:or/c Type/c SomeValues/c) (c:or/c Type/c SomeValues/c) boolean?) (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))) @@ -431,6 +431,7 @@ (subtype* A0 parent other)] ;; subtyping on values is pointwise [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] + [((or (Values: _) (AnyValues:)) (AnyValues:)) A0] ;; trivial case for Result [((Result: t f o) (Result: t* f o)) (subtype* A0 t t*)] @@ -458,7 +459,7 @@ (provide/cond-contract - [subtype (c:-> (c:or/c Type/c Values?) (c:or/c Type/c Values?) boolean?)]) + [subtype (c:-> (c:or/c Type/c SomeValues/c) (c:or/c Type/c SomeValues/c) boolean?)]) (provide type-compare? subtypes/varargs subtypes)