Merge branch 'master' of github.com:racket/typed-racket into fix-assoc-and-member-types

typed-racket-doc/typed-racket/scribblings/reference/experimental.scrbl

@@ -1,8 +1,13 @@
 #lang scribble/manual
 
-@begin[(require "../utils.rkt")
+@begin[(require "../utils.rkt" scribble/eval)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])))]
 
+@(define the-top-eval (make-base-eval))
+@(define-syntax-rule (ex . args)
+   (examples #:eval the-top-eval . args))
+
+
 @title{Experimental Features}
 
 These features are currently experimental and subject to change.
@@ -15,3 +20,20 @@ predicate @racket[id], which must have been specified with
 @racket[declare-refinement].}
 
 @defform[(define-typed-struct/exec forms ...)]{Defines an executable structure.}
+
+@defform[(define-new-subtype name (constructor t))]{
+Defines a new type @racket[name] that is a subtype of @racket[t].
+The @racket[constructor] is defined as a function that takes a value of type
+@racket[t] and produces a value of the new type @racket[name].
+A @racket[define-new-subtype] definition is only allowed at the top level of a
+file or module.
+@ex[(module m typed/racket
+      (provide Radians radians f)
+      (define-new-subtype Radians (radians Real))
+      (: f : [Radians -> Real])
+      (define (f a)
+        (sin a)))
+    (require 'm)
+    (radians 0)
+    (f (radians 0))]
+}

typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl

@@ -465,25 +465,6 @@ the type:
     (define-type Bar (U Bar False))]
 }
 
-@section{Defining New Subtypes}
-
-@defform[(define-new-subtype name (constructor t))]{
-Defines a new type @racket[name] that is a subtype of @racket[t].
-The @racket[constructor] is defined as a function that takes a value of type
-@racket[t] and produces a value of the new type @racket[name].
-A @racket[define-new-subtype] definition is only allowed at the top level of a
-file or module.
-@ex[(module m typed/racket
-      (provide Radians radians f)
-      (define-new-subtype Radians (radians Real))
-      (: f : [Radians -> Real])
-      (define (f a)
-        (sin a)))
-    (require 'm)
-    (radians 0)
-    (f (radians 0))]
-}
-
 @section{Generating Predicates Automatically}
 
 @defform[(make-predicate t)]{

typed-racket-lib/typed-racket/env/init-envs.rkt

@@ -127,8 +127,9 @@
               (define ty (force (cdr id/ty)))
               `(cons (quote-syntax ,id) ,(sub ty)))
             m))
+     (define serialized-extends (and extends `(quote-syntax ,extends)))
      `(make-Signature (quote-syntax ,name)
-                      (quote-syntax ,extends)
+                      ,serialized-extends
                       (list ,@(serialize-mapping mapping)))]
     [(arr: dom rng rest drest kws)
      `(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]

typed-racket-lib/typed-racket/private/parse-type.rkt

