From 5080fd5bee742f5fe96bb0328d88d178533006f7 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 29 May 2014 20:51:39 -0700 Subject: [PATCH] Merge open-Values and values->tc-results. original commit: 577b00a170434316567372564f2e096cdfb063dd --- .../typed-racket/typecheck/tc-app-helper.rkt | 2 +- .../typed-racket/typecheck/tc-lambda-unit.rkt | 16 +++--- .../typed-racket/typecheck/tc-subst.rkt | 29 ++--------- .../unit-tests/metafunction-tests.rkt | 50 +++++++++---------- 4 files changed, 37 insertions(+), 60 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt index 657be1e3..e3d9a91f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt @@ -49,7 +49,7 @@ [oa (in-sequence-forever (in-list o-a) -empty-obj)] [ta (in-sequence-forever (in-list t-a) Univ)]) (values oa ta))]) - (open-Values rng o-a t-a)))] + (values->tc-results rng o-a t-a)))] ;; this case should only match if the function type has mandatory keywords ;; but no keywords were provided in the application [((arr: _ _ _ _ diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt index ad40c42e..9bdaf820 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt @@ -4,7 +4,7 @@ racket/dict racket/list syntax/parse racket/syntax syntax/stx racket/match syntax/id-table racket/set (contract-req) - (rep type-rep) + (rep type-rep object-rep) (rename-in (types abbrev utils union) [-> t:->] [->* t:->*] @@ -256,12 +256,12 @@ [(null? (syntax-e s)) (formals (reverse acc) #f stx)] [else (formals (reverse acc) s stx)]))) -(define (formals->list formals) - (append - (formals-positional formals) - (if (formals-rest formals) - (list (formals-rest formals)) - empty))) +(define (formals->objects formals) + (for/list ([i (in-list (append (formals-positional formals) + (if (formals-rest formals) + (list (formals-rest formals)) + empty)))]) + (make-Path null i))) ;; An arity is a list (List Natural Boolean), with the number of positional @@ -370,7 +370,7 @@ [(list (arr: argss rets rests drests '()) ...) (for/list ([args (in-list argss)] [ret (in-list rets)] [rest (in-list rests)] [drest (in-list drests)]) (tc/lambda-clause/check - f* b* args (values->tc-results ret (formals->list f*)) rest drest))]))))) + f* b* args (values->tc-results ret (formals->objects f*)) rest drest))]))))) (define (tc/mono-lambda/type formals bodies expected) (make-Function (map lam-result->type diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt index 0338f61d..04deadaa 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt @@ -9,13 +9,13 @@ (except-in (types abbrev utils filter-ops) -> ->* one-of/c) (rep type-rep object-rep filter-rep rep-utils)) -(provide add-scope values->tc-results) +(provide add-scope) (provide/cond-contract - [open-Values (-> SomeValues/c (listof Object?) (listof Type/c) -> full-tc-results/c)] + [values->tc-results (->* (SomeValues/c (listof Object?)) ((listof Type/c)) full-tc-results/c)] [replace-names (-> (listof (list/c identifier? Object?)) tc-results/c tc-results/c)]) -(define (open-Values v os ts) +(define (values->tc-results v os [ts (map (λ (o) Univ) os)]) (match v [(AnyValues: f) (tc-any-results (open-Filter f os))] @@ -217,26 +217,3 @@ (make-arr* null Univ))])) (for-type type) #f)) - -;; Convert a Values to a corresponding tc-results -(define/cond-contract (values->tc-results tc formals) - (SomeValues/c (listof identifier?) . -> . tc-results/c) - (match tc - [(AnyValues: f) (tc-any-results f)] - [(ValuesDots: (list (and rs (Result: ts fs os)) ...) dty dbound) - (let-values ([(ts fs os) - (for/lists (ts fs os) ([r (in-list rs)]) - (open-Result r (map (lambda (i) (make-Path null i)) - formals)))]) - (ret ts fs os - (for/fold ([dty dty]) ([(o idx) (in-indexed (in-list formals))]) - (define key (list 0 idx)) - (subst-type dty key (make-Path null o) #t)) - dbound))] - [(Values: (list (and rs (Result: ts fs os)) ...)) - (let-values ([(ts fs os) - (for/lists (ts fs os) ([r (in-list rs)]) - (open-Result r (map (lambda (i) (make-Path null i)) - formals)))]) - (ret ts fs os))])) - diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt index c03ea76b..2bd9b58b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt @@ -72,76 +72,76 @@ ) - (test-suite "open-Values" + (test-suite "values->tc-results" (check-equal? - (open-Values (make-Values (list (-result -Symbol))) (list -empty-obj) (list Univ)) + (values->tc-results (make-Values (list (-result -Symbol))) (list -empty-obj) (list Univ)) (ret -Symbol)) (check-equal? - (open-Values (make-Values (list (-result -Symbol) (-result -String))) - (list -empty-obj -empty-obj) (list Univ Univ)) + (values->tc-results (make-Values (list (-result -Symbol) (-result -String))) + (list -empty-obj -empty-obj) (list Univ Univ)) (ret (list -Symbol -String))) (check-equal? - (open-Values (make-Values (list (-result -Symbol (-FS -top -bot)))) (list -empty-obj) (list Univ)) + (values->tc-results (make-Values (list (-result -Symbol (-FS -top -bot)))) (list -empty-obj) (list Univ)) (ret -Symbol (-FS -top -bot))) (check-equal? - (open-Values (make-Values (list (-result -Symbol (-FS -top -bot) (make-Path null '(0 0))))) - (list -empty-obj) (list Univ)) + (values->tc-results (make-Values (list (-result -Symbol (-FS -top -bot) (make-Path null '(0 0))))) + (list -empty-obj) (list Univ)) (ret -Symbol (-FS -top -bot))) (check-equal? - (open-Values (make-Values (list (-result (-opt -Symbol) (-FS (-filter -String '(0 0)) -top)))) - (list -empty-obj) (list Univ)) + (values->tc-results (make-Values (list (-result (-opt -Symbol) (-FS (-filter -String '(0 0)) -top)))) + (list -empty-obj) (list Univ)) (ret (-opt -Symbol) -top-filter)) (check-equal? - (open-Values (make-Values (list (-result (-opt -Symbol) (-FS (-not-filter -String '(0 0)) -top)))) - (list -empty-obj) (list Univ)) + (values->tc-results (make-Values (list (-result (-opt -Symbol) (-FS (-not-filter -String '(0 0)) -top)))) + (list -empty-obj) (list Univ)) (ret (-opt -Symbol) -top-filter)) (check-equal? - (open-Values (make-Values (list (-result (-opt -Symbol) (-FS (-imp (-not-filter (-val #f) '(0 0)) + (values->tc-results (make-Values (list (-result (-opt -Symbol) (-FS (-imp (-not-filter (-val #f) '(0 0)) (-not-filter -String #'x)) -top)))) - (list -empty-obj) (list Univ)) + (list -empty-obj) (list Univ)) (ret (-opt -Symbol) -top-filter)) (check-equal? - (open-Values (make-Values (list (-result (-opt -Symbol) (-FS (-not-filter -String '(0 0)) -top) + (values->tc-results (make-Values (list (-result (-opt -Symbol) (-FS (-not-filter -String '(0 0)) -top) (make-Path null '(0 0))))) - (list (make-Path null #'x)) (list Univ)) + (list (make-Path null #'x)) (list Univ)) (ret (-opt -Symbol) (-FS (-not-filter -String #'x) -top) (make-Path null #'x))) ;; Check additional filters (check-equal? - (open-Values (make-Values (list (-result (-opt -Symbol) (-FS (-not-filter -String '(0 0)) -top) + (values->tc-results (make-Values (list (-result (-opt -Symbol) (-FS (-not-filter -String '(0 0)) -top) (make-Path null '(0 0))))) - (list (make-Path null #'x)) (list -String)) + (list (make-Path null #'x)) (list -String)) (ret (-opt -Symbol) -false-filter (make-Path null #'x))) ;; Substitute into ranges correctly (check-equal? - (open-Values (make-Values (list (-result (-opt (-> Univ -Boolean : (-FS (-filter -Symbol '(0 0)) -top)))))) - (list (make-Path null #'x)) (list Univ)) + (values->tc-results (make-Values (list (-result (-opt (-> Univ -Boolean : (-FS (-filter -Symbol '(0 0)) -top)))))) + (list (make-Path null #'x)) (list Univ)) (ret (-opt (-> Univ -Boolean : (-FS (-filter -Symbol '(0 0)) -top))))) (check-equal? - (open-Values (make-Values (list (-result (-opt (-> Univ -Boolean : (-FS (-filter -Symbol '(1 0)) -top)))))) - (list (make-Path null #'x)) (list Univ)) + (values->tc-results (make-Values (list (-result (-opt (-> Univ -Boolean : (-FS (-filter -Symbol '(1 0)) -top)))))) + (list (make-Path null #'x)) (list Univ)) (ret (-opt (-> Univ -Boolean : (-FS (-filter -Symbol #'x) -top))))) ;; Substitute into filter of any values (check-equal? - (open-Values (make-AnyValues (-filter -String '(0 0))) - (list (make-Path null #'x)) (list Univ)) + (values->tc-results (make-AnyValues (-filter -String '(0 0))) + (list (make-Path null #'x)) (list Univ)) (tc-any-results (-filter -String #'x))) (check-equal? - (open-Values (-values-dots null (-> Univ -Boolean : (-FS (-filter -String '(1 0)) -top)) 'b) - (list (make-Path null #'x)) (list Univ)) + (values->tc-results (-values-dots null (-> Univ -Boolean : (-FS (-filter -String '(1 0)) -top)) 'b) + (list (make-Path null #'x)) (list Univ)) (ret null null null (-> Univ -Boolean : (-FS (-filter -String #'x) -top)) 'b))