suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge open-Values and values->tc-results.

Browse Source 
original commit: 577b00a170434316567372564f2e096cdfb063dd
This commit is contained in:
Eric Dobson 2014-05-29 20:51:39 -07:00
parent b9b038bfb9
commit 5080fd5bee
4 changed files with 37 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -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: _ _ _ _

16
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -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

29
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
View File

@ -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))]))

50
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt
View File

@ -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))