@@ -478,6 +478,11 @@
          (-Param ty ty))]
       [(:Parameter^ t1 t2)
        (-Param (parse-type #'t1) (parse-type #'t2))]
+      [((~and p :Parameter^) args ...)
+       (parse-error
+        #:stx stx
+        (~a (syntax-e #'p) " expects one or two type arguments, given "
+            (sub1 (length (syntax->list #'(args ...))))))]
       ;; curried function notation
       [((~and dom:non-keyword-ty (~not :->^)) ...
         :->^

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

@@ -111,7 +111,7 @@
                     (λ (#:reason [reason #f]) (set! failure-reason reason))))
   (syntax-parse stx
     #:literal-sets (kernel-literals)
-    [(define-values ctc-id _)
+    [(define-values (ctc-id) _)
      ;; no need for ignore, the optimizer doesn't run on this code
      (cond [failure-reason
             #`(define-syntax (#,untyped-id stx)
@@ -122,10 +122,15 @@
                                  "type" #,(pretty-format-type type #:indent 8)))]
            [else
             (match-define (list defs ctc) result)
+            (define maybe-inline-val
+              (should-inline-contract? ctc cache))
             #`(begin #,@defs
-                     (define ctc-id #,ctc)
+                     #,@(if maybe-inline-val
+                            null
+                            (list #`(define-values (ctc-id) #,ctc)))
                      (define-module-boundary-contract #,untyped-id
-                       #,orig-id ctc-id
+                       #,orig-id
+                       #,(or maybe-inline-val #'ctc-id)
                        #:pos-source #,blame-id
                        #:srcloc (vector (quote #,(syntax-source orig-id))
                                         #,(syntax-line orig-id)
@@ -133,6 +138,20 @@
                                         #,(syntax-position orig-id)
                                         #,(syntax-span orig-id))))])]))
 
+;; Syntax (Dict Static-Contract (Cons Id Syntax)) -> (Option Syntax)
+;; A helper for generate-contract-def/provide that helps inline contract
+;; expressions when needed to cooperate with the contract system's optimizations
+(define (should-inline-contract? ctc-stx cache)
+  (and (identifier? ctc-stx)
+       (let ([match? (assoc ctc-stx (hash-values cache) free-identifier=?)])
+         (and match?
+              ;; ->* are handled specially by the contract system
+              (let ([sexp (syntax-e (cdr match?))])
+                (and (pair? sexp)
+                     (or (free-identifier=? (car sexp) #'->)
+                         (free-identifier=? (car sexp) #'->*))))
+              (cdr match?)))))
+
 ;; The below requires are needed since they provide identifiers that
 ;; may appear in the residual program.
 

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

@@ -529,8 +529,8 @@
            ;; indirection here (see the implementation in
            ;; provide-handling.rkt).
            ;;
-           ;; First, we generate a macro that expands to a
-           ;; `local-require` of the contracted identifier in the
+           ;; First, we generate a macro that lifts a
+           ;; `require` of the contracted identifier in the
            ;; #%contract-defs submodule:
            ;;    (define-syntax con-f (mk-redirect f))
            ;;
@@ -542,7 +542,7 @@
            ;; because it's important for `export-f` to be a
            ;; rename-transformer (making things like
            ;; `syntax-local-value` work right), but `con-f` can't be,
-           ;; since it expands to a `local-require`.
+           ;; since it lifts a `require`
            new-export-defs ...
 
            ;; Finally, we do the export:

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

@@ -49,11 +49,16 @@
 ;; Normalizes representation by sorting types.
 ;; Type * -> Type
 ;; The input types can overlap and be union types
+(define Un-cache (make-weak-hash))
 (define Un
   (case-lambda 
     [() -Bottom]
     [(t) t]
     [args 
-     (define ts (foldr merge '()
-                       (remove-dups (sort (append-map flat args) type<?))))
-     (make-union* ts)]))
+     (cond [(hash-ref Un-cache args #f)]
+           [else
+            (define ts (foldr merge '()
+                              (remove-dups (sort (append-map flat args) type<?))))
+            (define type (make-union* ts))
+            (hash-set! Un-cache args type)
+            type])]))

typed-racket-lib/typed-racket/utils/redirect-contract.rkt

@@ -31,9 +31,9 @@
       (with-syntax ([mp (collapse-module-path-index
                          contract-defs-submod-modidx)]
                     [i (datum->syntax id (syntax-e id) stx stx)])
-        #`(let ()
-            (local-require (only-in mp [#,(datum->syntax #'mp (syntax-e #'i)) i]))
-            i))]
+        (syntax-local-lift-require
+         #`(rename mp i #,(datum->syntax #'mp (syntax-e #'i)))
+         #'i))]
      [else
       (datum->syntax stx
                      (cons (redirect (car (syntax-e stx)))

typed-racket-test/succeed/require-signature-all-typed.rkt

@@ -0,0 +1,14 @@
+#lang typed/racket
+
+(module a typed/racket
+  (provide foo^)
+
+  (define-signature foo^
+    ([n : Number])))
+
+(require 'a)
+
+(define-unit foo@
+  (import)
+  (export foo^)
+  (define n 5))

typed-racket-test/unit-tests/interactive-tests.rkt

@@ -111,7 +111,7 @@
                       [#:opaque Evt evt?]
                       [alarm-evt (Real -> Evt)]
                       [sync (Evt -> Any)])
-       evt?))
+       (void evt?)))
 
     ;; PR 14380
     (test-form-not-exn (begin - (void)))