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

Add a bunch of tests for contract creation error messages.

Browse Source 
Also minor fixes to said error messages.
This commit is contained in:
Eric Dobson 2013-12-15 16:49:25 -08:00
parent 09e28b272c
commit 7060bdd0f8
2 changed files with 88 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -89,7 +89,7 @@
cnt
#,(contract-kind->keyword kind)))))))]
[_ (int-err "should never happen - not a define-values: ~a"
(syntax->datum stx))]))
(syntax->datum stx))]))
(define (change-contract-fixups forms)
(for/list ((e (in-syntax forms)))
@ -237,16 +237,16 @@
(map t->c rngs)
(and rst (t->c/neg rst))))]
;; functions with filters or objects
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws)
(if (not (from-untyped? typed-side))
(values (map t->c/neg dom)
null
(map t->c rngs)
(and rst (t->c/neg rst)))
(let-values ([(mand-kws opt-kws) (partition-kws kws)])
(values (append (map t->c/neg dom) (append-map conv mand-kws))
(append-map conv opt-kws)
(map t->c rngs)
(and rst (t->c/neg rst))))
(exit (fail #:reason
(~a "cannot generate contract for function type"
" with filters or objects."))))]
[_ (exit (fail))]))
" with filters or objects."))))]))
(with-syntax*
([(dom* ...) (process-dom dom*)]
[(opt-dom* ...) opt-dom*]
@ -255,7 +255,9 @@
[(rst-spec ...) (if rst #'(#:rest (listof rst*)) #'())])
;; Garr, I hate case->!
(if (and (pair? (syntax-e #'(opt-dom* ...))) case->)
(exit (fail))
(exit (fail #:reason
(~a "cannot generate contract for case function type"
" with optional keyword arguments")))
(if (or rst (pair? (syntax-e #'(opt-dom* ...))))
(if case->
#'(dom* ... rst-spec ... . -> . rng*)
@ -483,16 +485,15 @@
#`(syntax/c #,(t->c t #:kind flat-sym))]
[(Value: v) #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v)))]
;; TODO Is this sound?
[(Param: in out)
(set-impersonator!)
#`(parameter/c #,(t->c in) #,(t->c out))]
[(Param: in out)
(set-impersonator!)
#`(parameter/c #,(t->c in) #,(t->c out))]
[(Hashtable: k v)
(when (equal? kind flat-sym) (exit (fail)))
(when (equal? kind flat-sym)
(exit (fail #:reason (~a "expected a first-order contract, but got a hashtable."))))
#`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)]
[(Channel: t)
(set-chaperone!)
#`(channel/c #,(t->c/both t))]
[else
(exit (fail #:reason "contract generation not supported for this type"))]))))

90
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
View File

@ -4,38 +4,92 @@
(for-syntax scheme/base)
(for-template scheme/base)
(private type-contract)
(types abbrev numeric-tower)
(rep type-rep)
(types abbrev numeric-tower union)
rackunit)
(define-syntax-rule (t e)
(test-not-exn
(format "~a" e)
(λ ()
(type->contract
e
(λ (#:reason [reason #f])
(error "type could not be converted to contract"))))))
(define-syntax-rule (t/fail e)
(test-not-exn
(format "~a" e)
(λ ()
(let/ec exit
(type->contract e (λ (#:reason [reason #f]) (exit #t)))
(error "type could be converted to contract")))))
(define-syntax-rule (t e)
(test-case (format "~a" 'e)
(let ((v e))
(with-check-info (('type v))
(type->contract
e
(λ (#:reason [reason #f])
(fail-check (or reason "Type could not be converted to contract"))))))))
(define-syntax-rule (t/fail e expected-reason)
(test-case (format "~a" 'e)
(let ((v e))
(with-check-info (('expected expected-reason)
('type v))
(define reason
(let/ec exit
(type->contract v (λ (#:reason [reason #f]) (exit reason)))
(fail-check "type could be converted to contract")))
(unless (regexp-match? expected-reason reason)
(with-check-info (('reason reason))
(fail-check "Reason didn't match expected.")))))))
(define known-bugs
(test-suite "Known Bugs"
;; This should fail as case-> doesn't support keyword arguments.
(t
(make-Function
(list
(make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t)))
(make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t))))))
;; Polydotted functions should work
(t/fail (-polydots (a) (->... (list) (a a) -Symbol))
"not supported for this type")))
(define (contract-tests)
(test-suite "Contract Tests"
known-bugs
(t (-Number . -> . -Number))
(t (-Promise -Number))
(t (-set Univ))
(t (-> Univ -Boolean : -Symbol))
(t (->key -Symbol #:key -Boolean #t Univ))
(t (make-Function
(list (make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key Univ #t))
#:filters -Symbol))))
(t (-struct #'struct-name #f (list (make-fld -Symbol #'acc #f))))
;; Adapted from PR 13815
(t (-poly (a) (-> a a)))
(t (-poly (a) (-mu X (-> a X))))
(t (-poly (a) (-poly (b) (-> a a))))
(t (-poly (a) (-App (-poly (b) (-> a a)) (list -Number) #'#f)))
(t/fail (-poly (a) -Flonum))
(t/fail (-poly (a) (-set -Number)))))
(t/fail
(make-Function
(list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))
(make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #f)))))
"case function type with optional keyword arguments")
(t/fail (-poly (a) -Flonum) "non-function polymorphic type")
(t/fail (-> (-> Univ -Boolean : -Symbol) -Symbol)
"function type with filters or objects")
(t/fail (-poly (a) (-set -Number)) "non-function polymorphic type")
(t/fail (cl->*
(-> -Boolean -Boolean)
(-> -Symbol -Symbol))
"two cases of arity 1")
(t/fail (-Syntax (-HT -Symbol -Symbol))
"first-order contract, but got a hashtable.")
(t/fail (-Syntax (-struct #'struct-name #f (list (make-fld -Symbol #'acc #t))))
"first-order contract, .* struct with at least one mutable field")
(t/fail (-struct #'struct-name #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol))
"procedural structs are not supported")
(t/fail (-Syntax (-> -Boolean -Boolean))
#rx"required a first-order .* generate a higher-order")
(t/fail (-set (-Param -Boolean -Boolean))
#rx"required a chaperone or flat contract .* generate an impersonator")
(t/fail (-poly (a b) (-> (Un a b) (Un a b)))
"multiple distinct type variables")
))
(define-go contract-tests)
(provide contract-tests)