Cleanup tc-app-helper.rkt.

original commit: 62f74cda0e559ac322236f63a32c5b344dbd9181
This commit is contained in:
Eric Dobson 2013-02-05 21:35:07 -08:00
parent d66ef4fb11
commit c07428390d
2 changed files with 32 additions and 21 deletions

View File

@ -1,20 +1,21 @@
#lang racket/base
(require "../utils/utils.rkt" racket/match unstable/list unstable/sequence
syntax/parse
racket/set
(require "../utils/utils.rkt"
racket/match unstable/list unstable/sequence racket/set syntax/parse
(only-in srfi/1 unzip4) (only-in racket/list make-list)
(prefix-in c: racket/contract)
"check-below.rkt" "tc-subst.rkt"
(contract-req)
(typecheck check-below tc-subst)
(utils tc-utils)
(rep type-rep object-rep)
(types utils union abbrev subtype))
(except-in (types utils union abbrev subtype)
-> ->* one-of/c))
(provide (all-defined-out))
;; syntax? syntax? arr? (listof tc-results/c) (or/c #f tc-results/c) [boolean?] -> tc-results/c
(define/cond-contract (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
((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)
(provide/cond-contract
[tc/funapp1
((syntax? (and/c syntax? syntax->list) arr? (listof tc-results/c) (or/c #f tc-results/c))
(#:check boolean?)
. ->* . tc-results/c)])
(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
(match* (ftype0 argtys)
;; we check that all kw args are optional
[((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)])))
;; 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
#:expected [expected #f] #:return [return -Bottom]
#:msg-thunk [msg-thunk (lambda (dom) dom)])
((syntax? syntax? Type/c (c:listof (c:listof Type/c)) (c:listof (c:or/c #f Type/c))
(c:listof (c:or/c #f (c:cons/c Type/c (c:or/c c:natural-number/c symbol?))))
(c:listof SomeValues/c) (c:listof tc-results?) (c:or/c #f Type/c) c:any/c)
(#:expected (c:or/c #f tc-results/c) #:return tc-results?
#:msg-thunk (c:-> string? string?))
. c:->* . tc-results/c)
(provide/cond-contract
[domain-mismatches
((syntax? syntax? Type/c (listof (listof Type/c)) (listof (or/c #f Type/c))
(listof (or/c #f (cons/c Type/c (or/c natural-number/c symbol?))))
(listof SomeValues/c) (listof tc-results?) (or/c #f Type/c) any/c)
(#:expected (or/c #f tc-results/c)
#:return tc-results?
#:msg-thunk (-> string? string?))
. ->* . 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
(stringify-domain arg-tys
@ -297,6 +301,8 @@
list)))))))))
;; 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])
(match t
;; function type, prune if possible.
@ -308,6 +314,11 @@
;; not a function type. keep as is.
[_ 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])
(match t
[(or (Poly-names:

View File

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