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

Make contracted unit tests pass

Browse Source
This commit is contained in:
Asumu Takikawa 2016-03-31 11:57:54 -04:00
parent 900d2b0be0
commit b869f18f1c
2 changed files with 12 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
typed-racket-lib/typed-racket/typecheck/possible-domains.rkt
View File

@ -5,10 +5,13 @@
racket/list
racket/match
(rep type-rep filter-rep)
(types abbrev subtype tc-result))
(except-in (types abbrev subtype tc-result)
-> ->* one-of/c))
(provide possible-domains
cleanup-type)
(provide possible-domains)
(provide/cond-contract
[cleanup-type ((Type/c) ((or/c #f Type/c) any/c) . ->* . Type/c)])
;; to avoid long and confusing error messages, in the case of functions with
;; multiple similar domains (<, >, +, -, etc.), we show only the domains that
@ -144,8 +147,6 @@
list)]))
;; Wrapper over possible-domains that works on types.
(provide/cond-contract
[cleanup-type ((Type/c) ((or/c #f Type/c) any/c) . ->* . Type/c)])
(define (cleanup-type t [expected #f] [permissive? #t])
(match t
;; function type, prune if possible.

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

@ -75,9 +75,11 @@
(define (make-printable t)
(match t
[(tc-result1: t) (cleanup-type t)]
[(tc-results: ts) (-values (map cleanup-type ts))]
[(or (tc-results: ts)
(tc-results: ts _ _ _ _))
(-values (map cleanup-type ts))]
[(tc-any-results: f) (-AnyValues -top)]
[_ (cleanup-type t)]))
[_ t]))
(define (stringify-domain dom rst drst [rng #f])
(let ([doms-string (if (null? dom) "" (string-append (stringify (map make-printable dom)) " "))]
@ -178,13 +180,12 @@
return]
[else
;; if not, print the message as usual
(define pdoms* (map make-printable pdoms))
(define err-doms
(string-append
label
(stringify (if expected
(map stringify-domain pdoms* rests drests rngs)
(map stringify-domain pdoms* rests drests))
(map stringify-domain pdoms rests drests rngs)
(map stringify-domain pdoms rests drests))
nl+spc)
"\nArguments: "
arguments-str