fix contract related bugs

typed-racket-lib/typed-racket/typecheck/tc-structs.rkt

@@ -6,10 +6,10 @@
          (prefix-in c: (contract-req))
          (rep type-rep object-rep free-variance)
          (private parse-type syntax-properties)
-         (types abbrev utils resolve substitute struct-table prefab)
+         (types abbrev subtype utils resolve substitute struct-table prefab)
          (env global-env type-name-env type-alias-env tvar-env)
          (utils tc-utils)
-         (typecheck def-binding internal-forms check-below)
+         (typecheck def-binding internal-forms error-message)
          (for-syntax syntax/parse racket/base))
 
 (require-for-cond-contract racket/struct-info)
@@ -315,27 +315,31 @@
          (parsed-struct (make-Prefab key (append parent-fields types))
                         names desc (struct-info-property nm/par) #f)]
         [else
-	 (define maybe-parsed-proc-ty
-	   (and proc-ty (parse-type proc-ty)))
-	 ;; ensure that the prop:procedure argument is really a procedure
-	 (when maybe-parsed-proc-ty
-	   (check-below maybe-parsed-proc-ty top-func))
-
+         (define maybe-proc-ty
+           (let ([maybe-parsed-proc-ty (and proc-ty (parse-type proc-ty))])
+             (and maybe-parsed-proc-ty
+                  (cond
+                    ;; ensure that the prop:procedure argument is really a procedure
+                    [(subtype maybe-parsed-proc-ty top-func)
+                     maybe-parsed-proc-ty]
+                    [else (expected-but-got top-func maybe-parsed-proc-ty)
+                          #f]))))
+         
          (define parent-mutable
            ;; Only valid as long as typed structs must be
            ;; either fully mutable or fully immutable
            (or (not parent)
                (andmap fld-mutable? (get-flds concrete-parent))))
-
+         
          (define desc (struct-desc
-                        (map fld-t (get-flds concrete-parent))
-                        types
-                        tvars
-                        mutable
-                        parent-mutable
-			maybe-parsed-proc-ty))
+                       (map fld-t (get-flds concrete-parent))
+                       types
+                       tvars
+                       mutable
+                       parent-mutable
+                       maybe-proc-ty))
          (define sty (mk/inner-struct-type names desc concrete-parent))
-
+         
          (parsed-struct sty names desc (struct-info-property nm/par) type-only)]))
 
 ;; register a struct type

typed-racket-lib/typed-racket/types/overlap.rkt

@@ -2,6 +2,7 @@
 
 (require "../utils/utils.rkt"
          (rep type-rep rep-utils)
+         (prefix-in c: (contract-req))
          (types abbrev subtype resolve utils)
          racket/match racket/set)
 
@@ -25,7 +26,7 @@
 ;; a conservative check to see if two types
 ;; have a non-empty intersection
 (define/cond-contract (overlap? t1 t2)
-  (-> Type/c Type/c boolean?)
+  (c:-> Type/c Type/c boolean?)
   (define k1 (Type-key t1))
   (define k2 (Type-key t2))
   (cond

typed-racket-lib/typed-racket/types/update.rkt

@@ -6,7 +6,11 @@
          (infer-in infer)
          (rep type-rep prop-rep object-rep rep-utils)
          (utils tc-utils)
-         (types abbrev resolve subtype remove union))
+         (types resolve subtype remove union)
+         (rename-in (types abbrev)
+                    [-> -->]
+                    [->* -->*]
+                    [one-of/c -one-of/c]))
 
 
 (provide update)