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

Cleanup tc-app-helper.rkt.

Browse Source
This commit is contained in:
Eric Dobson 2013-02-05 21:35:07 -08:00
parent 11bd5314e2
commit 62f74cda0e
2 changed files with 32 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -1,20 +1,21 @@
#lang racket/base #lang racket/base
(require "../utils/utils.rkt" racket/match unstable/list unstable/sequence (require "../utils/utils.rkt"
syntax/parse racket/match unstable/list unstable/sequence racket/set syntax/parse
racket/set
(only-in srfi/1 unzip4) (only-in racket/list make-list) (only-in srfi/1 unzip4) (only-in racket/list make-list)
(prefix-in c: racket/contract) (contract-req)
"check-below.rkt" "tc-subst.rkt" (typecheck check-below tc-subst)
(utils tc-utils) (utils tc-utils)
(rep type-rep object-rep) (rep type-rep object-rep)
(types utils union abbrev subtype)) (except-in (types utils union abbrev subtype)
-> ->* one-of/c))
(provide (all-defined-out)) (provide/cond-contract
[tc/funapp1
;; syntax? syntax? arr? (listof tc-results/c) (or/c #f tc-results/c) [boolean?] -> tc-results/c ((syntax? (and/c syntax? syntax->list) arr? (listof tc-results/c) (or/c #f tc-results/c))
(define/cond-contract (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) (#:check boolean?)
((syntax? (c:and/c syntax? syntax->list) arr? (c:listof tc-results/c) (c:or/c #f tc-results/c)) (#:check boolean?) . c:->* . tc-results/c) . ->* . tc-results/c)])
(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
(match* (ftype0 argtys) (match* (ftype0 argtys)
;; we check that all kw args are optional ;; we check that all kw args are optional
[((arr: dom (and rng (or (AnyValues:) (Values: _))) rest #f (and kws (list (Keyword: _ _ #f) ...))) [((arr: dom (and rng (or (AnyValues:) (Values: _))) rest #f (and kws (list (Keyword: _ _ #f) ...)))
@ -86,15 +87,18 @@
[else (string-append (stringify (map make-printable dom)) rng-string)]))) [else (string-append (stringify (map make-printable dom)) rng-string)])))
;; Generates error messages when operand types don't match operator domains. ;; Generates error messages when operand types don't match operator domains.
(define/cond-contract (domain-mismatches f-stx args-stx ty doms rests drests rngs arg-tys tail-ty tail-bound (provide/cond-contract
#:expected [expected #f] #:return [return -Bottom] [domain-mismatches
#:msg-thunk [msg-thunk (lambda (dom) dom)]) ((syntax? syntax? Type/c (listof (listof Type/c)) (listof (or/c #f Type/c))
((syntax? syntax? Type/c (c:listof (c:listof Type/c)) (c:listof (c:or/c #f Type/c)) (listof (or/c #f (cons/c Type/c (or/c natural-number/c symbol?))))
(c:listof (c:or/c #f (c:cons/c Type/c (c:or/c c:natural-number/c symbol?)))) (listof SomeValues/c) (listof tc-results?) (or/c #f Type/c) any/c)
(c:listof SomeValues/c) (c:listof tc-results?) (c:or/c #f Type/c) c:any/c) (#:expected (or/c #f tc-results/c)
(#:expected (c:or/c #f tc-results/c) #:return tc-results? #:return tc-results?
#:msg-thunk (c:-> string? string?)) #:msg-thunk (-> string? string?))
. c:->* . tc-results/c) . ->* . tc-results/c)])
(define (domain-mismatches f-stx args-stx ty doms rests drests rngs arg-tys tail-ty tail-bound
#:expected [expected #f] #:return [return -Bottom]
#:msg-thunk [msg-thunk (lambda (dom) dom)])
(define arguments-str (define arguments-str
(stringify-domain arg-tys (stringify-domain arg-tys
@ -297,6 +301,8 @@
list))))))))) list)))))))))
;; Wrapper over possible-domains that works on types. ;; Wrapper over possible-domains that works on types.
(provide/cond-contract
[cleanup-type ((Type/c) ((or/c #f Type/c)) . ->* . Type/c)])
(define (cleanup-type t [expected #f]) (define (cleanup-type t [expected #f])
(match t (match t
;; function type, prune if possible. ;; function type, prune if possible.
@ -308,6 +314,11 @@
;; not a function type. keep as is. ;; not a function type. keep as is.
[_ t])) [_ t]))
(provide/cond-contract
[poly-fail ((syntax? syntax? Type/c (listof tc-results?))
(#:name (or/c #f syntax?)
#:expected (or/c #f tc-results/c))
. ->* . tc-results/c)])
(define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f]) (define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f])
(match t (match t
[(or (Poly-names: [(or (Poly-names:

2
collects/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -5,7 +5,7 @@
"utils.rkt" "utils.rkt"
syntax/parse racket/match syntax/parse racket/match
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(typecheck signatures tc-funapp tc-app-helper tc-subst) (typecheck signatures tc-funapp)
(types utils abbrev) (types utils abbrev)
(rep type-rep filter-rep object-rep rep-utils) (rep type-rep filter-rep object-rep rep-utils)
(for-template racket/base)) (for-template racket/base))