Add a bunch of tests for contract creation error messages.

Also minor fixes to said error messages.

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt

@@ -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)
+                        (let-values ([(mand-kws opt-kws) (partition-kws kws)])
-                                null
+                          (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)))
+                                  (and rst (t->c/neg rst))))
                         (exit (fail #:reason
                                     (~a "cannot generate contract for function type"
-                                        " with filters or objects."))))]
+                                        " with filters or objects."))))]))
-                   [_ (exit (fail))]))
                (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*)
@@ -487,12 +489,11 @@
          (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"))]))))
-
-

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt

@@ -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
+  (test-case (format "~a" 'e)
-   (format "~a" e)
+    (let ((v e))
-   (λ ()
+      (with-check-info (('type v))
         (type->contract
           e
           (λ (#:reason [reason #f])
-        (error "type could not be converted to contract"))))))
+            (fail-check (or reason "Type could not be converted to contract"))))))))
 
-(define-syntax-rule (t/fail e)
+(define-syntax-rule (t/fail e expected-reason)
-  (test-not-exn
+  (test-case (format "~a" 'e)
-   (format "~a" e)
+   (let ((v e))
-   (λ ()
+     (with-check-info (('expected expected-reason)
+                       ('type v))
+       (define reason
          (let/ec exit
-       (type->contract e (λ (#:reason [reason #f]) (exit #t)))
+           (type->contract v (λ (#:reason [reason #f]) (exit reason)))
-       (error "type could be converted to contract")))))
+           (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
-              (t/fail (-poly (a) (-set -Number)))))
+                (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)