Add types for combinations, in-combinations

The redirection for contracted identifiers used to do a
require lift on each use. Instead, only do the lift once
and reuse the identifier.

.travis.yml

@@ -17,15 +17,16 @@ install:
 - raco pkg config catalogs >> catalog-config.txt
 - raco pkg config --set catalogs `cat catalog-config.txt`
 - raco pkg update -i --no-setup source-syntax/ typed-racket-lib/ typed-racket-more/ typed-racket-compatibility/ typed-racket-doc/ typed-racket/ typed-racket-test/
-- raco setup typed typed-racket typed-racket-test
+- raco setup typed typed-racket typed-racket-test typed-scheme
 
 script:
-- racket -l typed-racket-test/run -- --unit
-- racket -l typed-racket-test/run -- --int
-- racket -l typed-racket-test/run -- --opt
-- racket -l typed-racket-test/run -- --missed-opt
+- racket -l typed-racket-test -- --unit
+- racket -l typed-racket-test -- --int
+- racket -l typed-racket-test -- --opt
+- racket -l typed-racket-test -- --missed-opt
 - raco setup -j 1 math
-- racket -l typed-racket-test/run -- --math
+- racket -l typed-racket-test -- --math
+- racket -l typed-racket-test/test-docs-complete
 - echo "done"
 
 after_script:

issue_template.md

@@ -0,0 +1,7 @@
+### What version of Racket are you using?
+
+### What program did you run?
+
+### What should have happened?
+
+### If you got an error message, please include it here.

typed-racket-compatibility/info.rkt

@@ -11,4 +11,4 @@
 
 (define pkg-authors '(samth stamourv))
 
-(define version "1.1")
+(define version "1.5")

typed-racket-compatibility/typed-scheme/lang/reader.rkt

@@ -6,14 +6,11 @@ typed-scheme
 #:read-syntax r:read-syntax
 #:info make-info
 
-(require (prefix-in r: typed-racket/typed-reader))
+(require (prefix-in r: typed-racket/typed-reader)
+         typed-racket/private/oc-button)
 
 (define (make-info key default use-default)
   (case key
     [(drscheme:toolbar-buttons)
-     ;; If Optimization Coach is installed, load it.
-     (with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
-       (collection-path "optimization-coach")
-       (list (dynamic-require 'optimization-coach/tool
-                              'optimization-coach-drracket-button)))]
+     (maybe-show-OC)]
     [else (use-default key default)]))

typed-racket-compatibility/typed/scheme/base.rkt

@@ -17,12 +17,13 @@
          (rename-in
            (except-in typed-racket/base-env/prims
              require-typed-struct
-             require/typed)
+             require/typed
+             require-typed-signature)
            (require-typed-struct-legacy require-typed-struct)
            (require/typed-legacy require/typed))
          typed-racket/base-env/base-types
-         typed-racket/base-env/base-types-extra
-	 (for-syntax typed-racket/base-env/base-types-extra))
+         (except-in typed-racket/base-env/base-types-extra Distinction)
+	 (for-syntax (except-in typed-racket/base-env/base-types-extra Distinction)))
 (provide (rename-out [define-type-alias define-type])
          (all-from-out typed-racket/base-env/prims)
          (all-from-out typed-racket/base-env/base-types)

typed-racket-compatibility/typed/scheme/base/lang/reader.rkt

@@ -7,14 +7,12 @@ typed/scheme/base
 #:info make-info
 #:language-info make-language-info
 
+(require typed-racket/private/oc-button)
+
 (define (make-info key default use-default)
   (case key
     [(drscheme:toolbar-buttons)
-     ;; If Optimization Coach is installed, load it.
-     (with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
-       (collection-path "optimization-coach")
-       (list (dynamic-require 'optimization-coach/tool
-                              'optimization-coach-drracket-button)))]
+     (maybe-show-OC)]
     [else (use-default key default)]))
 
 (define make-language-info

typed-racket-compatibility/typed/scheme/lang/reader.rkt

@@ -7,14 +7,12 @@ typed/scheme
 #:info make-info
 #:language-info make-language-info
 
+(require typed-racket/private/oc-button)
+
 (define (make-info key default use-default)
   (case key
     [(drscheme:toolbar-buttons)
-     ;; If Optimization Coach is installed, load it.
-     (with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
-       (collection-path "optimization-coach")
-       (list (dynamic-require 'optimization-coach/tool
-                              'optimization-coach-drracket-button)))]
+     (maybe-show-OC)]
     [else (use-default key default)]))
 
 (define make-language-info

typed-racket-doc/info.rkt

@@ -10,12 +10,13 @@
                      "r6rs-lib"
                      "sandbox-lib"
                      "at-exp-lib"
-                     "scribble-lib"
+                     ("scribble-lib" #:version "1.16")
                      "pict-lib"
-                     "typed-racket-lib"
+                     ("typed-racket-lib" #:version "1.5")
                      "typed-racket-compatibility"
                      "typed-racket-more"
-                     "racket-doc"))
+                     "racket-doc"
+                     "draw-lib"))
 (define deps '("base"))
 (define update-implies '("typed-racket-lib"))
 
@@ -23,4 +24,4 @@
 
 (define pkg-authors '(samth stamourv))
 
-(define version "1.1")
+(define version "1.5")

typed-racket-doc/typed-racket/scribblings/guide/begin.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/manual
 
-@begin[(require (for-label (only-meta-in 0 typed/racket)) scribble/eval
+@begin[(require (for-label (only-meta-in 0 typed/racket))
+                scribble/example
                 "../utils.rkt" (only-in "quick.scrbl" typed-mod))]
 
 @(define the-eval (make-base-eval))
@@ -23,7 +24,7 @@ are provided as well; for example, the
 @racketmodname[typed/racket/base] language corresponds to
 @racketmodname[racket/base].
 
-@racketblock+eval[#:eval the-eval (struct pt ([x : Real] [y : Real]))]
+@examples[#:no-result #:eval the-eval (struct pt ([x : Real] [y : Real]))]
 
 @margin-note{Typed Racket provides modified versions of core Racket forms,
 which permit type annotations. Previous versions of Typed Racket provided
@@ -34,11 +35,11 @@ This defines a new structure, named @racket[pt], with two fields,
 @racket[Real], which corresponds to the @rtech{real numbers}.
  The
 @racket[struct] form corresponds to its untyped counterpart from
-from @racketmodname[racket]---when porting a program from
+@racketmodname[racket]---when porting a program from
 @racketmodname[racket] to @racketmodname[typed/racket], simply add
 type annotations to existing field declarations.
 
-@racketblock+eval[#:eval the-eval (: distance (-> pt pt Real))]
+@examples[#:no-result #:eval the-eval (: distance (-> pt pt Real))]
 
 This declares that @racket[distance] has the type @racket[(-> pt pt Real)].
 @;{@racket[distance] must be defined at the top-level of the module containing
@@ -54,7 +55,7 @@ function type, in this case @racket[Real].
 If you are familiar with @rtech{contracts}, the notation for function
 types is similar to function contract combinators.
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
 (define (distance p1 p2)
   (sqrt (+ (sqr (- (pt-x p2) (pt-x p1)))
            (sqr (- (pt-y p2) (pt-y p1))))))
@@ -71,14 +72,14 @@ the program is accepted.
 In the Typed Racket @gtech{REPL}, calling @racket[distance] will
 show the result as usual and will also print the result's type:
 
-@interaction[#:eval the-eval (distance (pt 0 0) (pt 3.1415 2.7172))]
+@examples[#:label #f #:eval the-eval (distance (pt 0 0) (pt 3.1415 2.7172))]
 
 Just evaluating the function name will print the function value and its type,
 which can be useful for discovering the types that Typed Racket ascribes to
 Racket functions. Alternatively, the @racket[:print-type] command will just
 print the type:
 
-@interaction[#:eval the-eval distance string-length (:print-type string-ref)]
+@examples[#:label #f #:eval the-eval distance string-length (:print-type string-ref)]
 
 @section{Datatypes and Unions}
 
@@ -141,14 +142,14 @@ When Typed Racket detects a type error in the module, it raises an
 error before running the program.
 
 @examples[#:eval the-eval
-(add1 "not a number")
+(eval:error (add1 "not a number"))
 ]
 
 @;{
 Typed Racket also attempts to detect more than one error in the module.
 
 @examples[#:eval the-eval
-(string-append "a string" (add1 "not a number"))
+(eval:error (string-append "a string" (add1 "not a number")))
 ]
 }
 

typed-racket-doc/typed-racket/scribblings/guide/caveats.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @(require "../utils.rkt"
-          scribble/eval
+          scribble/example
           (for-label (only-meta-in 0 typed/racket)))
 
 @(define the-eval (make-base-eval))
@@ -38,19 +38,19 @@ on higher-order arguments that are themselves polymorphic.
 For example, the following program results in a type error
 that demonstrates this limitation:
 
-@interaction[#:eval the-eval
-  (map cons '(a b c d) '(1 2 3 4))
+@examples[#:label #f #:eval the-eval
+  (eval:error (map cons '(a b c d) '(1 2 3 4)))
 ]
 
 The issue is that the type of @racket[cons] is also polymorphic:
 
-@interaction[#:eval the-eval cons]
+@examples[#:label #f #:eval the-eval cons]
 
 To make this expression type-check, the @racket[inst] form can
 be used to instantiate the polymorphic argument (e.g., @racket[cons])
 at a specific type:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
   (map (inst cons Symbol Integer) '(a b c d) '(1 2 3 4))
 ]
 
@@ -69,10 +69,11 @@ fixed in a future release.
 The following illustrates an example type that cannot be
 converted to a contract:
 
-@interaction[#:eval the-eval
-  (require/typed racket/base
-    [object-name (case-> (-> Struct-Type-Property Symbol)
-                         (-> Regexp (U String Bytes)))])
+@examples[#:label #f #:eval the-eval
+  (eval:error
+   (require/typed racket/base
+     [object-name (case-> (-> Struct-Type-Property Symbol)
+                          (-> Regexp (U String Bytes)))]))
 ]
 
 This function type by cases is a valid type, but a corresponding
@@ -83,7 +84,7 @@ supported with dependent contracts.
 A more approximate type will work for this case, but with a loss
 of type precision at use sites:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
   (require/typed racket/base
     [object-name (-> (U Struct-Type-Property Regexp)
                      (U String Bytes Symbol))])
@@ -94,14 +95,11 @@ Use of @racket[define-predicate] also involves contract generation, and
 so some types cannot have predicates generated for them. The following
 illustrates a type for which a predicate can't be generated:
 
-@interaction[#:eval the-eval
-  (define-predicate p? (All (A) (Listof A)))]
+@examples[#:label #f #:eval the-eval
+  (eval:error (define-predicate p? (All (A) (Listof A))))]
 
 @section{Unsupported features}
 
-Units are not currently supported at all in Typed Racket, but they
-will potentially be supported in a future version.
-
 Most structure type properties do not work in Typed Racket, including
 support for generic interfaces.
 
@@ -112,7 +110,7 @@ To make programming with invariant type constructors (such as @racket[Boxof])
 easier, Typed Racket generalizes types that are used as arguments to invariant
 type constructors. For example:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
   0
   (define b (box 0))
   b
@@ -126,7 +124,7 @@ initialize it with @racket[0]. Type generalization does exactly that.
 
 In some cases, however, type generalization can lead to unexpected results:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
   (box (ann 1 Fixnum))
 ]
 
@@ -134,7 +132,7 @@ The intent of this code may be to create of box of @racket[Fixnum], but Typed
 Racket will generalize it anyway. To create a box of @racket[Fixnum], the box
 itself should have a type annotation:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
   (ann (box 1) (Boxof Fixnum))
   ((inst box Fixnum) 1)
 ]
@@ -149,22 +147,24 @@ occur inside macros---are not checked.
 Concretely, this means that expressions inside, for example, a
 @racket[begin-for-syntax] block are not checked:
 
-@interaction[#:eval the-eval
-  (begin-for-syntax (+ 1 "foo"))
+@examples[#:label #f #:eval the-eval
+  (eval:error (begin-for-syntax (+ 1 "foo")))
 ]
 
 Similarly, expressions inside of macros defined in Typed Racket are
 not type-checked. On the other hand, the macro's expansion is always
 type-checked:
 
-@defs+int[#:eval the-eval
-  ((define-syntax (example-1 stx)
+@examples[#:label #f #:eval the-eval
+  (eval:no-prompt
+   (define-syntax (example-1 stx)
      (+ 1 "foo")
-     #'1)
+     #'1))
+  (eval:no-prompt
    (define-syntax (example-2 stx)
      #'(+ 1 "foo")))
-  (example-1)
-  (example-2)
+  (eval:error (example-1))
+  (eval:error (example-2))
 ]
 
 Note that functions defined in Typed Racket that are used at

typed-racket-doc/typed-racket/scribblings/guide/more.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @begin[(require "../utils.rkt"
-                scribble/core scribble/eval
+                scribble/core scribble/example
                 (for-label (only-meta-in 0 typed/racket)
                            (prefix-in base: racket)))]
 
@@ -127,8 +127,8 @@ This ensures that the expression, here @racket[(+ 7 1)], has the
 desired type, here @racket[Number].  Otherwise, the type checker
 signals an error.  For example:
 
-@interaction[#:eval the-eval
-(ann "not a number" Number)]
+@examples[#:label #f #:eval the-eval
+(eval:error (ann "not a number" Number))]
 
 @section{Type Inference}
 

typed-racket-doc/typed-racket/scribblings/guide/occurrence.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @begin[(require "../utils.rkt"
-		scribble/core scribble/eval
+		scribble/core scribble/example
 		(for-label (only-meta-in 0 typed/racket)))]
 
 @(define the-eval (make-base-eval))
@@ -18,7 +18,7 @@ fails.
 
 To illustrate, consider the following code:
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
   (: flexible-length (-> (U String (Listof Any)) Integer))
   (define (flexible-length str-or-lst)
     (if (string? str-or-lst)
@@ -51,7 +51,7 @@ have based on a predicate check in a conditional expression, it can
 narrow the type of the variable within the appropriate branch of the
 conditional.
 
-@section[#:tag "filters-and-predicates"]{Filters and Predicates}
+@section[#:tag "propositions-and-predicates"]{Propositions and Predicates}
 
 In the previous section, we demonstrated that a Typed Racket programmer
 can take advantage of occurrence typing to type-check functions
@@ -59,26 +59,30 @@ with union types and conditionals. This may raise the question: how
 does Typed Racket know how to narrow the type based on the predicate?
 
 The answer is that predicate types in Typed Racket are annotated
-with @deftech{filters} that tell the typechecker what additional
+with logical @deftech{propositions} that tell the typechecker what additional
 information is gained when a predicate check succeeds or fails.
 
 For example, consider the REPL's type printout for @racket[string?]:
 
-@interaction[#:eval the-eval string?]
+@examples[#:label #f #:eval the-eval string?]
 
 The type @racket[(-> Any Boolean : String)] has three parts. The first
 two are the same as any other function type and indicate that the
 predicate takes any value and returns a boolean. The third part, after
-the @racket[_:], is a @tech{filter} that tells the typechecker two
-things:
+the @racket[_:], represents the logical @tech{propositions}
+the typechecker learns from the result of applying the function:
 
 @itemlist[#:style 'ordered
-  @item{If the predicate check succeeds, the argument variable has type @racket[String]}
-  @item{If the predicate check fails, the argument variable @emph{does not} have type @racket[String]}
-]
 
-Predicates for all built-in types are annotated with similar filters
-that allow the type system to reason about predicate checks.
+  @item{If the predicate check succeeds (i.e. produces a
+  non-@racket[#f] value), the argument variable has type
+  @racket[String]}
+
+@item{If the predicate check fails (i.e. produces @racket[#f]), the
+  argument variable @emph{does not} have type @racket[String]} ]
+
+Predicates for all built-in types are annotated with similar propositions
+that allow the type system to reason logically about predicate checks.
 
 @section{Other conditionals and assertions}
 
@@ -93,7 +97,7 @@ control flow constructs that are present in Racket such as
 For example, the @racket[_flexible-length] function from earlier can
 be re-written to use @racket[cond] with no additional effort:
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
   (: flexible-length/cond (-> (U String (Listof Any)) Integer))
   (define (flexible-length/cond str-or-lst)
     (cond [(string? str-or-lst) (string-length str-or-lst)]
@@ -104,13 +108,13 @@ In some cases, the type system does not have enough information or is
 too conservative to typecheck an expression. For example, consider
 the following interaction:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 (: a Positive-Integer)
 (define a 15)
 (: b Positive-Integer)
 (define b 20)
 (: c Positive-Integer)
-(define c (- b a))
+(eval:error (define c (- b a)))
 ]
 
 In this case, the type system only knows that @racket[_a] and
@@ -119,13 +123,13 @@ difference will always be positive in defining @racket[_c].  In cases
 like this, occurrence typing can be used to make the code type-check
 using an @emph{assertion}. For example,
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
 (: d Positive-Integer)
 (define d (assert (- b a) positive?))
 ]
 
-Using the filter on @racket[positive?], Typed Racket can assign the
-type @racket[Positive-Integer] to the whole @racket[assert]
+Using the logical propositions on @racket[positive?], Typed Racket can
+assign the type @racket[Positive-Integer] to the whole @racket[assert]
 expression.  This type-checks, but note that the assertion may raise
 an exception at run-time if the predicate returns @racket[#f].
 
@@ -133,7 +137,7 @@ Note that @racket[assert] is a derived concept in Typed Racket and is
 a natural consequence of occurrence typing. The assertion above is
 essentially equivalent to the following:
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
 (: e Positive-Integer)
 (define e (let ([diff (- b a)])
             (if (positive? diff)
@@ -165,7 +169,7 @@ by let-expressions alias other values (e.g. when they alias non-mutated identifi
 This allows programs which explicitly rely on occurrence typing and aliasing to 
 typecheck:
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
 (: f (Any -> Number))
 (define (f x) 
   (let ([y x])
@@ -180,7 +184,7 @@ typecheck:
 It also allows the typechecker to check programs which use macros 
 that heavily rely on let-bindings internally (such as @racket[match]):
 
-@racketblock+eval[#:eval the-eval
+@examples[#:no-result #:eval the-eval
 (: g (Any -> Number))
 (define (g x) 
   (match x

typed-racket-doc/typed-racket/scribblings/guide/optimization.scrbl

@@ -1,7 +1,6 @@
 #lang scribble/manual
 
 @begin[(require (for-label (only-meta-in 0 typed/racket))
-                scribble/eval racket/sandbox
 		"../utils.rkt" (only-in "quick.scrbl" typed-mod))]
 
 @title[#:tag "optimization"]{Optimization in Typed Racket}
@@ -30,9 +29,9 @@ Racket idioms. However, it does a better job on some idioms than on
 others. By writing your programs using the right idioms, you can help
 the optimizer help you.
 
-To best take advantage of the Typed Racket optimizer, keep the following in
-mind. The @emph{Optimization Coach} package provides optimization coaching
-support to help you in this task.
+To best take advantage of the Typed Racket optimizer, consult
+@other-doc['(lib "optimization-coach/scribblings/optimization-coach.scrbl")
+#:indirect "Optimization Coach"]{}.
 
 
 @subsection{Numeric types}

typed-racket-doc/typed-racket/scribblings/guide/typed-untyped-interaction.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @(require "../utils.rkt"
-          scribble/eval
+          scribble/example
           (for-label (only-meta-in 0 typed/racket)))
 
 @(define the-eval (make-base-eval))
@@ -49,7 +49,7 @@ typed/racket
                [#:struct pt ([x : Real] [y : Real])]
                [distance (-> pt pt Real)])
 
-(distance (pt 3 5) (p 7 0))
+(distance (pt 3 5) (pt 7 0))
 ]
 
 The @racket[require/typed] form has several kinds of clauses. The
@@ -100,17 +100,17 @@ function:
 @margin-note{For general information on Racket's contract system
 , see @secref[#:doc '(lib "scribblings/guide/guide.scrbl")]{contracts}.}
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 (module increment racket
   (provide increment)
 
-  (code:contract "increment : exact-integer? -> exact-integer?")
+  (code:contract increment : exact-integer? -> exact-integer?)
   (define (increment x) "this is broken"))
 ]
 
 and a typed module that uses it:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 (module client typed/racket
 
   (require/typed 'increment [increment (-> Integer Integer)])
@@ -127,7 +127,7 @@ strings.
 
 On the other hand, when the program is run:
 
-@interaction[#:eval the-eval (require 'client)]
+@examples[#:label #f #:eval the-eval (eval:error (require 'client))]
 
 we find that the contract system checks the assumption made by the typed
 module and correctly finds that the assumption failed because of the

typed-racket-doc/typed-racket/scribblings/guide/types.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @begin[(require "../utils.rkt"
-		scribble/core scribble/eval
+		scribble/core scribble/example
 		(for-label (only-meta-in 0 typed/racket)))]
 
 @(define the-eval (make-base-eval))
@@ -18,7 +18,7 @@ The most basic types in Typed Racket are those for primitive data,
 such as @racket[True] and @racket[False] for booleans, @racket[String]
 for strings, and @racket[Char] for characters.
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 '"hello, world"
 #\f
 #t
@@ -27,14 +27,14 @@ for strings, and @racket[Char] for characters.
 Each symbol is given a unique type containing only that symbol.  The
 @racket[Symbol] type includes all symbols.
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 'foo
 'bar]
 
 Typed Racket also provides a rich hierarchy for describing particular
 kinds of numbers.
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 0
 -7
 14
@@ -43,7 +43,7 @@ kinds of numbers.
 
 Finally, any value is itself a type:
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 (ann 23 23)]
 
 @section{Function Types}
@@ -65,7 +65,7 @@ one argument, and produces  @rtech{multiple values}, of types
 @racket[String] and @racket[Natural].  Here are example functions for
 each of these types.
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 (lambda ([x : Number]) x)
 (lambda ([a : String] [b : String]) (equal? a b))
 (lambda ([c : Char]) (values (string c) (char->integer c)))]
@@ -106,7 +106,7 @@ The result is two values of type @racket[Number].
 Sometimes a value can be one of several types.  To specify this, we
 can use a union type, written with the type constructor @racket[U].
 
-@interaction[#:eval the-eval
+@examples[#:label #f #:eval the-eval
 (let ([a-number 37])
   (if (even? a-number)
       'yes
@@ -141,9 +141,9 @@ type defintion could also be written like this.
 Of course, types which directly refer to themselves are not
 permitted. For example, both of these definitions are illegal.
 
-@interaction[#:eval the-eval
-(define-type BinaryTree BinaryTree)
-(define-type BinaryTree (U Number BinaryTree))]
+@examples[#:label #f #:eval the-eval
+(eval:error (define-type BinaryTree BinaryTree))
+(eval:error (define-type BinaryTree (U Number BinaryTree)))]
 
 @section{Structure Types}
 

typed-racket-doc/typed-racket/scribblings/internals.txt

@@ -1,17 +1,17 @@
 Data Structures used in Typechecking.
 The main data structure used in typechecking is a tc-results/c.
 This currently has two variants
-(struct/c tc-results ((listof (struct/c tc-result (Type/c FilterSet? Object?)))
+(struct/c tc-results ((listof (struct/c tc-result (Type/c PropSet? Object?)))
                       (or/c #f (cons/c Type/c symbol?))))
-(struct/c tc-any-results (or/c Filter/c NoFilter?))
+(struct/c tc-any-results (or/c Prop? #f))
 
 The first represents a fixed number of values with optional dotted return values.
 The second represents an unknown number of values.
 
-A value has three main parts: a Type, a FilterSet, and an Object. For dotted values we do no store a 
-FilterSet or an Object because they would almost never be useful. They are thus implicitly -top-filter
+A value has three main parts: a Type, a PropSet, and an Object. For dotted values we do no store a 
+PropSet or an Object because they would almost never be useful. They are thus implicitly -tt-propset
 and -empty-obj. In the tc-any-results case since we don't know the number of values, we do not store
-the Type or the Object, but we do store a filter. This is useful in cases like
+the Type or the Object, but we do store a proposition. This is useful in cases like
 (let ((x (read)))
   (unless (number? x) (error 'bad-input))
   (do-stuff x))

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/example)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])))]
 
+@(define the-top-eval (make-base-eval #:lang 'typed/racket))
+@(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,27 @@ 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.
+
+This is purely a type-level distinction, with no way to distinguish the new type
+from the base type at runtime. Predicates made by @racket[make-predicate]
+won't be able distinguish them properly, so they will return true for all values
+that the base type's predicate would return true for. This is usually not what
+you want, so you shouldn't use @racket[make-predicate] with these types.
+
+@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/exploring-types.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @begin[(require "../utils.rkt")
-       (require scribble/eval)
+       (require scribble/example)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])))]
 
 @(define the-top-eval (make-base-eval))
@@ -33,7 +33,8 @@ The following bindings are only available at the Typed Racket REPL.
   ]
 }
 
-@defform[(:print-type e)]{Prints the type of @racket[_e]. This prints the whole
+@defform[(:print-type e)]{Prints the type of @racket[_e], which must be
+an expression. This prints the whole
 type, which can sometimes be quite large.
 
 @examples[#:eval the-top-eval

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

@@ -1,7 +1,7 @@
 #lang scribble/manual
 
 @begin[(require "../utils.rkt")
-       (require scribble/eval
+       (require scribble/example
                 (for-label (only-meta-in 0 [except-in typed/racket for])))]
 
 @(define the-eval (make-base-eval))

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

@@ -4,14 +4,21 @@
        (require (for-label (only-meta-in 0 [except-in typed/racket for])
                            (only-in racket/base for)
                            racket/list srfi/14 net/url
-                           version/check))]
+                           version/check
+                           ;; Specific libraries wrapped for TR:
+                           file/gif
+                           net/http-client
+                           net/url-structs
+                           net/url
+                           openssl
+                           json))]
 
 
 @title{Libraries Provided With Typed Racket}
 
 The @racketmodname[typed/racket] language corresponds to the
 @racketmodname[racket] language---that is, any identifier provided
-by @racketmodname[racket], such as @racket[modulo] is available by default in
+by @racketmodname[racket], such as @racket[modulo], is available by default in
 @racketmodname[typed/racket].
 
 @racketmod[typed/racket
@@ -44,25 +51,66 @@ Other libraries can be used with Typed Racket via
 The following libraries are included with Typed Racket in the
 @racketfont{typed} collection:
 
-@(define-syntax-rule @defmodule/incl[name]
-   @defmodule[name #:no-declare])
+@(define-syntax-rule @defmodule/incl[name rest ...]
+   (list
+      (section #:style '(hidden toc-hidden unnumbered)
+               (string-append "Typed for " (symbol->string 'name)))
+      @defmodule[name rest ...]))
 
+@(define-syntax-rule (deftype name . parts)
+   (defidform #:kind "type" name . parts))
+
+@;; framework and mred left out until support for classes
+@;; is more complete
 @defmodule/incl[typed/file/gif]
+@deftype[GIF-Stream]{
+  Describe a GIF stream, as produced by @racket[gif-start]
+  and accepted by the other functions from @racketmodname[file/gif].
+}
+@deftype[GIF-Colormap]{
+  Type alias for a list of three-element (R,G,B) vectors representing an image.
+}
+
 @defmodule/incl[typed/file/md5]
 @defmodule/incl[typed/file/tar]
 @defmodule/incl[typed/framework]
 @defmodule/incl[typed/json]
+
+@deftype[JSExpr]{
+  Describes a @tech["jsexpr" #:doc '(lib "json/json.scrbl")].
+}
+
 @defmodule/incl[typed/mred/mred]
 @defmodule/incl[typed/net/base64]
 @defmodule/incl[typed/net/cgi]
 @defmodule/incl[typed/net/cookie]
+
+@deftype[Cookie]{
+  Describes an HTTP cookie as implemented by @racketmodname[net/cookie].
+}
+
 @defmodule/incl[typed/net/dns]
 @defmodule/incl[typed/net/ftp]
+
+@deftype[FTP-Connection]{
+  Describes an open FTP connection.
+}
+
 @defmodule/incl[typed/net/gifwrite]
 @defmodule/incl[typed/net/git-checkout]
 @defmodule/incl[typed/net/head]
 @defmodule/incl[typed/net/http-client]
+
+@deftype[HTTP-Connection]{
+  Describes an HTTP connection, corresponding to @racket[http-conn?].
+}
+
 @defmodule/incl[typed/net/imap]
+
+@deftype[IMAP-Connection]{
+  Describes an IMAP connection.
+}
+
 @defmodule/incl[typed/net/mime]
 @defmodule/incl[typed/net/nntp]
 @defmodule/incl[typed/net/pop3]
@@ -73,15 +121,61 @@ The following libraries are included with Typed Racket in the
 @defmodule/incl[typed/net/uri-codec]
 @defmodule/incl[typed/net/url-connect]
 @defmodule/incl[typed/net/url-structs]
+
+@deftype[Path/Param]{
+  Describes the @racket[path/param] struct from @racketmodname[net/url-structs].
+}
+@deftype[URL]{
+  Describes an @racket[url] struct from @racketmodname[net/url-structs].
+}
+
 @defmodule/incl[typed/net/url]
+In addition to defining the following types, this module also provides the
+@racket[HTTP-Connection] type defined by @racketmodname[typed/net/http-client],
+and the @racket[URL] and @racket[Path/Param] types from
+@racketmodname[typed/net/url-structs].
+
+@deftype[URL-Exception]{
+  Describes exceptions raised by URL-related functions; corresponds
+  to @racket[url-exception?].
+}
+@deftype[PortT]{
+  Describes the functions @racket[head-pure-port], @racket[delete-pure-port],
+  @racket[get-impure-port], @racket[head-impure-port], and
+  @racket[delete-impure-port].
+}
+@deftype[PortT/Bytes]{
+  Like @racket[PortT], but describes the functions that make POST and PUT
+  requests, which require an additional byte-string argument for POST or PUT
+  data.
+}
+
+@defmodule/incl[typed/openssl]
+
+@deftype[SSL-Protocol]{
+  Describes an SSL protocol, defined as
+  @racket[(U 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)].
+}
+@deftogether[(@deftype[SSL-Server-Context]
+              @deftype[SSL-Client-Context])]{
+  Describes an OpenSSL server or client context.
+}
+@deftype[SSL-Context]{Supertype of OpenSSL server and client contexts.}
+@deftype[SSL-Listener]{
+  Describes an SSL listener, as produced by @racket[ssl-listen].
+}
+@deftype[SSL-Verify-Source]{
+  Describes a verification source usable by @racket[ssl-load-verify-source!]
+  and the @racket[ssl-default-verify-sources] parameter.
+}
+
 @defmodule/incl[typed/openssl/md5]
 @defmodule/incl[typed/openssl/sha1]
-@defmodule/incl[typed/openssl]
-@defmodule/incl[typed/pict]
-@defmodule[typed/racket/async-channel #:no-declare @history[#:added "1.1"]]
+@defmodule/incl[typed/racket/async-channel @history[#:added "1.1"]]
 @defmodule/incl[typed/racket/date]
 @defmodule/incl[typed/racket/draw]
 @defmodule/incl[typed/racket/gui]
+@defmodule/incl[typed/racket/random @history[#:added "1.5"]]
 @defmodule/incl[typed/racket/sandbox]
 @defmodule/incl[typed/racket/snip]
 @defmodule/incl[typed/racket/system]
@@ -90,8 +184,24 @@ The following libraries are included with Typed Racket in the
 @defmodule/incl[typed/rackunit/text-ui]
 @defmodule/incl[typed/rackunit]
 @defmodule/incl[typed/srfi/14]
+
+@deftype[Char-Set]{
+  Describes a character set usable by the @racketmodname[srfi/14] functions.
+}
+@deftype[Cursor]{
+  Describes a cursor for iterating over character sets.
+}
+
 @defmodule/incl[typed/srfi/19]
+
+@deftogether[(@defidform[#:kind "type" Time]
+              @defidform[#:kind "type" Date])]{
+  Describes an SRFI 19 time or date structure.
+}
+
 @defmodule/incl[typed/syntax/stx]
+@defmodule/incl[typed/web-server/configuration/responders]
+@defmodule/incl[typed/web-server/http]
 
 In some cases, these typed adapters may not contain all of exports of the
 original module, or their types may be more limited.
@@ -103,7 +213,11 @@ written in Typed Racket or have adapter modules that are typed:
    @defmodule[name #:no-declare #:link-target? #f #:indirect])
 
 @defmodule/also[math]
-@defmodule/also[plot/typed]
+@defmodule/also[plot]
+@defmodule/incl[typed/pict]
+@defmodule/also[images/flomap]
+@defmodule/incl[typed/images/logos]
+@defmodule/incl[typed/images/icons]
 
 @section{Porting Untyped Modules to Typed Racket}
 

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

@@ -1,6 +1,6 @@
 #lang scribble/manual
 
-@begin[(require "../utils.rkt" scribble/eval racket/sandbox)
+@begin[(require "../utils.rkt" scribble/example racket/sandbox)
        (require (for-label (only-meta-in 0 [except-in typed/racket])
                            (only-in racket/base)))]
 
@@ -229,12 +229,7 @@ variants.
 @defform[(for/hasheq type-ann-maybe (for-clause ...) expr ...+)]
 @defform[(for/hasheqv type-ann-maybe (for-clause ...) expr ...+)]
 @defform[(for/vector type-ann-maybe (for-clause ...) expr ...+)]
-@defform[(for/flvector type-ann-maybe (for-clause ...) expr ...+)]
-@defform[(for/extflvector type-ann-maybe (for-clause ...) expr ...+)]
-@defform[(for/and type-ann-maybe (for-clause ...) expr ...+)]
 @defform[(for/or   type-ann-maybe (for-clause ...) expr ...+)]
-@defform[(for/first type-ann-maybe (for-clause ...) expr ...+)]
-@defform[(for/last type-ann-maybe (for-clause ...) expr ...+)]
 @defform[(for/sum type-ann-maybe (for-clause ...) expr ...+)]
 @defform[(for/product type-ann-maybe (for-clause ...) expr ...+)]
 @defform[(for/set type-ann-maybe (for-clause ...) expr ...+)]
@@ -260,6 +255,16 @@ type @racket[u]. For example, a @racket[for/list] form would be
 annotated with a @racket[Listof] type. All annotations are optional.
 }
 
+@deftogether[[
+@defform[(for/flvector type-ann-maybe (for-clause ...) expr ...+)]
+@defform[(for/extflvector type-ann-maybe (for-clause ...) expr ...+)]
+@defform[(for/and type-ann-maybe (for-clause ...) expr ...+)]
+@defform[(for/first type-ann-maybe (for-clause ...) expr ...+)]
+@defform[(for/last type-ann-maybe (for-clause ...) expr ...+)]
+]]{
+Like the above, except they are not yet supported by the typechecker.
+}
+
 @deftogether[[
 @defform[(for/lists type-ann-maybe ([id : t] ...)
            (for-clause ...)
@@ -373,14 +378,19 @@ those functions.
 
 
 @section{Structure Definitions}
-@defform/subs[
+@defform/subs[#:literals (:)
 (struct maybe-type-vars name-spec ([f : t] ...) options ...)
 ([maybe-type-vars code:blank (v ...)]
- [name-spec name (code:line name parent)]
- [options #:transparent #:mutable #:prefab])]{
- Defines a @rtech{structure} with the name @racket[name], where the
+ [name-spec name-id (code:line name-id parent)]
+ [options #:transparent #:mutable #:prefab
+          (code:line #:constructor-name constructor-id)
+          (code:line #:extra-constructor-name constructor-id)
+          (code:line #:type-name type-id)])]{
+ Defines a @rtech{structure} with the name @racket[name-id], where the
  fields @racket[f] have types @racket[t], similar to the behavior of @|struct-id|
- from @racketmodname[racket/base].
+ from @racketmodname[racket/base]. If @racket[type-id] is specified, then it will
+ be used for the name of the type associated with instances of the declared
+ structure, otherwise @racket[name-id] will be used for both.
   When @racket[parent] is present, the
 structure is a substructure of @racket[parent].
 
@@ -397,36 +407,47 @@ amount it needs.
 
 @ex[
   (struct (X Y) 2-tuple ([first : X] [second : Y]))
-  (struct (X Y Z) 3-tuple 2-tuple ([first : X] [second : Y] [third :  Z]))
+  (struct (X Y Z) 3-tuple 2-tuple ([third :  Z]))
 ]
 
 Options provided have the same meaning as for the @|struct-id| form
-from @racketmodname[racket/base].
+from @racketmodname[racket/base] (with the exception of @racket[#:type-name], as
+described above).
 
-A prefab structure type declaration will bind the given @racket[name] to a
-@racket[Prefab] type. Unlike in @racketmodname[racket/base], a non-prefab
-structure type cannot extend a prefab structure type.
+A prefab structure type declaration will bind the given @racket[name-id]
+or @racket[type-id] to a @racket[Prefab] type. Unlike the @|struct-id| form from
+@racketmodname[racket/base], a non-prefab structure type cannot extend
+a prefab structure type.
 
 @ex[
   (struct a-prefab ([x : String]) #:prefab)
   (:type a-prefab)
-  (struct not-allowed a-prefab ())
+  (eval:error (struct not-allowed a-prefab ()))
 ]
+
+@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]
 }
 
 
-@defform/subs[
+@defform/subs[#:literals (:)
 (define-struct maybe-type-vars name-spec ([f : t] ...) options ...)
 ([maybe-type-vars code:blank (v ...)]
- [name-spec name (name parent)]
- [options #:transparent #:mutable])]{Legacy version of @racket[struct],
-corresponding to @|define-struct-id| from @racketmodname[racket/base].}
+ [name-spec name-id (code:line name-id parent)]
+ [options #:transparent #:mutable
+          (code:line #:type-name type-id)])]{
+Legacy version of @racket[struct], corresponding to @|define-struct-id|
+from @racketmodname[racket/base].
+@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]}
 
-@defform/subs[
-(define-struct/exec name-spec ([f : t] ...) [e : proc-t])
-([name-spec name (name parent)])]{
+@defform/subs[#:literals (:)
+(define-struct/exec name-spec ([f : t] ...) [e : proc-t] maybe-type-name)
+([name-spec name-id (code:line name-id parent)]
+ [maybe-type-name (code:line)
+                  (code:line #:type-name type-id)])]{
  Like @racket[define-struct], but defines a procedural structure.
- The procdure @racket[e] is used as the value for @racket[prop:procedure], and must have type @racket[proc-t].}
+ The procedure @racket[e] is used as the value for @racket[prop:procedure],
+ and must have type @racket[proc-t].
+@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]}
 
 @section{Names for Types}
 @defform*[[(define-type name t maybe-omit-def)
@@ -461,27 +482,8 @@ back to itself.
 However, the recursive reference may not occur immediately inside
 the type:
 
-@ex[(define-type Foo Foo)
-    (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))]
+@ex[(eval:error (define-type Foo Foo))
+    (eval:error (define-type Bar (U Bar False)))]
 }
 
 @section{Generating Predicates Automatically}
@@ -538,10 +540,19 @@ returned by @racket[e], protected by a contract ensuring that it has type
 @racket[t]. This is legal only in expression contexts.
 
 @ex[(cast 3 Integer)
-(cast 3 String)
-(cast (lambda: ([x : Any]) x) (String -> String))
+(eval:error (cast 3 String))
+(cast (lambda ([x : Any]) x) (String -> String))
+((cast (lambda ([x : Any]) x) (String -> String)) "hello")
 ]
-}
+
+The value is actually protected with two contracts. The second contract checks
+the new type, but the first contract is put there to enforce the old type, to
+protect higher-order uses of the value.
+
+@ex[
+((cast (lambda ([s : String]) s) (Any -> Any)) "hello")
+(eval:error ((cast (lambda ([s : String]) s) (Any -> Any)) 5))
+]}
 
 @defform*[[(inst e t ...)
            (inst e t ... t ooo bound)]]{
@@ -572,33 +583,34 @@ Here, @racket[_m] is a module spec, @racket[_pred] is an identifier
 naming a predicate, and @racket[_maybe-renamed] is an
 optionally-renamed identifier.
 
-@defform/subs[#:literals (struct)
+@defform/subs[#:literals (struct :)
 (require/typed m rt-clause ...)
 ([rt-clause [maybe-renamed t]
-            [#:struct name ([f : t] ...)
+            [#:struct name-id ([f : t] ...)
                  struct-option ...]
-            [#:struct (name parent) ([f : t] ...)
+            [#:struct (name-id parent) ([f : t] ...)
                  struct-option ...]
-            [#:opaque t pred]]
+            [#:opaque t pred]
+	    [#:signature name ([id : t] ...)]]
  [maybe-renamed id
                 (orig-id new-id)]
  [struct-option
    (code:line #:constructor-name constructor-id)
-   (code:line #:extra-constructor-name constructor-id)])]
+   (code:line #:extra-constructor-name constructor-id)
+   (code:line #:type-name type-id)])]
 This form requires identifiers from the module @racket[m], giving
 them the specified types.
 
-The first case requires @racket[_maybe-renamed], giving it type
-@racket[t].
+The first case requires @racket[_maybe-renamed], giving it type @racket[t].
 
-@index["struct"]{The second and third cases} require the struct with name @racket[name]
-with fields @racket[f ...], where each field has type @racket[t].  The
-third case allows a @racket[parent] structure type to be specified.
-The parent type must already be a structure type known to Typed
-Racket, either built-in or via @racket[require/typed].  The
-structure predicate has the appropriate Typed Racket filter type so
-that it may be used as a predicate in @racket[if] expressions in Typed
-Racket.
+@index["struct"]{The second and third cases} require the struct with name
+@racket[name-id] and creates a new type with the name @racket[type-id], or
+@racket[name-id] if no @racket[type-id] is provided, with fields @racket[f ...],
+where each field has type @racket[t]. The third case allows a @racket[parent]
+structure type to be specified. The parent type must already be a structure type
+known to Typed Racket, either built-in or via @racket[require/typed]. The
+structure predicate has the appropriate Typed Racket filter type so that it may
+be used as a predicate in @racket[if] expressions in Typed Racket.
 
 
 @ex[(module UNTYPED racket/base
@@ -630,6 +642,11 @@ Opaque types must be required lexically before they are used.
     evt?
     (sync (alarm-evt (+ 100 (current-inexact-milliseconds))))]
 
+@index["signature"]{The @racket[#:signature] keyword} registers the required
+signature in the signature environment. For more information on the use of
+signatures in Typed Racket see the documentation for
+@racketmodname[typed/racket/unit].
+
 In all cases, the identifiers are protected with @rtech{contracts} which
 enforce the specified types.  If this contract fails, the module
 @racket[m] is blamed.
@@ -652,7 +669,9 @@ a @racket[require/typed] form. Here is an example of using
                             Any])]))
 
 @racket[file-or-directory-modify-seconds] has some arguments which are optional,
-so we need to use @racket[case->].}
+so we need to use @racket[case->].
+
+@history[#:changed "1.4" @elem{Added the @racket[#:type-name] option.}]}
 
 @defform[(require/typed/provide m rt-clause ...)]{
 Similar to @racket[require/typed], but also provides the imported identifiers.
@@ -697,7 +716,7 @@ but provides additional annotations to assist the typechecker.
         (default-continuation-prompt-tag)
         (code:comment "the function cannot be passed an argument")
         (λ (f) (f 3))))
-    (require 'untyped)
+    (eval:error (require 'untyped))
   ]
 }
 

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

@@ -1,6 +1,6 @@
 #lang scribble/manual
 
-@begin[(require "../utils.rkt" scribble/eval racket/sandbox)
+@begin[(require "../utils.rkt" scribble/example racket/sandbox)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])))]
 
 @(define the-eval (make-base-eval))
@@ -127,9 +127,10 @@ additional provides all other bindings from @racketmodname[racket/class].
   class form's clauses) are restricted.
 
   @ex[
-    (class object%
-      (code:comment "Note the missing `super-new`")
-      (init-field [x : Real 0] [y : Real 0]))
+    (eval:error
+     (class object%
+       (code:comment "Note the missing `super-new`")
+       (init-field [x : Real 0] [y : Real 0])))
   ]
 
   If any identifier with an optional type annotation is left without an

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

@@ -1,6 +1,6 @@
 #lang scribble/manual
 
-@begin[(require "../utils.rkt" scribble/eval racket/sandbox)
+@begin[(require "../utils.rkt" scribble/example racket/sandbox)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])))]
 
 @(define the-eval (make-base-eval))
@@ -35,19 +35,21 @@ have the types ascribed to them; these types are converted to contracts and chec
 @examples[#:eval the-eval
 (with-type #:result Number 3)
 
-((with-type #:result (Number -> Number)
-   (lambda: ([x : Number]) (add1 x)))
- #f)
+(eval:error
+ ((with-type #:result (Number -> Number)
+    (lambda: ([x : Number]) (add1 x)))
+  #f))
 
 (let ([x "hello"])
   (with-type #:result String
     #:freevars ([x String])
     (string-append x ", world")))
 
-(let ([x 'hello])
-  (with-type #:result String
-    #:freevars ([x String])
-    (string-append x ", world")))
+(eval:error
+ (let ([x 'hello])
+   (with-type #:result String
+     #:freevars ([x String])
+     (string-append x ", world"))))
 
 (with-type ([fun (Number -> Number)]
             [val Number])

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

@@ -0,0 +1,405 @@
+#lang scribble/manual
+
+@begin[(require "../utils.rkt" scribble/example racket/sandbox)
+       (require (for-label (only-meta-in 0 [except-in typed/racket for]))
+       (for-label (only-in racket/unit tag unit/c)))]
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require (except-in typed/racket #%top-interaction #%module-begin)))
+@(define the-top-eval (make-base-eval))
+@(the-top-eval '(require (except-in typed/racket #%module-begin)))
+
+@(define-syntax-rule (ex . args)
+   (examples #:eval the-top-eval . args))
+
+@title{Typed Units}
+
+@bold{Warning}: the features described in this section are experimental
+and may not work correctly. Some of the features may change by
+the next release.
+
+Typed Racket provides support for modular programming with the units
+and signatures provided by the @racketmodname[racket/unit] library.
+
+@section[#:tag "unit-forms"]{Special forms}
+
+@defmodule[typed/racket/unit]
+
+The special forms below are provided by the @racketmodname[typed/racket/unit]
+and @racketmodname[typed/racket] modules, but not by
+@racketmodname[typed/racket/base]. The @racketmodname[typed/racket/unit] module
+additionally provides all other bindings from @racketmodname[racket/unit].
+
+@;; This trick is borrowed from the Typed Class reference to link to
+@;; the identifiers in racket/unit
+@(module id-holder racket/base
+  (require scribble/manual (for-label racket/unit))
+  (provide (all-defined-out))
+  (define ut:define-signature (racket define-signature))
+  (define ut:unit (racket unit))
+  (define ut:invoke-unit (racket invoke-unit))
+  (define ut:define-values/invoke-unit (racket define-values/invoke-unit))
+  (define ut:compound-unit (racket compound-unit))
+  (define ut:define-unit (racket define-unit))
+  (define ut:compound-unit/infer (racket compound-unit/infer))
+  (define ut:define-compound-unit (racket define-compound-unit))
+  (define ut:define-compound-unit/infer (racket define-compound-unit/infer))
+  (define ut:invoke-unit/infer (racket invoke-unit/infer))
+  (define ut:define-values/invoke-unit/infer (racket define-values/invoke-unit/infer))
+  (define ut:unit-from-context (racket unit-from-context))
+  (define ut:define-unit-from-context (racket define-unit-from-context))
+  (define ut:define-values-for-export (racket define-values-for-export))
+  (define ut:define-values (racket define-values))
+  (define ut:open (racket open))
+  (define ut:define-syntaxes (racket define-syntaxes))
+  (define ut:define-unit-binding (racket define-unit-binding))
+  (define ut:unit/s (racket unit/s))
+  (define ut:unit/new-import-export (racket unit/new-import-export)))
+@(require 'id-holder)
+
+
+@defform[
+#:literals (extends :) 
+(define-signature id extension-decl
+  (sig-elem ...))
+#:grammar
+  ([extension-decl 
+    code:blank
+    (code:line extends sig-id)]
+
+   [sig-elem  [id : type]])]{
+
+Binds an identifier to a signature and registers the identifier in the signature
+environment with the specified type bindings. Sigantures in Typed Racket allow
+only specifications of variables and their types. Variable and syntax definitions
+are not allowed in the @racket[define-signature] form. This is only a limitation
+of the @racket[define-signature] form in Typed Racket.
+
+As in untyped Racket, the @racket[extends] clause includes all elements of
+extended signature and any implementation of the new signature can be used
+as an implementation of the extended signature.}
+
+@defform[
+#:literals (import export prefix rename only except init-depend)
+(unit 
+  (import sig-spec ...)
+  (export sig-spec ...)
+  init-depends-decl
+  unit-body-expr-or-defn
+  ...)
+#:grammar ([sig-spec
+ 	    sig-id  
+	    (prefix id sig-spec)
+  	    (rename sig-spec (id id) ...)
+	    (only sig-spec id ...)
+	    (except sig-spec id ...)]
+
+ 	    [init-depends-decl
+  	    code:blank
+  	    (init-depend sig-id ...)])]{
+The typed version of the Racket @ut:unit form. Unit expressions in Typed Racket
+do not support tagged signatures with the @racket[tag] keyword.}
+
+@defform*[
+#:literals (import)
+[(invoke-unit unit-expr)
+ (invoke-unit unit-expr (import sig-spec ...))]]{
+The typed version of the Racket @ut:invoke-unit form.}
+
+@defform[
+#:literals (import export)
+(define-values/invoke-unit unit-expr
+  (import def-sig-spec ...)
+  (export def-sig-spec ...))
+#:grammar ([def-sig-spec
+	    sig-id
+	    (prefix id def-sig-spec)
+	    (rename def-sig-spec (id id) ...)])]{
+The typed version of the Racket @ut:define-values/invoke-unit form. In Typed
+Racket @racket[define-values/invoke-unit] is only allowed at the top-level
+of a module.}
+
+@defform[
+#:literals (: import export link tag)
+(compound-unit
+  (import link-binding ...)
+  (export link-id ...)
+  (link linkage-decl ...))
+#:grammar ([link-binding
+	    (link-id : sig-id)]
+
+	   [linkage-decl
+	     ((link-binding ...) unit-expr link-id ...)])]{
+The typed version of the Racket @ut:compound-unit form.}
+
+@defform[
+#:literals (import export)
+(define-unit unit-id
+  (import sig-spec ...)
+  (export sig-spec ...)
+  init-depends-decl
+  unit-body-expr-or-defn
+  ...)]{
+The typed version of the Racket @ut:define-unit form.}
+
+@defform[
+#:literals (import export link :)
+(compound-unit/infer
+  (import infer-link-import ...)
+  (export infer-link-export ...)
+  (link infer-linkage-decl ...))
+#:grammar ([infer-link-import
+	    sig-id
+	    (link-id : sig-id)]
+
+	   [infer-link-export
+	     link-id
+	     sig-id]
+
+	   [infer-linkage-decl
+	     ((link-binding ...) unit-id
+	     		    	 tagged-link-id ...)
+	     unit-id])]{
+The typed version of the Racket @ut:compound-unit/infer form.}
+
+@defform[
+#:literals (import export link)
+(define-compound-unit id
+  (import link-binding ...)
+  (export link-id ...)
+  (link linkage-decl ...))]{
+The typed version of the Racket @ut:define-compound-unit form.}
+
+@defform[
+#:literals (import export link)
+(define-compound-unit/infer id
+  (import link-binding ...)
+  (export infer-link-export ...)
+  (link infer-linkage-decl ...))]{
+The typed version of the Racket @ut:define-compound-unit/infer form.}
+
+@defform[
+#:literals (link)
+(invoke-unit/infer unit-spec)
+#:grammar ([unit-spec 
+	    unit-id
+	    (link link-unit-id ...)])]{
+The typed version of the Racket @ut:invoke-unit/infer form.}
+
+@defform[
+#:literals (export link)
+(define-values/invoke-unit/infer maybe-exports unit-spec)
+#:grammar ([maybe-exports
+	    code:blank
+	    (export sig-sepc ...)]
+	   [unit-spec
+	     unit-id
+	     (link link-unit-id ...)])]{
+The typed version of the Racket @ut:define-values/invoke-unit/infer form. Like
+the @racket[define-values/invoke-unit] form above, this form is only allowed at
+the toplevel of a module.}
+
+@defform[
+(unit-from-context sig-spec)]{
+The typed version of the Racket @ut:unit-from-context form.}
+
+@defform[
+(define-unit-from-context id sig-spec)]{
+The typed version of the Racket @ut:define-unit-from-context form.}
+
+
+@section[#:tag "unit-types"]{Types}
+
+@defform[
+#:literals (import export init-depend Values)
+(Unit 
+  (import sig-id ...)
+  (export sig-id ...)
+  optional-init-depend-clause
+  optional-body-type-clause)
+#:grammar ([optional-init-depend-clause
+             code:blank
+             (init-depend sig-id ...)]
+           [optional-body-type-clause
+             code:blank
+	     type
+	     (Values type ...)])]{
+The type of a unit with the given imports, exports, initialization dependencies,
+and body type. Omitting the init-depend clause is equivalent to an
+@racket[init-depend] clause that contains no signatures. The body type is the
+type of the last expression in the unit's body. If a unit contains only
+definitions and no expressions its body type is @racket[Void]. Omitting the body
+type is equivalent to specifying a body type of @racket[Void].
+
+@ex[(module Unit-Types typed/racket
+      (define-signature fact^ ([fact : (-> Natural Natural)]))
+      (: use-fact@ (Unit (import fact^)
+	       	         (export)
+			 Natural))
+      (define use-fact@ (unit (import fact^) (export) (fact 5))))]
+
+}
+
+@defidform[UnitTop]{
+The supertype of all unit types. Values of this type cannot be linked or invoked.
+The primary use of is for the reflective operation @racket[unit?]}
+
+@section[#:tag "unit-typed/untyped-interactions"]{Interacting with Untyped Code}
+
+@defform/subs[#:link-target? #f
+#:literals (struct)
+(require/typed m rt-clause ...)
+([rt-clause [maybe-renamed t]
+            [#:struct name ([f : t] ...)
+                 struct-option ...]
+            [#:struct (name parent) ([f : t] ...)
+                 struct-option ...]
+            [#:opaque t pred]
+	    [#:signature name ([id : t] ...)]]
+ [maybe-renamed id
+                (orig-id new-id)]
+ [struct-option
+   (code:line #:constructor-name constructor-id)
+   (code:line #:extra-constructor-name constructor-id)])]
+
+
+The @racket[#:signature] clause of @racket[require/typed] requires the given
+signature and registers it in the signature environment with the specified
+bindings. Unlike other identifiers required with @racket[require/typed], signatures
+are not protected by contracts.
+@margin-note{Signatures are not runtime values and therefore do not need to be protected by contracts.}
+
+@ex[
+(module UNTYPED-1 racket
+  (provide a^)  
+  (define-signature a^ (a)))
+
+(module TYPED-1 typed/racket
+  (require/typed 'UNTYPED-1
+                 [#:signature a^ ([a : Integer])])
+  (unit (import a^) (export) (add1 a)))]
+
+
+Typed Racket will infer whether the named signature @racket[extends]
+another signature. It is an error to require a signature that extends a signature
+not present in the signature environment.
+
+@ex[
+(module UNTYPED-2 racket
+  (provide a-sub^)
+  (define-signature a^ (a1))
+  (define-signature a-sub^ extends a^ (a2)))
+
+(eval:error
+ (module TYPED-2 typed/racket
+   (require/typed 'UNTYPED-2
+                  [#:signature a-sub^
+                    ([a1 : Integer]
+                     [a2 : String])])))]
+
+
+Requiring a signature from an untyped module that contains variable definitions is an error
+in Typed Racket.
+
+@ex[
+(module UNTYPED racket
+  (provide bad^)
+  (define-signature bad^ (bad (define-values (bad-ref) (car bad)))))
+
+(eval:error
+ (module TYPED typed/racket
+   (require/typed 'UNTYPED
+                  [#:signature bad^
+                    ([bad : (Pairof Integer Integer)]
+                     [bad-ref : Integer])])))]
+
+
+
+
+
+
+
+
+@section{Limitations}
+
+@subsection{Signature Forms}
+Unlike Racket's @ut:define-signature form, in Typed Racket
+@racket[define-signature] only supports one kind of signature element that
+specifies the types of variables in the signature. In particular Typed Racket's
+@racket[define-signature] form does not support uses of @ut:define-syntaxes,
+@ut:define-values, or @ut:define-values-for-export . Requiring an untyped
+signature that contains definitions in a typed module will result in an error.
+
+@ex[(module UNTYPED racket
+      (provide bad^)
+      (define-signature bad^ ((define-values (bad) 13))))
+    (eval:error
+     (module TYPED typed/racket
+       (require/typed 'UNTYPED
+                      [#:signature bad^ ([bad : Integer])])))]
+
+@subsection{Contracts and Unit Static Information}
+Unit values that flow between typed and untyped contexts are wrapped in
+@racket[unit/c] contracts to guard the unit's imports, exports, and result upon
+invocation. When identifers that are additionally bound to static information
+about a unit, such as those defined by @racket[define-unit], flow between typed
+and untyped contexts contract application can result the static information
+becoming inaccessible.
+
+@ex[
+(module UNTYPED racket
+  (provide u@)
+  (define-unit u@ (import) (export) "Hello!"))
+(eval:error
+ (module TYPED typed/racket
+   (require/typed 'UNTYPED
+                  [u@ (Unit (import) (export) String)])
+   (invoke-unit/infer u@)))]
+
+When an identifier bound to static unit information flows from a typed module to
+an untyped module, however, the situation is worse. Because unit static
+information is bound to an identifier as a macro definition, any use of the
+typed unit is disallowed in untyped contexts.
+
+@ex[
+(module TYPED typed/racket
+  (provide u@)
+  (define-unit u@ (import) (export) "Hello!"))
+(eval:error
+ (module UNTYPED racket
+   (require 'TYPED)
+   u@))]
+
+@subsection{Signatures and Internal Definition Contexts}
+Typed Racket's @racket[define-signature] form is allowed in both top-level and
+internal definition contexts. As the following example shows, defining
+signatures in internal definiition contexts can be problematic.
+
+@ex[
+(eval:error
+ (module TYPED typed/racket
+   (define-signature a^ ())
+   (define u@
+     (let ()
+       (define-signature a^ ())
+       (unit (import a^) (export) (init-depend a^) 5)))
+   (invoke-unit u@ (import a^))))]
+
+  Even though the unit imports a signature named @racket[a^], the @racket[a^]
+provided for the import refers to the top-level @racket[a^] signature and the
+type system prevents invoking the unit. This issue can be avoided by defining
+signatures only at the top-level of a module.
+
+@subsection{Tagged Signatures}
+
+Various unit forms in Racket allow for signatures to be tagged to support the
+definition of units that import or export the same signature multiple times.
+Typed Racket does not support the use of tagged signatures, using the
+@racket[tag] keyword, anywhere in the various unit forms described above.
+
+@subsection{Structural Matching and Other Unit Forms}
+
+Typed Racket supports only those unit forms described above. All other bindings
+exported by @racketmodname[racket/unit] are not supported in the type system. In
+particular, the structural matching forms including @ut:unit/new-import-export
+and @ut:unit/s are unsupported.

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

@@ -2,7 +2,7 @@
 
 @begin[(require "../utils.rkt"
                 "numeric-tower-pict.rkt"
-                scribble/eval
+                scribble/example
                 racket/sandbox)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])
                            racket/async-channel))]
@@ -21,6 +21,8 @@
 
 @defidform[Any]{Any Racket value. All other types are subtypes of @racket[Any].}
 
+@defidform[AnyValues]{Any number of Racket values of any type.}
+
 @defidform[Nothing]{The empty type.  No values inhabit this type, and
 any expression of this type will not evaluate to a value.}
 
@@ -370,7 +372,10 @@ corresponding to @racket[trest], where @racket[bound]
 @defidform[FlVector]{An @rtech{flvector}.
   @ex[(flvector 1.0 2.0 3.0)]}
 @defidform[ExtFlVector]{An @rtech{extflvector}.
-  @ex[(extflvector 1.0t0 2.0t0 3.0t0)]}
+  @ex[(eval:alts (extflvector 1.0t0 2.0t0 3.0t0)
+                 (eval:result @racketresultfont{#<extflvector>}
+                              "- : ExtFlVector"
+                              ""))]}
 @defidform[FxVector]{An @rtech{fxvector}.
   @ex[(fxvector 1 2 3)]}
 
@@ -397,8 +402,11 @@ corresponding to @racket[trest], where @racket[bound]
 @ex[(lambda: ([x : Any]) (if (hash? x) x (error "not a hash table!")))]
 }
 
-@defform[(Setof t)]{is the type of a @rtech{set} of @racket[t].
+@defform[(Setof t)]{is the type of a @rtech{hash set} of
+@racket[t]. This includes custom hash sets, but not mutable hash set
+or sets that are implemented using @racket[gen:set].
 @ex[(set 0 1 2 3)]
+@ex[(seteq 0 1 2 3)]
 }
 
 @defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent.
@@ -560,29 +568,33 @@ functions and continuation mark functions.
 @section{Other Type Constructors}
 
 @defform*/subs[#:id -> #:literals (|@| * ... ! and or implies car cdr)
-               [(-> dom ... rng optional-filter)
+               [(-> dom ... rng opt-proposition)
                 (-> dom ... rest * rng)
                 (-> dom ... rest ooo bound rng)
 
-                (dom ... -> rng optional-filter)
+                (dom ... -> rng opt-proposition)
                 (dom ... rest * -> rng)
                 (dom ... rest ooo bound -> rng)]
                ([ooo #,(racket ...)]
                 [dom type
                      mandatory-kw
-                     optional-kw]
+                     opt-kw]
                 [mandatory-kw (code:line keyword type)]
-                [optional-kw [keyword type]]
-                [optional-filter (code:line)
+                [opt-kw [keyword type]]
+                [opt-proposition (code:line)
                                  (code:line : type)
-                                 (code:line : pos-filter neg-filter object)]
-                [pos-filter (code:line)
-                            (code:line #:+ proposition ...)]
-                [neg-filter (code:line)
-                            (code:line #:- proposition ...)]
+                                 (code:line : pos-proposition
+				              neg-proposition
+					      object)]
+                [pos-proposition (code:line)
+                                 (code:line #:+ proposition ...)]
+                [neg-proposition (code:line)
+                                 (code:line #:- proposition ...)]
                 [object (code:line)
                         (code:line #:object index)]
-                [proposition type
+                [proposition Top
+		             Bot
+			     type
                              (! type)
                              (type |@| path-elem ... index)
                              (! type |@| path-elem ... index)
@@ -596,15 +608,15 @@ functions and continuation mark functions.
   The type of functions from the (possibly-empty)
   sequence @racket[dom ....] to the @racket[rng] type.
 
-  @ex[(λ: ([x : Number]) x)
-      (λ: () 'hello)]
+  @ex[(λ ([x : Number]) x)
+      (λ () 'hello)]
 
   The second form specifies a uniform rest argument of type @racket[rest], and the
   third form specifies a non-uniform rest argument of type
   @racket[rest] with bound @racket[bound]. The bound refers to the type variable
   that is in scope within the rest argument type.
 
-  @ex[(λ: ([x : Number] . [y : String *]) (length y))
+  @ex[(λ ([x : Number] . [y : String *]) (length y))
       ormap]
 
   In the third form, the @racket[...] introduced by @racket[ooo] is literal,
@@ -621,20 +633,24 @@ functions and continuation mark functions.
       (is-zero? 2 #:equality =)
       (is-zero? 2 #:equality eq? #:zero 2.0)]
 
-  When @racket[optional-filter] is provided, it specifies the @emph{filter} for the
-  function type (for an introduction to filters, see @tr-guide-secref["filters-and-predicates"]).
-  For almost all use cases, only the simplest form of filters, with a single type after a
+  When @racket[opt-proposition] is provided, it specifies the
+  @emph{proposition} for the function type (for an introduction to
+  propositions in Typed Racket, see
+  @tr-guide-secref["propositions-and-predicates"]).  For almost all use
+  cases, only the simplest form of propositions, with a single type after a
   @racket[:], are necessary:
 
   @ex[string?]
 
-  The filter specifies that when @racket[(string? x)] evaluates to a true value for
-  a conditional branch, the variable @racket[x] in that branch can be assumed to have
-  type @racket[String]. Likewise, if the expression evaluates to @racket[#f] in a branch,
-  the variable @emph{does not} have type @racket[String].
+  The proposition specifies that when @racket[(string? x)] evaluates to a
+  true value for a conditional branch, the variable @racket[x] in that
+  branch can be assumed to have type @racket[String]. Likewise, if the
+  expression evaluates to @racket[#f] in a branch, the variable
+  @emph{does not} have type @racket[String].
 
-  In some cases, asymmetric type information is useful in filters. For example, the
-  @racket[filter] function's first argument is specified with only a positive filter:
+  In some cases, asymmetric type information is useful in the
+  propositions. For example, the @racket[filter] function's first
+  argument is specified with only a positive proposition:
 
   @ex[filter]
 
@@ -645,7 +661,7 @@ functions and continuation mark functions.
   Conversely, @racket[#:-] specifies that a function provides information for the
   false branch of a conditional.
 
-  The other filter proposition cases are rarely needed, but the grammar documents them
+  The other proposition cases are rarely needed, but the grammar documents them
   for completeness. They correspond to logical operations on the propositions.
 
   The type of functions can also be specified with an @emph{infix} @racket[->]
@@ -687,7 +703,7 @@ functions and continuation mark functions.
 
   @ex[(: +all (->* (Integer) #:rest Integer (Listof Integer)))
       (define (+all inc . rst)
-        (map (λ: ([x : Integer]) (+ x inc)) rst))
+        (map (λ ([x : Integer]) (+ x inc)) rst))
       (+all 20 1 2 3)]
 
   Both the mandatory and optional argument lists may contain keywords paired
@@ -702,9 +718,9 @@ functions and continuation mark functions.
 
 @deftogether[(
 @defidform[Top]
-@defidform[Bot])]{ These are filters that can be used with @racket[->].
-  @racket[Top] is the filter with no information.
-  @racket[Bot] is the filter which means the result cannot happen.
+@defidform[Bot])]{ These are propositions that can be used with @racket[->].
+  @racket[Top] is the propositions with no information.
+  @racket[Bot] is the propositions which means the result cannot happen.
 }
 
 
@@ -720,13 +736,17 @@ functions and continuation mark functions.
   @ex[
     (: my-list Procedure)
     (define my-list list)
-    (my-list "zwiebelkuchen" "socca")
+    (eval:error (my-list "zwiebelkuchen" "socca"))
   ]
 }
 
 
 @defform[(U t ...)]{is the union of the types @racket[t ...].
- @ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]}
+ @ex[(λ ([x : Real]) (if (> 0 x) "yes" 'no))]}
+
+@defform[(∩ t ...)]{is the intersection of the types @racket[t ...].
+ @ex[((λ #:forall (A) ([x : (∩ Symbol A)]) x) 'foo)]}
+
 @defform[(case-> fun-ty ...)]{is a function that behaves like all of
   the @racket[fun-ty]s, considered in order from first to last.  The @racket[fun-ty]s must all be function
   types constructed with @racket[->].

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

@@ -0,0 +1,75 @@
+#lang scribble/manual
+
+@(require scribble/example
+          (for-label (only-meta-in 0 [except-in typed/racket for])))
+
+@(define eval (make-base-eval))
+@(eval '(require typed/racket/base))
+
+@title{Unsafe Typed Racket operations}
+
+@defmodule[typed/racket/unsafe]
+
+@bold{Warning}: the operations documented in this section are @emph{unsafe},
+meaning that they can circumvent the invariants of the type system. Unless the
+@racket[#:no-optimize] language option is used, this may result in unpredictable
+behavior and may even crash Typed Racket.
+
+@defform[(unsafe-require/typed m rt-clause ...)]{
+  This form requires identifiers from the module @racket[m] with the same
+  import specifications as @racket[require/typed].
+
+  Unlike @racket[require/typed], this form is unsafe and will not generate
+  contracts that correspond to the specified types to check that the values
+  actually match their types.
+
+  @examples[#:eval eval
+    (require typed/racket/unsafe)
+    (code:comment "import with a bad type")
+    (unsafe-require/typed racket/base [values (-> String Integer)])
+    (code:comment "unchecked call, the result type is wrong")
+    (values "foo")
+  ]
+
+  @history[#:added "1.3"]
+}
+
+@defform[(unsafe-provide provide-spec ...)]{
+  This form declares exports from a module with the same syntax as
+  the @racket[provide] form.
+
+  Unlike @racket[provide], this form is unsafe and Typed Racket will not generate
+  any contracts that correspond to the specified types. This means that uses of the
+  exports in other modules may circumvent the type system's invariants.
+
+  Additionally, importing an identififer that is exported with
+  @racket[unsafe-provide] into another typed module, and then
+  re-exporting it with @racket[provide] will not cause contracts to be
+  generated.
+
+  Uses of the provided identifiers in other typed modules are not
+  affected by @racket[unsafe-provide]---in these situations it behaves
+  identically to @racket[provide]. Furthermore, other typed modules
+  that @emph{use} a binding that is in an @racket[unsafe-provide] will
+  still have contracts generated as usual.
+
+  @examples[#:eval eval
+    (module t typed/racket/base
+      (require typed/racket/unsafe)
+      (: f (-> Integer Integer))
+      (define (f x) (add1 x))
+      (code:comment "unsafe export, does not install checks")
+      (unsafe-provide f))
+
+    (module u racket/base
+      (require 't)
+      (code:comment "bad call that's unchecked")
+      (f "foo"))
+
+    (eval:error (require 'u))
+  ]
+
+  @history[#:added "1.3"]
+}
+
+@close-eval[eval]

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

@@ -1,6 +1,6 @@
 #lang scribble/manual
 
-@begin[(require "../utils.rkt" scribble/eval racket/sandbox)
+@begin[(require "../utils.rkt" scribble/example racket/sandbox)
        (require (for-label (only-meta-in 0 [except-in typed/racket for])
                            typed/untyped-utils))]
 
@@ -30,7 +30,7 @@ x
 (define: y : (U String Symbol) "hello")
 y
 (assert y string?)
-(assert y boolean?)]
+(eval:error (assert y boolean?))]
 
 @defform*/subs[[(with-asserts ([id maybe-pred] ...) body ...+)]
               ([maybe-pred code:blank
@@ -64,10 +64,11 @@ the error message.
      #`(cond clause ... [else (typecheck-fail #,stx "incomplete coverage"
                                               #:covered-id x)])]))
 
-(define: (f [x  : (U String Integer)]) : Boolean
-  (cond* x
-         [(string? x) #t]
-         [(exact-nonnegative-integer? x) #f]))
+(eval:error
+ (define: (f [x  : (U String Integer)]) : Boolean
+   (cond* x
+          [(string? x) #t]
+          [(exact-nonnegative-integer? x) #f])))
 ]
 
 }

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

@@ -29,11 +29,13 @@ For a friendly introduction, see the companion manual
 @include-section["reference/special-forms.scrbl"]
 @include-section["reference/libraries.scrbl"]
 @include-section["reference/typed-classes.scrbl"]
+@include-section["reference/typed-units.scrbl"]
 @include-section["reference/utilities.scrbl"]
 @include-section["reference/exploring-types.scrbl"]
 @include-section["reference/no-check.scrbl"]
 @include-section["reference/typed-regions.scrbl"]
 @include-section["reference/optimization.scrbl"]
+@include-section["reference/unsafe.scrbl"]
 @include-section["reference/legacy.scrbl"]
 @include-section["reference/compatibility-languages.scrbl"]
 @include-section["reference/experimental.scrbl"]

typed-racket-lib/info.rkt

@@ -2,20 +2,14 @@
 
 (define collection 'multi)
 
-(define deps '(("base" #:version "6.2.900.6")
+(define deps '(("base" #:version "6.4.0.5")
                "pconvert-lib"
-               "unstable-contract-lib"
                "source-syntax"
                "compatibility-lib" ;; to assign types
                "string-constants-lib"))
 
-;; This is needed since the expansion of TR
-;; can insert `(require unstable/contract)` into
-;; the expanded code.
-(define implies '("unstable-contract-lib"))
-
 (define pkg-desc "implementation (no documentation) part of \"typed-racket\"")
 
 (define pkg-authors '(samth stamourv))
 
-(define version "1.1")
+(define version "1.5")

typed-racket-lib/typed-racket/HISTORY.txt

@@ -1,5 +1,24 @@
-(add1 6.2)
+6.5
+- Added `simple-result->` to improve generated contract performance.
+- Improve error message printing.
+- Add `typed/racket/random`.
+- Internal: populate type table unconditionally, for use in tooltips.
+6.4
+- Contract performance improvements, including generating code that
+  the contract system can optimize
+- Make `any-wrap/c` more permissive on opaque structs.
+- Soundly check opaque predicates.
+- Add `#:type-name` option to `struct`.
+6.3
 - Startup time reduction
+- Tightening and cleanup of numeric types
+- Sealing contracts for row polymorphic types
+- `define-new-subtype`
+- More robust compound pair operations optimizations
+- Redesign of top-level support, using trampolining macros
+- Static contract caching more conservative, causes contract generation slowdowns
+- Experimental unit support
+- `typed/racket/unsafe`, with `unsafe-require/typed` and `unsafe-provide`
 6.2
 - Use submodules to avoid allocating contract wrappers when not needed.
 - Class types and contract generation are significantly improved, but still experimental.

typed-racket-lib/typed-racket/base-env/base-env.rkt

@@ -17,7 +17,7 @@
   racket/logging
   racket/private/stx
   (only-in mzscheme make-namespace)
-  (only-in racket/match/runtime match:error matchable? match-equality-test))
+  (only-in racket/match/runtime match:error matchable? match-equality-test syntax-srclocs))
  "base-structs.rkt"
  racket/file
  (only-in racket/private/pre-base new-apply-proc)
@@ -25,6 +25,7 @@
  (only-in (types numeric-tower) [-Number N])
  (only-in (rep type-rep)
           make-ClassTop
+          make-UnitTop
           make-Name
           make-ValuesDots
           make-MPairTop
@@ -65,8 +66,8 @@
 
 ;; Section 4.2.2.7 (Random Numbers)
 [random
-  (cl->* (->opt -PosFixnum [-Pseudo-Random-Generator] -NonNegFixnum)
-         (->opt -Int [-Pseudo-Random-Generator] -Nat)
+  (cl->* (->opt -Int -Int [-Pseudo-Random-Generator] -NonNegFixnum)
+         (->opt -Int [-Pseudo-Random-Generator] -NonNegFixnum)
          (->opt [-Pseudo-Random-Generator] -Flonum))]
 
 [random-seed (-> -PosInt -Void)]
@@ -176,6 +177,11 @@
            #:repeat? Univ #f
            -String)]
 
+[non-empty-string? (make-pred-ty -String)]
+[string-contains? (-> -String -String -Boolean)]
+[string-prefix? (-> -String -String -Boolean)]
+[string-suffix? (-> -String -String -Boolean)]
+
 ;; Section 4.3.6 (racket/format)
 [~a (->optkey []
               #:rest Univ
@@ -631,15 +637,18 @@
 [memq (-poly (a) (-> Univ (-lst a) (-opt (-ne-lst a))))]
 [memv (-poly (a) (-> Univ (-lst a) (-opt (-ne-lst a))))]
 [memf (-poly (a) ((a . -> . Univ) (-lst a) . -> . (-opt (-ne-lst a))))]
-[member (-poly (a)
+[member (-poly (a b)
           (cl->* (Univ (-lst a) . -> . (-opt (-ne-lst a)))
-                 (Univ (-lst a) (-> a a Univ)
+                 (b (-lst a) (-> b a Univ)
                        . -> . (-opt (-ne-lst a)))))]
 [findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))]
 
 [assq  (-poly (a b) (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
 [assv  (-poly (a b) (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
-[assoc (-poly (a b) (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
+[assoc (-poly (a b c)
+              (cl->* (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b)))
+                     (c (-lst (-pair a b)) (-> c a Univ)
+                        . -> . (-opt (-pair a b)))))]
 [assf  (-poly (a b) ((a . -> . Univ) (-lst (-pair a b))
                      . -> . (-opt (-pair a b))))]
 
@@ -668,7 +677,7 @@
                      [((a b c . -> . c) c (-lst a) (-lst b)) c]
                      [((a b c d . -> . d) d (-lst a) (-lst b) (-lst c)) d]))]
 [filter (-poly (a b) (cl->*
-                      ((asym-pred a Univ (-FS (-filter b 0) -top))
+                      ((asym-pred a Univ (-PS (-is-type 0 b) -tt))
                        (-lst a)
                        . -> .
                        (-lst b))
@@ -708,7 +717,7 @@
                    -Index))]
 [partition
  (-poly (a b) (cl->*
-               (-> (asym-pred b Univ (-FS (-filter a 0) -top)) (-lst b) (-values (list (-lst a) (-lst b))))
+               (-> (asym-pred b Univ (-PS (-is-type 0 a) -tt)) (-lst b) (-values (list (-lst a) (-lst b))))
                (-> (-> a Univ) (-lst a) (-values (list (-lst a) (-lst a))))))]
 
 [last   (-poly (a) ((-lst a) . -> . a))]
@@ -726,7 +735,7 @@
  (-poly (a b)
    (cl->*
     (-> (-lst a)
-        (asym-pred a Univ (-FS (-filter b 0) -top))
+        (asym-pred a Univ (-PS (-is-type 0 b) -tt))
         (-lst b))
     (-> (-lst a) (-> a Univ) (-lst a))))]
 [dropf (-poly (a) (-> (-lst a) (-> a Univ) (-lst a)))]
@@ -734,14 +743,14 @@
  (-poly (a b)
    (cl->*
     (-> (-lst a)
-        (asym-pred a Univ (-FS (-filter b 0) -top))
+        (asym-pred a Univ (-PS (-is-type 0 b) -tt))
         (-values (list (-lst b) (-lst a))))
     (-> (-lst a) (-> a Univ) (-values (list (-lst a) (-lst a))))))]
 [takef-right
  (-poly (a b)
    (cl->*
     (-> (-lst a)
-        (asym-pred a Univ (-FS (-filter b 0) -top))
+        (asym-pred a Univ (-PS (-is-type 0 b) -tt))
         (-lst b))
     (-> (-lst a) (-> a Univ) (-lst a))))]
 [dropf-right (-poly (a) (-> (-lst a) (-> a Univ) (-lst a)))]
@@ -749,7 +758,7 @@
  (-poly (a b)
    (cl->*
     (-> (-lst a)
-        (asym-pred a Univ (-FS (-filter b 0) -top))
+        (asym-pred a Univ (-PS (-is-type 0 b) -tt))
         (-values (list (-lst a) (-lst b))))
     (-> (-lst a) (-> a Univ) (-values (list (-lst a) (-lst a))))))]
 
@@ -767,6 +776,14 @@
                      ((-lst b) b) . ->... .(-lst c)))]
 [append*
  (-poly (a) ((-lst (-lst a)) . -> . (-lst a)))]
+[flatten
+ (Univ . -> . (-lst Univ))]
+[combinations (-poly (a) (cl->*
+                          (-> (-lst a) (-lst (-lst a)))
+                          (-> (-lst a) -Nat (-lst (-lst a)))))]
+[in-combinations (-poly (a) (cl->*
+                             (-> (-lst a) (-seq (-lst a)))
+                             (-> (-lst a) -Nat (-seq (-lst a)))))]
 [permutations (-poly (a) (-> (-lst a) (-lst (-lst a))))]
 [in-permutations (-poly (a) (-> (-lst a) (-seq (-lst a))))]
 [argmin (-poly (a) ((a . -> . -Real) (-lst a) . -> . a))]
@@ -836,7 +853,7 @@
                           . ->... .
                           -Index))]
 [vector-filter (-poly (a b) (cl->*
-                              ((asym-pred a Univ (-FS (-filter b 0) -top))
+                              ((asym-pred a Univ (-PS (-is-type 0 b) -tt))
                                (-vec a)
                                . -> .
                                (-vec b))
@@ -870,6 +887,7 @@
                    ((-box a) . -> . a)
                    ((make-BoxTop) . -> . Univ)))]
 [set-box! (-poly (a) ((-box a) a . -> . -Void))]
+[box-cas! (-poly (a) ((-box a) a a . -> . -Boolean))]
 [unsafe-unbox (-poly (a) (cl->*
                           ((-box a) . -> . a)
                           ((make-BoxTop) . -> . Univ)))]
@@ -878,6 +896,7 @@
                            ((-box a) . -> . a)
                            ((make-BoxTop) . -> . Univ)))]
 [unsafe-set-box*! (-poly (a) ((-box a) a . -> . -Void))]
+[unsafe-box*-cas! (-poly (a) ((-box a) a a . -> . -Boolean))]
 [box? (make-pred-ty (make-BoxTop))]
 
 ;; Section 4.13 (Hash Tables)
@@ -951,13 +970,25 @@
 [equal-hash-code (-> Univ -Fixnum)]
 [equal-secondary-hash-code (-> Univ -Fixnum)]
 [hash-iterate-first (-poly (a b)
-                           ((-HT a b) . -> . (Un (-val #f) -Integer)))]
+                           (cl->*
+                            ((-HT a b) . -> . (Un (-val #f) -Integer))
+                            (-> -HashTop (Un (-val #f) -Integer))))]
 [hash-iterate-next (-poly (a b)
-                           ((-HT a b) -Integer . -> . (Un (-val #f) -Integer)))]
+                           (cl->*
+                            ((-HT a b) -Integer . -> . (Un (-val #f) -Integer))
+                            (-> -HashTop -Integer (Un (-val #f) -Integer))))]
 [hash-iterate-key (-poly (a b)
-                           ((-HT a b) -Integer . -> . a))]
+                           (cl->* ((-HT a b) -Integer . -> . a)
+                                  (-> -HashTop -Integer Univ)))]
 [hash-iterate-value (-poly (a b)
-                           ((-HT a b) -Integer . -> . b))]
+                           (cl->* ((-HT a b) -Integer . -> . b)
+                                  (-> -HashTop -Integer Univ)))]
+[hash-iterate-pair (-poly (a b)
+                           (cl->* ((-HT a b) -Integer . -> . (-pair a b))
+                                  (-> -HashTop -Integer Univ)))]
+[hash-iterate-key+value (-poly (a b)
+                           (cl->* ((-HT a b) -Integer . -> . (-values (list a b)))
+                                  (-> -HashTop -Integer (-values (list Univ Univ)))))]
 
 [make-custom-hash (->opt (-> Univ Univ Univ) (-> Univ -Nat) [(-> Univ -Nat)] Univ)]
 [make-immutable-custom-hash (->opt (-> Univ Univ Univ) (-> Univ -Nat) [(-> Univ -Nat)] Univ)]
@@ -1010,7 +1041,7 @@
 [sequence-fold (-poly (a b) ((b a . -> . b) b (-seq a) . -> . b))]
 [sequence-count (-poly (a) ((a . -> . Univ) (-seq a) . -> . -Nat))]
 [sequence-filter (-poly (a b) (cl->*
-                                ((asym-pred a Univ (-FS (-filter b 0) -top))
+                                ((asym-pred a Univ (-PS (-is-type 0 b) -tt))
                                  (-seq a)
                                  . -> .
                                  (-seq b))
@@ -1040,7 +1071,7 @@
 [proper-subset? (-poly (e) (-> (-set e) (-set e) B))]
 [set-map (-poly (e b) (-> (-set e) (-> e b) (-lst b)))]
 [set-for-each (-poly (e b) (-> (-set e) (-> e b) -Void))]
-[generic-set? (asym-pred Univ B (-FS -top (-not-filter (-set Univ) 0)))]
+[generic-set? (asym-pred Univ B (-PS -tt (-not-type 0 (-set Univ))))]
 [set? (make-pred-ty (-set Univ))]
 [set-equal? (-poly (e) (-> (-set e) B))]
 [set-eqv? (-poly (e) (-> (-set e) B))]
@@ -1079,14 +1110,14 @@
 [identity (-poly (a) (->acc (list a) a null))]
 [const (-poly (a) (-> a (->* '() Univ a)))]
 [negate (-polydots (a b c d)
-          (cl->* (-> (-> c Univ : (-FS (-filter a 0) (-not-filter b 0)))
-                     (-> c -Boolean : (-FS (-not-filter b 0) (-filter a 0))))
-                 (-> (-> c Univ : (-FS (-filter a 0) (-filter b 0)))
-                     (-> c -Boolean : (-FS (-filter b 0) (-filter a 0))))
-                 (-> (-> c Univ : (-FS (-not-filter a 0) (-filter b 0)))
-                     (-> c -Boolean : (-FS (-filter b 0) (-not-filter a 0))))
-                 (-> (-> c Univ : (-FS (-not-filter a 0) (-not-filter b 0)))
-                     (-> c -Boolean : (-FS (-not-filter b 0) (-not-filter a 0))))
+          (cl->* (-> (-> c Univ : (-PS (-is-type 0 a) (-not-type 0 b)))
+                     (-> c -Boolean : (-PS (-not-type 0 b) (-is-type 0 a))))
+                 (-> (-> c Univ : (-PS (-is-type 0 a) (-is-type 0 b)))
+                     (-> c -Boolean : (-PS (-is-type 0 b) (-is-type 0 a))))
+                 (-> (-> c Univ : (-PS (-not-type 0 a) (-is-type 0 b)))
+                     (-> c -Boolean : (-PS (-is-type 0 b) (-not-type 0 a))))
+                 (-> (-> c Univ : (-PS (-not-type 0 a) (-not-type 0 b)))
+                     (-> c -Boolean : (-PS (-not-type 0 b) (-not-type 0 a))))
                  (-> ((list) [d d] . ->... . Univ)
                      ((list) [d d] . ->... . -Boolean))))]
 [conjoin (-polydots (a) (->* '() (->... '() (a a) Univ) (->... '() (a a) Univ)))]
@@ -1159,6 +1190,9 @@
 [object-info (-> (-object) (-values (list (Un (make-ClassTop) (-val #f)) -Boolean)))]
 ;; TODO: class-info (is this sound to allow?)
 
+;; Section 7.8 (Unit Utilities)
+[unit? (make-pred-ty (make-UnitTop))]
+
 ;; Section 9.1
 [exn:misc:match? (-> Univ B)]
 ;; this is a hack
@@ -1166,6 +1200,7 @@
 ;[match:error (Univ . -> . (Un))]
 [match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))]
 [matchable? (make-pred-ty (Un -String -Bytes))]
+[syntax-srclocs (Univ . -> . Univ)]
 
 ;; Section 10.1
 [values (-polydots (a b) (cl->*
@@ -1268,7 +1303,7 @@
 [call-with-continuation-barrier (-poly (a) (-> (-> a) a))]
 [continuation-prompt-available? (-> (make-Prompt-TagTop) B)]
 [continuation?
- (asym-pred Univ B (-FS (-filter top-func 0) -top))]
+ (asym-pred Univ B (-PS (-is-type 0 top-func) -tt))]
 [continuation-prompt-tag? (make-pred-ty (make-Prompt-TagTop))]
 [dynamic-wind (-poly (a) (-> (-> ManyUniv) (-> a) (-> ManyUniv) a))]
 
@@ -1389,7 +1424,7 @@
 [never-evt (-evt (Un))]
 [system-idle-evt (-> (-evt -Void))]
 [alarm-evt (-> -Real (-mu x (-evt x)))]
-[handle-evt? (asym-pred Univ B (-FS (-filter (-evt Univ) 0) -top))]
+[handle-evt? (asym-pred Univ B (-PS (-is-type 0 (-evt Univ)) -tt))]
 [current-evt-pseudo-random-generator
  (-Param -Pseudo-Random-Generator -Pseudo-Random-Generator)]
 
@@ -1400,7 +1435,7 @@
 [channel-try-get (-poly (a) ((-channel a) . -> . (Un a (-val #f))))]
 [channel-put (-poly (a) ((-channel a) a . -> . -Void))]
 [channel-put-evt (-poly (a) (-> (-channel a) a (-mu x (-evt x))))]
-[channel-put-evt? (asym-pred Univ B (-FS (-filter (-mu x (-evt x)) 0) -top))]
+[channel-put-evt? (asym-pred Univ B (-PS (-is-type 0 (-mu x (-evt x))) -tt))]
 
 ;; Section 11.2.3 (Semaphores)
 [semaphore? (make-pred-ty -Semaphore)]
@@ -1410,7 +1445,7 @@
 [semaphore-try-wait? (-> -Semaphore B)]
 [semaphore-wait/enable-break (-> -Semaphore -Void)]
 [semaphore-peek-evt (-> -Semaphore (-mu x (-evt x)))]
-[semaphore-peek-evt? (asym-pred Univ B (-FS (-filter (-mu x (-evt x)) 0) -top))]
+[semaphore-peek-evt? (asym-pred Univ B (-PS (-is-type 0 (-mu x (-evt x))) -tt))]
 [call-with-semaphore
  (-polydots (b a)
    (cl->* (->... (list -Semaphore (->... '() [a a] b))
@@ -1506,7 +1541,10 @@
 [syntax-original? (-poly (a) (-> (-Syntax a) B))]
 [syntax-source-module (->opt (-Syntax Univ) [Univ] (Un (-val #f) -Path Sym -Module-Path-Index))]
 [syntax-e (-poly (a) (->acc (list (-Syntax a)) a (list -syntax-e)))]
-[syntax->list (-poly (a) (-> (-Syntax (-lst a)) (-lst a)))]
+[syntax->list (-poly (a)
+                (cl->* (-> (-Syntax (-lst a)) (-lst a))
+                       (-> (-Syntax Univ)
+                           (Un (-val #f) (-lst (-Syntax Univ))))))]
 [syntax->datum (cl->* (-> Any-Syntax -Sexp)
                       (-> (-Syntax Univ) Univ))]
 
@@ -1592,6 +1630,8 @@
           -Nat
           (-opt -Integer)
           (-opt -Integer))))]
+[identifier-binding-symbol
+ (Ident . ->opt . [(Un -Int (-val #f))] -Symbol)]
 
 ;; Section 12.4
 [set!-transformer? (-> Univ B)]
@@ -1668,6 +1708,7 @@
 [syntax-local-lift-expression (-> (-Syntax Univ) (-Syntax Sym))]
 [syntax-local-lift-values-expression (-> -Nat (-Syntax Univ) (-lst (-Syntax Sym)))]
 [syntax-local-lift-context (-> Univ)]
+[syntax-local-lift-module (-> (-Syntax Univ) -Void)]
 [syntax-local-lift-module-end-declaration (-> (-Syntax Univ) -Void)]
 [syntax-local-lift-require (-poly (a) (-> Univ (-Syntax a) (-Syntax a)))]
 [syntax-local-lift-provide (-> Univ -Void)]
@@ -1675,14 +1716,20 @@
 [syntax-local-context (-> (Un (-val 'expression) (-val 'top-level) (-val 'module) (-val 'module-begin) (-lst Univ)))]
 [syntax-local-phase-level (-> -Int)]
 [syntax-local-module-exports (-> -Module-Path (-values (list (-lst Sym) (-lst Sym) (-lst Sym))))]
-[syntax-local-get-shadower (-> (-Syntax Sym) (-Syntax Sym))]
+[syntax-local-submodules (-> (-lst -Symbol))]
+[syntax-local-get-shadower (->opt (-Syntax Sym) [Univ] (-Syntax Sym))]
 [syntax-local-certifier (->opt [B] (-poly (a) (->opt (-Syntax a) [Univ (-opt (-poly (b) (-> (-Syntax b) (-Syntax b))))] (-Syntax a))))]
 [syntax-transforming? (-> B)]
+[syntax-transforming-module-expression? (-> B)]
 
 [syntax-local-identifier-as-binding (-> (-Syntax -Symbol) (-Syntax -Symbol))]
 [syntax-local-introduce (-poly (a) (-> (-Syntax a) (-Syntax a)))]
-[make-syntax-introducer (-> (-poly (a) (-> (-Syntax a) (-Syntax a))))]
-[make-syntax-delta-introducer (->opt (-Syntax Univ) [(-opt (-Syntax Univ)) (-opt -Int)] (-poly (a) (-> (-Syntax a) (-Syntax a))))]
+[make-syntax-introducer
+ (-> (-poly (a) (->opt (-Syntax a) [(one-of/c 'flip 'add 'remove)] (-Syntax a))))]
+[make-syntax-delta-introducer
+ (->opt (-Syntax Univ) (-opt (-Syntax Univ))
+        [(-opt -Int)]
+        (-poly (a) (->opt (-Syntax a) [(one-of/c 'flip 'add 'remove)] (-Syntax a))))]
 
 [syntax-local-transforming-module-provides? (-> B)]
 [syntax-local-module-defined-identifiers (-> (-HT (Un (-val #f) -Int) (-lst (-Syntax Sym))))]
@@ -1743,7 +1790,7 @@
 [file-stream-buffer-mode (cl-> [(-Port) (one-of/c 'none 'line 'block #f)]
                                [(-Port (one-of/c 'none 'line 'block)) -Void])]
 [file-position (cl-> [(-Port) -Nat]
-                     [(-Port -Integer) -Void])]
+                     [(-Port (Un -Integer (-val eof))) -Void])]
 [file-position* (-> -Port (Un -Nat (-val #f)))]
 
 ;; Section 13.1.4
@@ -1802,8 +1849,8 @@
 [port-file-identity (-> (Un -Input-Port -Output-Port) -PosInt)]
 
 ;; Section 13.1.6
-[open-input-string (-> -String -Input-Port)]
-[open-input-bytes (-> -Bytes -Input-Port)]
+[open-input-string (->opt -String [Univ] -Input-Port)]
+[open-input-bytes (->opt -Bytes [Univ] -Input-Port)]
 [open-output-string
  ([Univ] . ->opt . -Output-Port)]
 [open-output-bytes
@@ -1816,7 +1863,7 @@
 
 ;; Section 13.1.7
 [make-pipe
- (cl->* [->opt [N] (-values (list -Input-Port -Output-Port))])]
+ (cl->* [->opt [N Univ Univ] (-values (list -Input-Port -Output-Port))])]
 [pipe-content-length (-> (Un -Input-Port -Output-Port) -Nat)]
 
 ;; Section 13.1.8
@@ -1918,8 +1965,10 @@
 [make-pipe-with-specials (->opt [-Nat Univ Univ] (-values (list -Input-Port -Output-Port)))]
 
 [merge-input (->opt -Input-Port -Input-Port [(-opt -Nat)] -Input-Port)]
-[open-output-nowhere (-> -Output-Port)]
-[peeking-input-port (->opt -Input-Port [Univ -Nat] -Input-Port)]
+[open-output-nowhere (->opt [Univ Univ] -Output-Port)]
+[peeking-input-port (->optkey -Input-Port [Univ -Nat]
+                              #:init-position -Nat #f
+                              -Input-Port)]
 
 [reencode-input-port
  (->opt -Input-Port -String (-opt -Bytes) [Univ Univ Univ (-> -String -Input-Port ManyUniv)] -Input-Port)]
@@ -1927,7 +1976,7 @@
  (->opt -Output-Port -String (-opt -Bytes) [Univ Univ (-opt -Bytes) (-> -String -Output-Port ManyUniv)] -Output-Port)]
 
 [dup-input-port (-Input-Port (B) . ->opt . -Input-Port)]
-[dup-output-port (-Output-Port (B) . ->opt . -Input-Port)]
+[dup-output-port (-Output-Port (B) . ->opt . -Output-Port)]
 
 [relocate-input-port (->opt -Input-Port (-opt -PosInt) (-opt -Nat) -PosInt [Univ] -Input-Port)]
 [relocate-output-port (->opt -Output-Port (-opt -PosInt) (-opt -Nat) -PosInt [Univ] -Output-Port)]
@@ -2061,7 +2110,9 @@
 [write   (Univ [-Output-Port] . ->opt . -Void)]
 [display (Univ [-Output-Port] . ->opt . -Void)]
 [print   (Univ [-Output-Port (one-of/c 0 1)] . ->opt . -Void)]
+[writeln   (Univ [-Output-Port] . ->opt . -Void)]
 [displayln (Univ [-Output-Port] . ->opt . -Void)]
+[println   (Univ [-Output-Port (one-of/c 0 1)] . ->opt . -Void)]
 [fprintf (->* (list -Output-Port -String) Univ -Void)]
 [printf (->* (list -String) Univ -Void)]
 [eprintf (->* (list -String) Univ -Void)]
@@ -2099,7 +2150,7 @@
 [pretty-print (Univ [-Output-Port (one-of/c 0 1)] . ->opt . -Void)]
 [pretty-write (Univ [-Output-Port] . ->opt . -Void)]
 [pretty-display (Univ [-Output-Port] . ->opt . -Void)]
-[pretty-format (Univ [-Nat] . ->opt . -String)]
+[pretty-format (Univ [-Nat] #:mode -Symbol #f . ->optkey . -String)]
 [pretty-print-handler (-> Univ -Void)]
 
 [pretty-print-columns (-Param (Un -Nat (-val 'infinity)) (Un -Nat (-val 'infinity)))]
@@ -2265,7 +2316,7 @@
 [resolved-module-path? (make-pred-ty -Resolved-Module-Path)]
 [make-resolved-module-path (-> (Un -Symbol -Path) -Resolved-Module-Path)]
 [resolved-module-path-name (-> -Resolved-Module-Path (Un -Path -Symbol))]
-[module-path? (asym-pred Univ B (-FS (-filter -Module-Path 0) -top))]
+[module-path? (asym-pred Univ B (-PS (-is-type 0 -Module-Path) -tt))]
 
 [current-module-name-resolver (-Param (cl->* (-Resolved-Module-Path Univ . -> . Univ)
                                              ((Un -Module-Path -Path)
@@ -2449,8 +2500,8 @@
 ;; Section 15.1 (Path Manipulation)
 [path? (make-pred-ty -Path)]
 [path-string? (asym-pred Univ B
-                         (-FS (-filter (Un -Path -String) 0)
-                              (-not-filter -Path 0)))]
+                         (-PS (-is-type 0 (Un -Path -String))
+                              (-not-type 0 -Path)))]
 [path-for-some-system? (make-pred-ty -SomeSystemPath)]
 
 [string->path (-> -String -Path)]
@@ -2515,6 +2566,16 @@
                 (Un -SomeSystemPath (one-of/c 'up 'same))
                 B))))]
 
+[path-replace-extension
+ (cl->*
+  (-> -Pathlike (Un -String -Bytes) -Path)
+  (-> -SomeSystemPathlike (Un -String -Bytes) -SomeSystemPath))]
+
+[path-add-extension
+ (cl->*
+  (-> -Pathlike (Un -String -Bytes) -Path)
+  (-> -SomeSystemPathlike (Un -String -Bytes) -SomeSystemPath))]
+
 [path-replace-suffix
  (cl->*
   (-> -Pathlike (Un -String -Bytes) -Path)
@@ -2589,8 +2650,14 @@
                              -Void)]
 [delete-directory/files (->key -Pathlike #:must-exist? Univ #f -Void)]
 
-[find-files (->optkey (-> -Path Univ) [(-opt -Pathlike)] #:follow-links? Univ #f (-lst -Path))]
-[pathlist-closure (->key (-lst -Pathlike) #:follow-links? Univ #f (-lst -Path))]
+[find-files (->optkey (-> -Path Univ) [(-opt -Pathlike)]
+                      #:skip-filtered-directories? Univ #f
+                      #:follow-links? Univ #f
+                      (-lst -Path))]
+[pathlist-closure (->key (-lst -Pathlike)
+                         #:path-filter (Un (-val #f) (-Path . -> . Univ)) #f
+                         #:follow-links? Univ #f
+                         (-lst -Path))]
 
 [fold-files
  (-poly
@@ -2634,10 +2701,10 @@
 
 [tcp-abandon-port (-Port . -> . -Void)]
 [tcp-addresses (cl->*
-                (-Port [(-val #f)] . ->opt . (-values (list -String -String)))
-                (-Port (-val #t) . -> . (-values (list -String -Index -String -Index))))]
+                ((Un -TCP-Listener -Port) [(-val #f)] . ->opt . (-values (list -String -String)))
+                ((Un -TCP-Listener -Port) (-val #t) . -> . (-values (list -String -Index -String -Index))))]
 
-[tcp-port? (asym-pred Univ B (-FS (-filter (Un -Input-Port -Output-Port) 0) -top))]
+[tcp-port? (asym-pred Univ B (-PS (-is-type 0 (Un -Input-Port -Output-Port)) -tt))]
 
 ;; Section 15.3.2 (racket/udp)
 [udp-open-socket (->opt [(-opt -String) (-opt -String)] -UDP-Socket)]
@@ -2903,6 +2970,7 @@
 ;; Section 15.8
 [system-type
  (cl->*
+  (-> (Un (-val 'unix) (-val 'windows) (-val 'macosx)))
   (-> (-val 'os) (Un (-val 'unix) (-val 'windows) (-val 'macosx)))
   (-> (-val 'gc) (Un (-val 'cgc) (-val '3m)))
   (-> (-val 'link) (Un (-val 'static) (-val 'shared) (-val 'dll) (-val 'framework)))
@@ -2952,7 +3020,9 @@
 [will-try-execute (-> -Will-Executor ManyUniv)]
 
 ;; Section 16.4
-[collect-garbage (-> -Void)]
+[collect-garbage (cl->*
+                  (-> -Void)
+                  (-> (Un (-val 'minor) (-val 'major) (-val 'incremental)) -Void))]
 [current-memory-use (-> -Nat)]
 [dump-memory-stats (-> Univ)]
 
@@ -2993,7 +3063,7 @@
 [assert (-poly (a b) (cl->*
                       (Univ (make-pred-ty (list a) Univ b) . -> . b)
                       (-> (Un a (-val #f)) a)))]
-[defined? (->* (list Univ) -Boolean : (-FS (-not-filter -Undefined 0) (-filter -Undefined 0)))]
+[defined? (->* (list Univ) -Boolean : (-PS (-not-type 0 -Undefined) (-is-type 0 -Undefined)))]
 
 ;; Syntax Manual
 ;; Section 2.1 (syntax/stx)

typed-racket-lib/typed-racket/base-env/base-special-env.rkt

@@ -13,6 +13,7 @@
  (rename-in (types abbrev numeric-tower union) [make-arr* make-arr])
  (for-syntax racket/base syntax/parse
              (only-in racket/syntax syntax-local-eval)))
+(provide make-template-identifier)
 
 (define (make-template-identifier what where)
   (let ([name (module-path-index-resolve (module-path-index-join where #f))])
@@ -45,6 +46,10 @@
          (cl->*
           (-> (-lst a) -Null (-lst a))
           (-> (-lst a) (-lst b) (-lst (Un a b)))))]
+  ;; normalise-inputs
+  [(make-template-identifier 'normalise-inputs 'racket/private/for)
+   (-poly (a)
+          (-> -Symbol -String (-> a -Boolean) (-> a -Nat) a -Nat (Un (-val #f) -Nat) -Nat (-values (list a -Index -Index -Index))))]
   ;; make-sequence
   [(make-template-identifier 'make-sequence 'racket/private/for)
    (-poly (a b)
@@ -111,25 +116,75 @@
   [(make-template-identifier 'in-bytes 'racket/private/for)
    (->opt -Bytes [-Int (-opt -Int) -Int] (-seq -Byte))]
   ;; in-hash and friends
-  [(make-template-identifier 'in-hash 'racket/private/for)
+  [(make-template-identifier 'default-in-hash 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a b)]
                 [(-HashTop) (-seq Univ Univ)]))]
-  [(make-template-identifier 'in-hash-keys 'racket/private/for)
+  [(make-template-identifier 'default-in-hash-keys 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a)]
                 [(-HashTop) (-seq Univ)]))]
-  [(make-template-identifier 'in-hash-values 'racket/private/for)
+  [(make-template-identifier 'default-in-hash-values 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq b)]
                 [(-HashTop) (-seq Univ)]))]
-  [(make-template-identifier 'in-hash-pairs 'racket/private/for)
+  [(make-template-identifier 'default-in-hash-pairs 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq (-pair a b))]
+                [(-HashTop) (-seq (-pair Univ Univ))]))]
+  [(make-template-identifier 'default-in-immutable-hash 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq a b)]
+                [(-HashTop) (-seq Univ Univ)]))]
+  [(make-template-identifier 'default-in-immutable-hash-keys 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq a)]
+                [(-HashTop) (-seq Univ)]))]
+  [(make-template-identifier 'default-in-immutable-hash-values 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq b)]
+                [(-HashTop) (-seq Univ)]))]
+  [(make-template-identifier 'default-in-immutable-hash-pairs 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq (-pair a b))]
+                [(-HashTop) (-seq (-pair Univ Univ))]))]
+  [(make-template-identifier 'default-in-mutable-hash 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq a b)]
+                [(-HashTop) (-seq Univ Univ)]))]
+  [(make-template-identifier 'default-in-mutable-hash-keys 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq a)]
+                [(-HashTop) (-seq Univ)]))]
+  [(make-template-identifier 'default-in-mutable-hash-values 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq b)]
+                [(-HashTop) (-seq Univ)]))]
+  [(make-template-identifier 'default-in-mutable-hash-pairs 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq (-pair a b))]
+                [(-HashTop) (-seq (-pair Univ Univ))]))]
+  [(make-template-identifier 'default-in-weak-hash 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq a b)]
+                [(-HashTop) (-seq Univ Univ)]))]
+  [(make-template-identifier 'default-in-weak-hash-keys 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq a)]
+                [(-HashTop) (-seq Univ)]))]
+  [(make-template-identifier 'default-in-weak-hash-values 'racket/private/for)
+   (-poly (a b)
+          (cl-> [((-HT a b)) (-seq b)]
+                [(-HashTop) (-seq Univ)]))]
+  [(make-template-identifier 'default-in-weak-hash-pairs 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq (-pair a b))]
                 [(-HashTop) (-seq (-pair Univ Univ))]))]
   ;; in-port
   [(make-template-identifier 'in-port 'racket/private/for)
-   (->opt [(-> -Input-Port Univ) -Input-Port] (-seq Univ))]
+   (-poly (a)
+          (cl->* (-> (-seq Univ))
+                 (->opt (-> -Input-Port (Un a (-val eof))) [-Input-Port] (-seq a))))]
   ;; in-input-port-bytes
   [(make-template-identifier 'in-input-port-bytes 'racket/private/for)
    (-> -Input-Port (-seq -Byte))]

typed-racket-lib/typed-racket/base-env/base-structs.rkt

@@ -70,7 +70,10 @@
     ([message : -String] [continuation-marks : -Cont-Mark-Set])
 
     (define-hierarchy exn:break (#:kernel-maker k:exn:break)
-     ([continuation : top-func]))
+     ([continuation : top-func])
+
+     (define-hierarchy exn:break:hang-up (#:kernel-maker k:exn:break:hang-up) ())
+     (define-hierarchy exn:break:terminate (#:kernel-maker k:exn:break:terminate) ()))
 
     (define-hierarchy exn:fail (#:kernel-maker k:exn:fail) ()
 
@@ -81,7 +84,10 @@
         (define-hierarchy exn:fail:contract:continuation (#:kernel-maker k:exn:fail:contract:continuation) ())
         (define-hierarchy exn:fail:contract:variable (#:kernel-maker k:exn:fail:contract:variable) ()))
 
-      (define-hierarchy exn:fail:syntax (#:kernel-maker k:exn:fail:syntax) ([exprs : (-lst Any-Syntax)]))
+      (define-hierarchy exn:fail:syntax (#:kernel-maker k:exn:fail:syntax) ([exprs : (-lst Any-Syntax)])
+        (define-hierarchy exn:fail:syntax:unbound (#:kernel-maker k:exn:fail:syntax:unbound) ())
+        (define-hierarchy exn:fail:syntax:missing-module (#:kernel-maker k:exn:fail:syntax:missing-module)
+          ([path : -Module-Path])))
 
       (define-hierarchy exn:fail:read (#:kernel-maker k:exn:fail:read)
         ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc
@@ -90,9 +96,15 @@
 
       (define-hierarchy exn:fail:filesystem (#:kernel-maker k:exn:fail:filesystem) ()
         (define-hierarchy exn:fail:filesystem:exists (#:kernel-maker k:exn:fail:filesystem:exists) ())
-        (define-hierarchy exn:fail:filesystem:version (#:kernel-maker k:exn:fail:filesystem:version) ()))
+        (define-hierarchy exn:fail:filesystem:version (#:kernel-maker k:exn:fail:filesystem:version) ())
+        (define-hierarchy exn:fail:filesystem:errno (#:kernel-maker k:exn:fail:filesystem:errno)
+          ([errno : (-pair -Integer (one-of/c 'posix 'windows 'gai))]))
+        (define-hierarchy exn:fail:filesystem:missing-module (#:kernel-maker k:exn:fail:filesystem:missing-module)
+          ([path : -Module-Path])))
 
-      (define-hierarchy exn:fail:network (#:kernel-maker k:exn:fail:network) ())
+      (define-hierarchy exn:fail:network (#:kernel-maker k:exn:fail:network) ()
+        (define-hierarchy exn:fail:network:errno (#:kernel-maker k:exn:fail:network:errno)
+          ([errno : (-pair -Integer (one-of/c 'posix 'windows 'gai))])))
 
       (define-hierarchy exn:fail:out-of-memory (#:kernel-maker k:exn:fail:out-of-memory) ())
 

typed-racket-lib/typed-racket/base-env/base-types-extra.rkt

@@ -7,7 +7,12 @@
     [(_ nm ...)
      #'(begin (define-syntax nm
                 (lambda (stx)
-                  (raise-syntax-error 'type-check "type name used out of context"
+                  (raise-syntax-error 'type-check
+                                      (format "type name used out of context\n  type: ~a\n  in: ~a"
+                                              (syntax->datum (if (stx-pair? stx)
+                                                                 (stx-car stx)
+                                                                 stx))
+                                              (syntax->datum stx))
                                       stx
                                       (and (stx-pair? stx) (stx-car stx)))))
               ...
@@ -16,8 +21,9 @@
 ;; special type names that are not bound to particular types
 (define-other-types
   -> ->* case-> U Rec All Opaque Vector
-  Parameterof List List* Class Object Values Instance Refinement
-  pred Struct Struct-Type Prefab Top Bot)
+  Parameterof List List* Class Object Unit Values AnyValues Instance Refinement
+  pred Struct Struct-Type Prefab Top Bot Distinction Sequenceof
+  ∩)
 
 (provide (rename-out [All ∀]
                      [U Un]
@@ -26,4 +32,3 @@
                      [List Tuple]
                      [Rec mu]
                      [Parameterof Parameter]))
-

typed-racket-lib/typed-racket/base-env/base-types.rkt

@@ -126,6 +126,7 @@
 [Continuation-Mark-KeyTop -Continuation-Mark-KeyTop]
 [Struct-TypeTop (make-StructTypeTop)]
 [ClassTop (make-ClassTop)]
+[UnitTop (make-UnitTop)]
 [Keyword -Keyword]
 [Thread -Thread]
 [Resolved-Module-Path -Resolved-Module-Path]
@@ -186,7 +187,6 @@
 [Pairof (-poly (a b) (-pair a b))]
 [MPairof (-poly (a b) (-mpair a b))]
 [MListof (-poly (a) (-mlst a))]
-[Sequenceof (-poly (a) (-seq a))]
 [Thread-Cellof (-poly (a) (-thread-cell a))]
 [Custodian-Boxof (-poly (a) (make-CustodianBox a))]
 

typed-racket-lib/typed-racket/base-env/class-prims.rkt

@@ -282,7 +282,7 @@
       [_ #f]))
 
   ;; clauses->names : (-> Clause Boolean) Listof<Clause> -> Listof<Id>
-  ;; filter clauses by some property and spit out the names in those clauses
+  ;; prop clauses by some property and spit out the names in those clauses
   (define (clauses->names prop clauses [keep-pair? #f])
     (apply append
            (for/list ([clause (in-list clauses)]

typed-racket-lib/typed-racket/base-env/env-lang.rkt

@@ -5,7 +5,7 @@
 (require (for-syntax racket/base syntax/parse)
          (utils tc-utils)
          (env init-envs)
-         (types abbrev numeric-tower union filter-ops))
+         (types abbrev numeric-tower union prop-ops))
 
 (define-syntax (-#%module-begin stx)
   (define-syntax-class clause
@@ -29,4 +29,4 @@
          require
          (except-out (all-from-out racket/base) #%module-begin)
          types rep private utils
-         (types-out abbrev numeric-tower union filter-ops))
+         (types-out abbrev numeric-tower union prop-ops))

typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt

@@ -11,7 +11,7 @@
          (for-syntax racket/base
                      syntax/parse
                      syntax/stx)
-         (for-syntax (types abbrev numeric-tower union filter-ops)))
+         (for-syntax (types abbrev numeric-tower union prop-ops)))
 
 (provide type-environment
          (rename-out [-#%module-begin #%module-begin])
@@ -20,7 +20,7 @@
          (except-out (all-from-out racket/base) #%module-begin)
          (for-syntax (except-out (all-from-out racket/base) #%module-begin))
          types rep private utils
-         (for-syntax (types-out abbrev numeric-tower union filter-ops)))
+         (for-syntax (types-out abbrev numeric-tower union prop-ops)))
 
 ;; syntax classes for type clauses in the type-environment macro
 (begin-for-syntax
@@ -52,7 +52,11 @@
                                    ;;        lift out to utility module maybe
                                    (define-syntax (type stx)
                                      (raise-syntax-error 'type-check
-                                                         "type name used out of context"
+                                                         (format "type name used out of context\n  type: ~a\n  in: ~a"
+                                                                 (syntax->datum (if (stx-pair? stx)
+                                                                                    (stx-car stx)
+                                                                                    stx))
+                                                                 (syntax->datum stx))
                                                          stx
                                                          (and (stx-pair? stx) (stx-car stx))))
                                    (provide type pred))))

typed-racket-lib/typed-racket/base-env/prims-contract.rkt

@@ -19,28 +19,49 @@
 
 (provide require/opaque-type require-typed-struct-legacy require-typed-struct
          require/typed-legacy require/typed require/typed/provide
-         require-typed-struct/provide cast make-predicate define-predicate)
+         require-typed-struct/provide core-cast make-predicate define-predicate
+         require-typed-signature)
 
 (module forms racket/base
   (require (for-syntax racket/lazy-require racket/base))
   (begin-for-syntax 
     (lazy-require [(submod "..")
-                   (require/opaque-type 
+                   (require/opaque-type
+                    require-typed-signature
                     require-typed-struct-legacy
                     require-typed-struct
                     require/typed-legacy require/typed require/typed/provide
-                    require-typed-struct/provide cast make-predicate define-predicate)]))
+                    require-typed-struct/provide core-cast make-predicate define-predicate)]))
   (define-syntax (def stx)
     (syntax-case stx ()
       [(_ id ...)
        (with-syntax ([(names ...) (generate-temporaries #'(id ...))])
          #'(begin (provide (rename-out [names id] ...))
                   (define-syntax (names stx) (id stx)) ...))]))
-  (def require/opaque-type 
+  (def require/opaque-type
+        require-typed-signature
         require-typed-struct-legacy
         require-typed-struct
         require/typed-legacy require/typed require/typed/provide
-        require-typed-struct/provide cast make-predicate define-predicate))
+        require-typed-struct/provide make-predicate define-predicate)
+
+  ;; Expand `cast` to a `core-cast` with an extra `#%expression` in order
+  ;; to prevent the contract generation pass from executing too early
+  ;; (i.e., before the `cast` typechecks)
+  (define-syntax (-core-cast stx) (core-cast stx))
+  (define-syntax (cast stx)
+    (syntax-case stx ()
+      [(_ e ty) (quasisyntax/loc stx (#%expression #,(syntax/loc stx (-core-cast e ty))))]))
+  (provide cast))
+
+;; unsafe operations go in this submodule
+(module* unsafe #f
+  ;; turned into a macro on the requiring side
+  (provide -unsafe-require/typed))
+
+;; used for private unsafe functionality in require macros
+;; *do not export*
+(define-syntax unsafe-kw (syntax-rules ()))
 
 (require (for-template (submod "." forms) "../utils/require-contract.rkt"
                        (submod "../typecheck/internal-forms.rkt" forms)
@@ -60,8 +81,10 @@
          racket/struct-info
          syntax/struct
          syntax/location
+         (for-template "../utils/any-wrap.rkt")
          "../utils/tc-utils.rkt"
          "../private/syntax-properties.rkt"
+         "../private/cast-table.rkt"
          "../typecheck/internal-forms.rkt"
          ;; struct-extraction is actually used at both of these phases
          "../utils/struct-extraction.rkt"
@@ -71,11 +94,9 @@
 
 ;; Lazily loaded b/c they're only used sometimes, so we save a lot
 ;; of loading by not having them when they are unneeded
-(lazy-require ["../rep/type-rep.rkt" (make-Opaque Error?)]
+(lazy-require ["../rep/type-rep.rkt" (Error?)]
               ["../types/utils.rkt" (fv)]
-              [syntax/define (normalize-definition)]
-              [typed-racket/private/parse-type (parse-type)]
-              [typed-racket/env/type-alias-env (register-resolved-type-alias)])
+              [typed-racket/private/parse-type (parse-type)])
 
 (define (with-type* expr ty)
   (with-type #`(ann #,expr #,ty)))
@@ -89,11 +110,12 @@
   (pattern (nm:id parent:id)))
 
 
-(define-values (require/typed-legacy require/typed)
+(define-values (require/typed-legacy require/typed -unsafe-require/typed)
  (let ()
   (define-syntax-class opt-rename
-    #:attributes (nm spec)
+    #:attributes (nm orig-nm spec)
     (pattern nm:id
+             #:with orig-nm #'nm
              #:with spec #'nm)
     (pattern (orig-nm:id internal-nm:id)
              #:with spec #'(orig-nm internal-nm)
@@ -103,23 +125,29 @@
     #:attributes (nm ty)
     (pattern [nm:opt-rename ty]))
 
-  (define-splicing-syntax-class (opt-constructor legacy struct-name)
-   #:attributes (value)
-   (pattern (~seq)
-            #:attr value (if legacy
-                             #`(#:extra-constructor-name
-                                #,(format-id struct-name "make-~a" struct-name))
-                             #'()))
-   (pattern (~seq (~and key (~or #:extra-constructor-name #:constructor-name)) name:id)
-            #:attr value #'(key name)))
+  (define-splicing-syntax-class (struct-opts legacy struct-name)
+     #:attributes (ctor-value type)
+     (pattern (~seq (~optional (~seq (~and key (~or #:extra-constructor-name #:constructor-name))
+                                     name:id))
+                    (~optional (~seq #:type-name type:id) #:defaults ([type struct-name])))
+              #:attr ctor-value (if (attribute key) #'(key name)
+                                    (if legacy
+                                        #`(#:extra-constructor-name
+                                           #,(format-id struct-name "make-~a" struct-name))
+                                        #'()))))
 
   (define-syntax-class (struct-clause legacy)
-    ;#:literals (struct)
-    #:attributes (nm (body 1) (constructor-parts 1))
+    #:attributes (nm type (body 1) (constructor-parts 1))
     (pattern [(~or (~datum struct) #:struct)
               nm:opt-parent (body ...)
-              (~var constructor (opt-constructor legacy #'nm.nm))]
-             #:with (constructor-parts ...) #'constructor.value))
+              (~var opts (struct-opts legacy #'nm.nm))]
+             #:with (constructor-parts ...) #'opts.ctor-value
+             #:attr type #'opts.type))
+
+  (define-syntax-class signature-clause
+    #:literals (:)
+    #:attributes (sig-name [var 1] [type 1])
+    (pattern [#:signature sig-name:id ([var:id : type] ...)]))
 
   (define-syntax-class opaque-clause
     ;#:literals (opaque)
@@ -129,38 +157,63 @@
     (pattern [(~or (~datum opaque) #:opaque) opaque ty:id pred:id #:name-exists]
              #:with opt #'(#:name-exists)))
 
-  (define-syntax-class (clause legacy lib)
+  (define-syntax-class (clause legacy unsafe? lib)
    #:attributes (spec)
    (pattern oc:opaque-clause #:attr spec
      #`(require/opaque-type oc.ty oc.pred #,lib . oc.opt))
    (pattern (~var strc (struct-clause legacy)) #:attr spec
-     #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... #,lib))
+     #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ...
+                             #:type-name strc.type
+                             #,@(if unsafe? #'(unsafe-kw) #'())
+                             #,lib))
+   (pattern sig:signature-clause #:attr spec
+     #`(require-typed-signature sig.sig-name (sig.var ...) (sig.type ...) #,lib))
    (pattern sc:simple-clause #:attr spec
-     #`(require/typed #:internal sc.nm sc.ty #,lib)))
+     #`(require/typed #:internal sc.nm sc.ty #,lib
+                      #,@(if unsafe? #'(unsafe-kw) #'()))))
 
 
-  (define ((r/t-maker legacy) stx)
+  (define ((r/t-maker legacy unsafe?) stx)
     (unless (or (unbox typed-context?) (eq? (syntax-local-context) 'module-begin))
       (raise-syntax-error #f "only allowed in a typed module" stx))
     (syntax-parse stx
-      [(_ lib:expr (~var c (clause legacy #'lib)) ...)
+      [(_ lib:expr (~var c (clause legacy unsafe? #'lib)) ...)
        (when (zero? (syntax-length #'(c ...)))
          (raise-syntax-error #f "at least one specification is required" stx))
        #`(begin c.spec ...)]
-      [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
+      [(_ #:internal nm:opt-rename ty lib
+          (~optional [~seq #:struct-maker parent])
+          (~optional (~and (~seq (~literal unsafe-kw))
+                           (~bind [unsafe? #t]))
+                     #:defaults ([unsafe? #f])))
        (define/with-syntax hidden (generate-temporary #'nm.nm))
        (define/with-syntax sm (if (attribute parent)
                                   #'(#:struct-maker parent)
                                   #'()))
-       ;; define `cnt*` to be fixed up later by the module type-checking
-       (define cnt*
-         (syntax-local-lift-expression
-          (make-contract-def-rhs #'ty #f (attribute parent))))
-       (quasisyntax/loc stx
-         (begin
-           #,(internal #'(require/typed-internal hidden ty . sm))
-           #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))]))
-  (values (r/t-maker #t) (r/t-maker #f))))
+       (cond [(not (attribute unsafe?))
+              ;; define `cnt*` to be fixed up later by the module type-checking
+              (define cnt*
+                (syntax-local-lift-expression
+                 (make-contract-def-rhs #'ty #f (attribute parent))))
+              (quasisyntax/loc stx
+                (begin
+                  ;; register the identifier so that it has a binding (for top-level)
+                  #,@(if (eq? (syntax-local-context) 'top-level)
+                         (list #'(define-syntaxes (hidden) (values)))
+                         null)
+                  #,(internal #'(require/typed-internal hidden ty . sm))
+                  #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))]
+             [else
+              (define/with-syntax hidden2 (generate-temporary #'nm.nm))
+              (quasisyntax/loc stx
+                (begin
+                  (require (only-in lib [nm.orig-nm hidden]))
+                  ;; need this indirection since `hidden` may expand
+                  ;; to a different identifier that TR doesn't know about
+                  #,(ignore #'(define hidden2 hidden))
+                  (rename-without-provide nm.nm hidden2)
+                  #,(internal #'(require/typed-internal hidden2 ty . sm))))])]))
+  (values (r/t-maker #t #f) (r/t-maker #f #f) (r/t-maker #f #t))))
 
 
 (define (require/typed/provide stx)
@@ -207,9 +260,28 @@
 ;;  make-predicate
 ;;  cast
 
-;; Helper to construct syntax for contract definitions
+;; Helpers to construct syntax for contract definitions
+;; make-contract-def-rhs : Type-Stx Boolean Boolean -> Syntax
 (define (make-contract-def-rhs type flat? maker?)
-  (contract-def-property #'#f `#s(contract-def ,type ,flat? ,maker? untyped)))
+  (define contract-def `#s(contract-def ,type ,flat? ,maker? untyped))
+  (contract-def-property #'#f (λ () contract-def)))
+
+;; make-contract-def-rhs/from-typed : Id Boolean Boolean -> Syntax
+(define (make-contract-def-rhs/from-typed id flat? maker?)
+  (contract-def-property
+   #'#f
+   ;; This function should only be called after the type-checking pass has finished.
+   ;; By then `tc/#%expression` will have recognized the `casted-expr` property and
+   ;; will have added the casted expression's original type to the cast-table, so
+   ;; that `(cast-table-ref id)` can get that type here.
+   (λ ()
+     (define type-stx
+       (or (cast-table-ref id)
+           (int-err (string-append
+                     "contract-def-property: thunk called too early\n"
+                     "  This should only be called after the type-checking pass has finished."))))
+     `#s(contract-def ,type-stx ,flat? ,maker? typed))))
+
 
 (define (define-predicate stx)
   (syntax-parse stx
@@ -241,21 +313,21 @@
      #`(#,(external-check-property #'#%expression check-valid-type)
         #,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty)))]))
 
-
-(define (cast stx)
+;; wrapped above in the `forms` submodule
+(define (core-cast stx)
   (syntax-parse stx
     [(_ v:expr ty:expr)
-     (define (apply-contract ctc-expr)
+     (define (apply-contract v ctc-expr pos neg)
        #`(#%expression
           #,(ignore-some/expr
-             #`(let-values (((val) #,(with-type* #'v #'Any)))
+             #`(let-values (((val) #,(with-type* v #'Any)))
                  #,(syntax-property
                     (quasisyntax/loc stx
                       (contract
                        #,ctc-expr
                        val
-                       'cast
-                       'typed-world
+                       '#,pos
+                       '#,neg
                        val
                        (quote-srcloc #,stx)))
                     'feature-profile:TR-dynamic-check #t))
@@ -264,8 +336,13 @@
      (cond [(not (unbox typed-context?)) ; no-check, don't check
             #'v]
            [else
-            (define ctc (syntax-local-lift-expression
-                         (make-contract-def-rhs #'ty #f #f)))
+            (define new-ty-ctc (syntax-local-lift-expression
+                                (make-contract-def-rhs #'ty #f #f)))
+            (define existing-ty-id new-ty-ctc)
+            (define existing-ty-ctc (syntax-local-lift-expression
+                                     (make-contract-def-rhs/from-typed existing-ty-id #f #f)))
+            (define (store-existing-type existing-type)
+              (cast-table-set! existing-ty-id existing-type))
             (define (check-valid-type _)
               (define type (parse-type #'ty))
               (define vars (fv type))
@@ -275,7 +352,12 @@
                  "Type ~a could not be converted to a contract because it contains free variables."
                  type)))
             #`(#,(external-check-property #'#%expression check-valid-type)
-               #,(apply-contract ctc))])]))
+               #,(apply-contract
+                  (apply-contract
+                   #`(#,(casted-expr-property #'#%expression store-existing-type)
+                      v)
+                   existing-ty-ctc 'typed-world 'cast)
+                  new-ty-ctc 'cast 'typed-world))])]))
 
 
 
@@ -283,21 +365,25 @@
   (define-syntax-class name-exists-kw
     (pattern #:name-exists))
   (syntax-parse stx
+    [_ #:when (eq? 'module-begin (syntax-local-context))
+       ;; it would be inconvenient to find the correct #%module-begin here, so we rely on splicing
+       #`(begin #,stx (begin))]
     [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...)
-     ;; This line appears redundant with the use of `define-type-alias` below, but
-     ;; it's actually necessary for top-level uses because this opaque type may appear
-     ;; in subsequent `require/typed` clauses, which needs to parse the types at
-     ;; expansion-time, not at typechecking time when aliases are installed.
-     (register-resolved-type-alias #'ty (make-Opaque #'pred))
      (with-syntax ([hidden (generate-temporary #'pred)])
+       (define pred-cnt
+         (syntax-local-lift-expression
+          (make-contract-def-rhs #'(-> Any Boolean) #f #f)))
        (quasisyntax/loc stx
          (begin
-           #,(ignore #'(define pred-cnt (any/c . c-> . boolean?)))
+           ;; register the identifier for the top-level (see require/typed)
+           #,@(if (eq? (syntax-local-context) 'top-level)
+                  (list #'(define-syntaxes (hidden) (values)))
+                  null)
            #,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred))))
            #,(if (attribute ne)
                  (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred))))
                  (syntax/loc stx (define-type-alias ty (Opaque pred))))
-           #,(ignore #'(require/contract pred hidden pred-cnt lib)))))]))
+           #,(ignore #`(require/contract pred hidden #,pred-cnt lib)))))]))
 
 
 
@@ -342,10 +428,18 @@
    (pattern (~seq #:constructor-name name:id) #:attr extra #f)
    (pattern (~seq #:extra-constructor-name name:id) #:attr extra #t))
 
+  (define-splicing-syntax-class unsafe-clause
+   (pattern (~seq) #:attr unsafe? #f)
+   (pattern (~seq (~literal unsafe-kw)) #:attr unsafe? #t))
 
   (define ((rts legacy) stx)
     (syntax-parse stx #:literals (:)
-      [(_ name:opt-parent ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) lib)
+      [(_ name:opt-parent
+          ([fld : ty] ...)
+          (~var input-maker (constructor-term legacy #'name.nm))
+          (~optional (~seq #:type-name type:id) #:defaults ([type #'name.nm]))
+          unsafe:unsafe-clause
+          lib)
        (with-syntax* ([nm #'name.nm]
                       [parent #'name.parent]
                       [hidden (generate-temporary #'name.nm)]
@@ -421,20 +515,52 @@
                                   (make-struct-info-self-ctor #'internal-maker si)
                                   si))
 
-                         (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only)
-                         #,(ignore #'(require/contract pred hidden (any/c . c-> . boolean?) lib))
-                         #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm)))
-                         (require/typed #:internal (maker-name real-maker) nm lib
-                                        #:struct-maker parent)
+                         (dtsi* () spec type ([fld : ty] ...) #:maker maker-name #:type-only)
+                         #,(ignore #'(require/contract pred hidden (or/c struct-predicate-procedure?/c (c-> any-wrap/c boolean?)) lib))
+                         #,(internal #'(require/typed-internal hidden (Any -> Boolean : type)))
+                         (require/typed #:internal (maker-name real-maker) type lib
+                                        #:struct-maker parent
+                                        #,@(if (attribute unsafe.unsafe?) #'(unsafe-kw) #'()))
 
                          ;This needs to be a different identifier to meet the specifications
                          ;of struct (the id constructor shouldn't expand to it)
                          #,(if (syntax-e #'extra-maker)
-                               #'(require/typed #:internal (maker-name extra-maker) nm lib
-                                                #:struct-maker parent)
+                               #`(require/typed #:internal (maker-name extra-maker) type lib
+                                                #:struct-maker parent
+                                                #,@(if (attribute unsafe.unsafe?) #'(unsafe-kw) #'()))
                                #'(begin))
 
-                         (require/typed lib
-                           [sel (nm -> ty)]) ...)))]))
+                         #,(if (not (free-identifier=? #'nm #'type))
+                               #'(define-syntax type
+                                   (lambda (stx)
+                                     (raise-syntax-error
+                                      'type-check
+                                      (format "type name ~a used out of context in ~a"
+                                              (syntax->datum (if (stx-pair? stx)
+                                                                 (stx-car stx)
+                                                                 stx))
+                                              (syntax->datum stx))
+                                      stx
+                                      (and (stx-pair? stx) (stx-car stx)))))
+                               #'(begin))
+
+                         #,@(if (attribute unsafe.unsafe?)
+                                #'((require/typed #:internal sel (type -> ty) lib unsafe-kw) ...)
+                                #'((require/typed lib [sel (type -> ty)]) ...)))))]))
 
   (values (rts #t) (rts #f))))
+
+(define (require-typed-signature stx)
+  (syntax-parse stx
+    #:literals (:)
+    [(_ sig-name:id (var ...) (type ...) lib)
+     (quasisyntax/loc stx
+       (begin
+         (require (only-in lib sig-name))
+         #,(internal (quasisyntax/loc stx
+                       (define-signature-internal sig-name
+                         #:parent-signature #f
+                         ([var type] ...)
+                         ;; infer parent relationships using the static information
+                         ;; bound to this signature
+                         #:check? #t)))))]))

typed-racket-lib/typed-racket/base-env/prims-struct.rkt

@@ -46,7 +46,7 @@
              (format "field `~a' requires a type annotation"
                      (syntax-e #'fld))
              #:with form 'dummy))
-
+  
   (define-syntax-class struct-name
     #:description "struct name (with optional super-struct name)"
     #:attributes (name super)
@@ -72,16 +72,31 @@
 
   (define-splicing-syntax-class struct-options
     #:description "typed structure type options"
-    #:attributes (guard mutable? transparent? prefab? [prop 1] [prop-val 1])
+    #:attributes (guard mutable? transparent? prefab? cname ecname type untyped
+                  [prop 1] [prop-val 1])
     (pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?)))
                         (~optional (~seq (~and #:transparent transparent?)))
                         (~optional (~seq (~and #:prefab prefab?)))
+                        (~optional (~or (~and (~seq #:constructor-name cname)
+                                              (~bind [ecname #f]))
+                                        (~and (~seq #:extra-constructor-name ecname)
+                                              (~bind [cname #f]))))
+                        (~optional (~seq #:type-name type:id))
                         ;; FIXME: unsound, but relied on in core libraries
                         ;; #:guard ought to be supportable with some work
                         ;; #:property is harder
                         (~optional (~seq #:guard guard:expr))
                         (~seq #:property prop:expr prop-val:expr))
-                   ...)))
+                   ...)
+             #:attr untyped #`(#,@(if (attribute mutable?) #'(#:mutable) #'())
+                               #,@(if (attribute transparent?) #'(#:transparent) #'())
+                               #,@(if (attribute prefab?) #'(#:prefab) #'())
+                               #,@(if (attribute cname) #'(#:constructor-name cname) #'())
+                               #,@(if (attribute ecname) #'(#:extra-constructor-name ecname) #'())
+                               #,@(if (attribute guard) #'(#:guard guard) #'())
+                               #,@(append* (for/list ([prop (in-list (attribute prop))]
+                                                      [prop-val (in-list (attribute prop-val))])
+                                             (list #'#:property prop prop-val))))))
 
   (define-syntax-class dtsi-struct-name
     #:description "struct name (with optional super-struct name)"
@@ -94,13 +109,27 @@
 
 (define-syntax (define-typed-struct/exec stx)
   (syntax-parse stx #:literals (:)
-    [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
+    [(_ nm:struct-name ((~describe "field specification" [fld:optionally-annotated-name]) ...)
+        [proc : proc-ty] (~optional (~seq #:type-name type:id)))
      (with-syntax*
-      ([proc* (with-type* #'proc #'proc-ty)]
+      ([type (or (attribute type) #'nm.name)]
+       [proc* (with-type* #'proc #'proc-ty)]
        [d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...)
                                       #:property prop:procedure proc*)))]
-       [dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))])
-      #'(begin d-s dtsi))]))
+       [stx-err-fun (if (not (free-identifier=? #'nm.name #'type))
+                        (syntax/loc stx
+                          (define-syntax type
+                            (lambda (stx)
+                              (raise-syntax-error
+                               'type-check
+                               (format "type name ~a used out of context in ~a"
+                                       (syntax->datum (if (stx-pair? stx) (stx-car stx) stx))
+                                       (syntax->datum stx))
+                               stx
+                               (and (stx-pair? stx) (stx-car stx))))))
+                        #'(begin))]
+       [dtsi (quasisyntax/loc stx (dtsi/exec* () nm type (fld ...) proc-ty))])
+      #'(begin d-s stx-err-fun dtsi))]))
 
 (define-syntaxes (dtsi* dtsi/exec*)
   (let ()
@@ -121,57 +150,63 @@
 
 
 ;; User-facing macros for defining typed structure types
-(define-syntaxes (define-typed-struct -struct)
-  (values
-   (lambda (stx)
-     (syntax-parse stx
-       [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...)
-           opts:struct-options)
-        (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
-              [cname (second (build-struct-names #'nm.name null #t #t))])
-          (with-syntax ([d-s (ignore-some
-                               (syntax/loc stx (define-struct nm (fs.fld ...) . opts)))]
-                        [dtsi (quasisyntax/loc stx
-                                (dtsi* (vars.vars ...) nm (fs.form ...)
-                                       #:maker #,cname
-                                       #,@mutable?))])
-            (if (eq? (syntax-local-context) 'top-level)
-                ;; Use `eval` at top-level to avoid an unbound id error
-                ;; from dtsi trying to look at the d-s bindings.
-                #'(begin (eval (quote-syntax d-s))
-                         ;; It is important here that the object under the
-                         ;; eval is a quasiquoted literal in order
-                         ;; for #%top-interaction to get the lexical
-                         ;; information for TR's actual #%top-interaction.
-                         ;; This effectively lets us invoke the type-checker
-                         ;; dynamically.
-                         ;;
-                         ;; The quote-syntax is also important because we want
-                         ;; the `dtsi` to have the lexical information from
-                         ;; this module. This ensures that the `dtsi` macro
-                         ;; is actually bound to its definition above.
-                         (eval `(#%top-interaction . ,(quote-syntax dtsi))))
-                #'(begin d-s dtsi))))]))
-   (lambda (stx)
-     (syntax-parse stx
-       [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
-           opts:struct-options)
-        (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
-              [prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())])
-          (with-syntax ([d-s (ignore (quasisyntax/loc stx
-                                       (struct #,@(attribute nm.new-spec) (fs.fld ...)
-                                               . opts)))]
-                        [dtsi (quasisyntax/loc stx
-                                (dtsi* (vars.vars ...)
-                                       nm.old-spec (fs.form ...)
-                                       #,@mutable?
-                                       #,@prefab?))])
-            ;; see comment above
-            (if (eq? (syntax-local-context) 'top-level)
-                #'(begin (eval (quote-syntax d-s))
-                         (eval `(#%top-interaction . ,(quote-syntax dtsi))))
-                #'(begin d-s dtsi))))]))))
+(define-syntax (define-typed-struct stx)
+  (syntax-parse stx
+    [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) opts:struct-options)
+     (quasisyntax/loc stx
+       (-struct #,@#'vars
+                #,@(if (stx-pair? #'nm)
+                       #'nm
+                       (list #'nm))
+                (fs ...)
+                ;; If there's already a (extra) constructor name supplied,
+                ;; then Racket's `define-struct` doesn't define a `make-`
+                ;; constructor either so don't pass anything extra.
+                #,@(if (or (attribute opts.cname)
+                           (attribute opts.ecname))
+                       null
+                       (list #'#:extra-constructor-name
+                             (second (build-struct-names #'nm.name null #t #t))))
+                . opts))]))
 
+(define-syntax (-struct stx)
+  (syntax-parse stx
+    [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
+        opts:struct-options)
+     (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
+           [prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())]
+           [maker (if (attribute opts.cname)
+                      #`(#:maker #,(attribute opts.cname))
+                      #'())]
+           [extra-maker (if (attribute opts.ecname)
+                            #`(#:extra-maker #,(attribute opts.ecname))
+                            #'())])
+       (with-syntax* ([type (or (attribute opts.type) #'nm.name)]
+                      [d-s (ignore (quasisyntax/loc stx
+                                     (struct #,@(attribute nm.new-spec) (fs.fld ...)
+                                       . opts.untyped)))]
+                      [stx-err-fun (if (not (free-identifier=? #'nm.name #'type))
+                                       (syntax/loc stx
+                                         (define-syntax type
+                                           (lambda (stx)
+                                             (raise-syntax-error
+                                              'type-check
+                                              (format "type name ~a used out of context in ~a"
+                                                      (syntax->datum (if (stx-pair? stx)
+                                                                         (stx-car stx)
+                                                                         stx))
+                                                      (syntax->datum stx))
+                                              stx
+                                              (and (stx-pair? stx) (stx-car stx))))))
+                                       #'(begin))]
+                      [dtsi (quasisyntax/loc stx
+                              (dtsi* (vars.vars ...)
+                                     nm.old-spec type (fs.form ...)
+                                     #,@mutable?
+                                     #,@prefab?
+                                     #,@maker
+                                     #,@extra-maker))])
+         #'(begin d-s stx-err-fun dtsi)))]))
 
 ;; this has to live here because it's used below
 (define-syntax (define-type-alias stx)
@@ -200,7 +235,9 @@
        #'(lambda (stx)
            (raise-syntax-error
             'type-check
-            "type name used out of context"
+            (format "type name used out of context\n  type: ~a\n in: ~a"
+                    (syntax->datum (if (stx-pair? stx) (stx-car stx) stx))
+                    (syntax->datum stx))
             stx
             (and (stx-pair? stx) (stx-car stx)))))
      #`(begin
@@ -218,18 +255,10 @@
     (syntax-parse stx
       [(define-new-subtype ty:id (constructor:id rep-ty:expr))
        #:with gen-id (generate-temporary #'ty)
-       #:with stx-err-fun
-       #'(lambda (stx)
-           (raise-syntax-error
-            'type-check
-            "type name used out of context"
-            stx
-            (and (stx-pair? stx) (stx-car stx))))
        #`(begin
+           (define-type-alias ty (Distinction ty gen-id rep-ty))
            #,(ignore
-              #'(begin
-                  (define-syntax ty stx-err-fun)
-                  (define constructor (lambda (x) x))))
+              #'(define constructor (lambda (x) x)))
            #,(internal (syntax/loc stx
                          (define-new-subtype-internal ty (constructor rep-ty) #:gen-id gen-id))))])))
 

typed-racket-lib/typed-racket/base-env/prims.rkt

@@ -145,9 +145,12 @@ the typed racket language.
   (provide (all-from-out "base-contracted.rkt")))
 
 (begin-for-syntax 
+  (require racket/runtime-path
+           (for-syntax racket/base))
+  (define-runtime-module-path-index contract-defs-submod
+    '(submod "." #%contract-defs))
   (require racket/base "../utils/redirect-contract.rkt")
-  (define varref (#%variable-reference))
-  (define mk (make-make-redirect-to-contract varref)))
+  (define mk (make-make-redirect-to-contract contract-defs-submod)))
 
 (define-syntax-rule (def-redirect id ...)
   (begin (define-syntax id (mk (quote-syntax id))) ... (provide id ...)))
@@ -157,11 +160,7 @@ the typed racket language.
 ;; Lazily loaded b/c they're only used sometimes, so we save a lot
 ;; of loading by not having them when they are unneeded
 (begin-for-syntax 
-  (lazy-require ["../rep/type-rep.rkt" (make-Opaque Error?)]
-                ["../types/utils.rkt" (fv)]
-                [syntax/define (normalize-definition)]
-                [typed-racket/private/parse-type (parse-type)]
-                [typed-racket/env/type-alias-env (register-resolved-type-alias)]))
+  (lazy-require [syntax/define (normalize-definition)]))
 
 (define-for-syntax (with-type* expr ty)
   (with-type #`(ann #,expr #,ty)))
@@ -203,7 +202,7 @@ the typed racket language.
   (let ([mk (lambda (form)
               (lambda (stx)
                 (syntax-parse stx
-                  #:context form
+                  #:context (list (syntax-e form) stx)
                   [(_ (bs:optionally-annotated-binding ...) . body)
                    (quasisyntax/loc stx (#,form (bs.binding ...) . body))])))])
     (values (mk #'let) (mk #'let*) (mk #'letrec))))
@@ -481,14 +480,17 @@ the typed racket language.
         clause:for-clauses
         a2:optional-standalone-annotation*
         c ...)
+     (define all-typed? (andmap values (attribute var.ty)))
+     (define for-stx
+       (quasisyntax/loc stx
+         (for/lists (var.ann-name ...)
+             (clause.expand* ... ...)
+           c ...)))
      ((attribute a1.annotate)
       ((attribute a2.annotate)
-       (add-ann
-        (quasisyntax/loc stx
-          (for/lists (var.ann-name ...)
-              (clause.expand* ... ...)
-            c ...))
-        #'(values var.ty ...))))]))
+       (if all-typed?
+           (add-ann for-stx #'(values var.ty ...))
+           for-stx)))]))
 (define-syntax (for*/fold: stx)
   (syntax-parse stx #:literals (:)
     [(_ a1:optional-standalone-annotation*
@@ -496,14 +498,17 @@ the typed racket language.
         clause:for-clauses
         a2:optional-standalone-annotation*
         c ...)
+     (define all-typed? (andmap values (attribute var.ty)))
+     (define for-stx
+       (quasisyntax/loc stx
+         (for/fold ((var.ann-name init) ...)
+             (clause.expand* ... ...)
+           c ...)))
      ((attribute a1.annotate)
       ((attribute a2.annotate)
-       (add-ann
-        (quasisyntax/loc stx
-          (for/fold ((var.ann-name init) ...)
-              (clause.expand* ... ...)
-            c ...))
-        #'(values var.ty ...))))]))
+       (if all-typed?
+           (add-ann for-stx #'(values var.ty ...))
+           for-stx)))]))
 
 (define-for-syntax (define-for/acc:-variant for*? for/folder: for/folder op initial final)
   (lambda (stx)
@@ -806,7 +811,13 @@ the typed racket language.
                    (define i 0)
                    (for (clauses ...)
                      (define v body-expr)
-                     (cond [(unsafe-fx= i 0)  (define new-vs (ann (make-vector n v) T))
+                     ;; can't use `unsafe-fx=` here
+                     ;; if `n` is larger than a fixnum, this is unsafe, and we
+                     ;; don't know whether that's the case until we try creating
+                     ;; the vector
+                     ;; other unsafe ops are after vector allocation, and so are
+                     ;; fine
+                     (cond [(= i 0)  (define new-vs (ann (make-vector n v) T))
                                               (set! vs new-vs)]
                            [else  (unsafe-vector-set! vs i v)])
                      (set! i (unsafe-fx+ i 1))

typed-racket-lib/typed-racket/base-env/signature-prims.rkt

@@ -0,0 +1,108 @@
+#lang racket/base
+
+;; This file implements unit signatures for typed racket
+
+(provide define-signature)
+
+(require "../utils/utils.rkt"
+         "colon.rkt"
+         (for-syntax syntax/parse
+                     racket/base
+                     racket/list
+                     racket/syntax
+                     syntax/kerncase
+                     "../private/syntax-properties.rkt"
+                     (typecheck internal-forms)
+                     syntax/id-table
+                     racket/dict
+                     racket/unit-exptime
+                     (utils tc-utils))
+         (only-in racket/unit
+                  [define-signature untyped-define-signature]
+                  extends)
+         (for-label "colon.rkt")
+         (submod "../typecheck/internal-forms.rkt" forms)
+         (only-in "../../typed/racket/base.rkt" define-type))
+
+(begin-for-syntax 
+  (define-literal-set colon #:for-label (:))
+  
+  ;; TODO: there should be a more extensible way of handling signatures
+  (define-syntax-class signature-forms
+    (pattern (form:def-sig-form ...)))
+  
+  (define-syntax-class def-sig-form
+    #:attributes (internal-form erased)
+    (pattern :sig-var-form
+             #:attr kind 'var)
+    ;; The define-type form is explicitly disallowed until I can figure out how
+    ;; to sensibly support them in signature definitions - dfeltey
+    (pattern :sig-type-form
+             #:fail-when #t "type definitions are not allowed within signature definitions"
+             #:attr kind 'type))
+  
+  (define-syntax-class sig-var-form
+    #:literal-sets (colon)
+    (pattern [name:id : type]
+             #:with internal-form #'(name type)
+             #:with erased #'name))
+
+  ;; Preliminary support for type definitions in signatures
+  ;; The form is allowed in signature definitions, but currently
+  ;; fails on parsing.
+  ;; In the future supporting type definitions inside of signatures
+  ;; would be a worthwhile feature, but their implemention is not obvious
+  (define-syntax-class sig-type-form
+    #:literals (define-type)
+    (pattern (define-type t ty)
+             ;; These attributes are dummy values
+             #:attr internal-form #f
+             #:attr erased #f))
+  
+  (define-splicing-syntax-class extends-form
+    #:literals (extends)
+    (pattern (~seq extends super:id)
+             #:with internal-form #'super
+             #:with extends-id #'super
+             #:attr form #'(extends super))
+    (pattern (~seq)
+             #:with internal-form #'#f
+             #:with extends-id '()
+             #:attr form '())))
+
+
+;; process-signature-forms : (listof syntax?) -> (listof (pairof id id))
+;; Processes the raw syntax of signature forms and returns a list
+;; of pairs representing names and types bound by the signature
+(define-for-syntax (process-signature-forms forms)
+  (for/list ([form (in-list forms)])
+    (syntax-parse form
+      [member:sig-var-form
+       (syntax-e #'member.internal-form)])))
+
+
+;; typed define-signature macro
+;; This expands into the untyped define-signature syntax as well as an
+;; internal form used by TR to register signatures in the signature environment
+;; The `define-signature-internal` form specifies
+;; - the `name` of the signature being defined
+;; - it's parent-signature, or #f if this signature does not extend another signature
+;; - the list of member variables contained in this signature along with their types
+;; - and a boolean flag indicating whether the signature came from an instance of
+;;   require/typed in which case additional checking must occur when the internal
+;;   form is parsed
+(define-syntax (define-signature stx)
+  (syntax-parse stx
+    [(_ sig-name:id super-form:extends-form forms:signature-forms)
+     (define members (process-signature-forms (syntax->list #'forms)))
+     (define erased-members (map car members))
+     #`(begin
+         #,(ignore (quasisyntax/loc stx
+                     (untyped-define-signature sig-name #,@(attribute super-form.form)
+                                               (#,@erased-members))))
+         #,(internal (quasisyntax/loc stx
+                       (define-signature-internal sig-name
+                         #:parent-signature super-form.internal-form
+                         (#,@members)
+                         ;; no need to further check parent information
+                         #:check? #f))))]))

typed-racket-lib/typed-racket/base-env/top-interaction.rkt

@@ -43,13 +43,16 @@
     "../tc-setup.rkt"
     (private parse-type syntax-properties)
     (types utils abbrev printer)
-    (typecheck tc-toplevel tc-app-helper)
+    (typecheck possible-domains typechecker)
     (rep type-rep)
     (utils tc-utils)
+    (for-syntax racket/base syntax/parse)
     (for-template racket/base))
   (provide
     :type-impl :print-type-impl :query-type/args-impl :query-type/result-impl)
 
+  ;; this one doesn't quite fit the pattern of the next three REPL operations, so
+  ;; this one isn't defined with a macro as below
   (define (:type-impl stx)
     (syntax-parse stx
       [(_ (~optional (~and #:verbose verbose-kw)) ty:expr)
@@ -72,59 +75,55 @@
       [form
        (raise-syntax-error #f "must be applied to exactly one argument" #'form)]))
 
+  (define-syntax (define-repl-op stx)
+    (syntax-parse stx
+      [(_ op args to-expand handler err)
+       #'(define (op stx)
+           (syntax-parse stx
+             [args
+              (define result
+                (tc-expr (local-expand to-expand 'expression (list #'module*))))
+              (handler result)]
+             [form
+              (raise-syntax-error #f err #'form)]))]))
+
   ;; TODO what should be done with stx
   ;; Prints the _entire_ type. May be quite large.
-  (define (:print-type-impl stx)
-    (syntax-parse stx
-      [(_ e)
-       (tc-toplevel/full stx #'e
-         (λ (expanded type)
-           #`(displayln
-              #,(if (eq? type 'no-type)
-                    "This form has no type (it does not produce a value)."
-                    (pretty-format-type
-                     (match type
-                       [(tc-result1: t f o) t]
-                       [(tc-results: t) (-values t)]
-                       [(tc-any-results: f) (-AnyValues f)]))))))]
-      [form
-       (raise-syntax-error #f "must be applied to exactly one argument" #'form)]))
+  (define-repl-op :print-type-impl (_ e) #'e
+    (λ (type)
+      #`(displayln
+         #,(pretty-format-type
+            (match type
+              [(tc-result1: t f o) t]
+              [(tc-results: t) (-values t)]
+              [(tc-any-results: f) (-AnyValues f)]))))
+    "must be applied to exactly one argument")
 
   ;; given a function and input types, display the result type
-  (define (:query-type/args-impl stx)
-    (syntax-parse stx
-      [(_ op arg-type ...)
-       (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
-         (tc-toplevel/full
-           stx
-           ;; create a dummy function with the right argument types
-           #`(lambda #,(stx-map type-label-property
-                                #'(dummy-arg ...) #'(arg-type ...))
-               (op dummy-arg ...))
-           (λ (expanded type)
-             #`(display
-                #,(pretty-format-type
-                   (match type
-                     [(tc-result1: (and t (Function: _)) f o) t]))))))]
-      [form
-       (raise-syntax-error #f "must be applied to at least one argument" #'form)]))
+  (define-repl-op :query-type/args-impl (_ op arg-type ...)
+    (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
+      ;; create a dummy function with the right argument types
+      #`(lambda #,(stx-map type-label-property
+                           #'(dummy-arg ...) #'(arg-type ...))
+                (op dummy-arg ...)))
+     (λ (type)
+       #`(display
+          #,(pretty-format-type
+             (match type
+               [(tc-result1: (and t (Function: _)) f o) t]))))
+     "must be applied to at least one argument" )
 
   ;; given a function and a desired return type, fill in the blanks
-  (define (:query-type/result-impl stx)
-    (syntax-parse stx
-      [(_ op desired-type)
-       (let ([expected (parse-type #'desired-type)])
-         (tc-toplevel/full stx #'op
-           (λ (expanded type)
-             (match type
-               [(tc-result1: (and t (Function: _)) f o)
-                (let ([cleaned (cleanup-type t expected #f)])
-                  #`(display
-                     #,(match cleaned
-                         [(Function: '())
-                          "Desired return type not in the given function's range.\n"]
-                         [(Function: arrs)
-                          (pretty-format-type cleaned)])))]
-               [_ (error (format "~a: not a function" (syntax->datum #'op)))]))))]
-      [form
-       (raise-syntax-error #f "must be applied to exactly two arguments" #'form)])))
+  (define-repl-op :query-type/result-impl (_ op desired-type) #'op
+    (λ (type)
+      (match type
+        [(tc-result1: (and t (Function: _)) f o)
+         (let ([cleaned (cleanup-type t (parse-type #'desired-type) #f)])
+           #`(display
+              #,(match cleaned
+                  [(Function: '())
+                   "Desired return type not in the given function's range.\n"]
+                  [(Function: arrs)
+                   (pretty-format-type cleaned)])))]
+        [_ (error (format "~a: not a function" (syntax->datum #'op)))]))
+    "must be applied to exactly two arguments"))

typed-racket-lib/typed-racket/base-env/type-env-lang.rkt

@@ -9,7 +9,10 @@
         (begin
           (define-syntax (nm stx)
             (raise-syntax-error
-             'type-check "type name used out of context"
+             'type-check
+             (format "type name used out of context\n  type: ~a\n  in: ~a"
+                     (syntax->datum (if (stx-pair? stx) (stx-car stx) stx))
+                     (syntax->datum stx))
              stx
              (and (stx-pair? stx) (stx-car stx))))
           ...

typed-racket-lib/typed-racket/base-env/unit-prims.rkt

@@ -0,0 +1,492 @@
+#lang racket/base
+
+;; Primitive forms for units/signatures
+
+(provide unit
+         define-unit
+         compound-unit 
+         define-compound-unit
+         compound-unit/infer
+         define-compound-unit/infer
+         invoke-unit
+         invoke-unit/infer
+         define-values/invoke-unit
+         define-values/invoke-unit/infer
+         unit-from-context
+         define-unit-from-context)
+
+
+(require  "../utils/utils.rkt"
+          "colon.rkt"
+          (for-syntax syntax/parse
+                      racket/base
+                      racket/list
+                      racket/match
+                      racket/syntax
+                      racket/sequence
+                      syntax/context
+                      syntax/flatten-begin
+                      syntax/kerncase
+                      "../private/syntax-properties.rkt"
+                      (typecheck internal-forms)
+                      syntax/id-table
+                      racket/dict
+                      racket/unit-exptime
+                      syntax/strip-context
+                      (utils tc-utils)
+                      syntax/id-table
+                      syntax/id-set)
+          (prefix-in untyped- (only-in racket/unit
+                                       define-signature
+                                       unit
+                                       invoke-unit
+                                       invoke-unit/infer
+                                       compound-unit
+                                       define-unit
+                                       define-compound-unit
+                                       define-values/invoke-unit
+                                       define-values/invoke-unit/infer
+                                       compound-unit/infer
+                                       define-compound-unit/infer
+                                       unit-from-context
+                                       define-unit-from-context))
+          (only-in racket/unit
+                   extends
+                   import
+                   export
+                   init-depend
+                   link
+                   prefix
+                   rename)
+          "base-types.rkt"
+          "base-types-extra.rkt"
+          (for-label "colon.rkt")
+          (for-template (rep type-rep))
+          (submod "../typecheck/internal-forms.rkt" forms))
+
+(begin-for-syntax
+  (define-literal-set colon #:for-label (:))
+
+  ;; process-definition-form handles all of the `define-` style unit macros
+  ;; such as define-unit, define-compound-unit, define-unit-from-context. but
+  ;; not the corresponding unit, compound-unit, etc forms
+  ;; Performs local expansion in order to apply a syntax property to the
+  ;; subexpression of the `define-*` form correpsonding to the body of the
+  ;; definition being created
+  ;; - eg for a define-unit form, a syntax property will be attached to the
+  ;;   subexpression that creates the unit
+  (define (process-definition-form apply-property stx)
+    (define exp-stx (local-expand stx (syntax-local-context) (kernel-form-identifier-list)))
+    (syntax-parse exp-stx
+      #:literal-sets (kernel-literals)
+      [(begin e ...)
+       (quasisyntax/loc stx
+         (begin #,@(map (λ (e) (process-definition-form apply-property e))
+                        (syntax->list #'(e ...)))))]
+      [(define-values (name ...) rhs)
+       (quasisyntax/loc stx (define-values (name ...) #,(ignore (apply-property #'rhs))))]
+      ;; define-syntaxes that actually create the binding given in the
+      ;; `define-*` macro will fall through to this case, and should be left as-is
+      [_ exp-stx]))
+
+
+  (define-splicing-syntax-class init-depend-form
+    #:literals (init-depend)
+    (pattern (~and this-syntax (init-depend sig:id ...))
+             #:attr form (list #'this-syntax)
+             #:with names #'(sig ...))
+    (pattern (~seq)
+             #:attr form '()
+             #:with names #'()))
+  
+  ;; The `rename` attribute in the sig-spec syntax class is used to correctly
+  ;; map names of signature bound variables in unit bodies to their names in
+  ;; the fully expanded syntax. It applies prefixes and renamings from
+  ;; signature specifications to identifiers.
+  (define-syntax-class sig-spec
+    #:literals (prefix rename)
+    (pattern sig-id:id
+             #:attr rename (lambda (id) id)
+             #:with sig-name #'sig-id)
+    (pattern (prefix p:id sig:sig-spec)
+             #:attr rename (lambda (id) (format-id #'sig.sig-name
+                                                 "~a~a"
+                                                 #'p
+                                                 ((attribute sig.rename) id)))
+             #:with sig-name #'sig.sig-name)
+    (pattern (rename sig:sig-spec (new:id old:id) ...)
+             #:attr rename 
+             (lambda (id)
+               (define (lookup id)
+                 (for/first ([old-id (in-syntax #'(old ...))]
+                             [new-id (in-syntax #'(new ...))]
+                             #:when (free-identifier=? id old-id))
+                   new-id))
+               (define rn ((attribute sig.rename) id))
+               (or (lookup rn) rn))
+             #:with sig-name #'sig.sig-name)))
+
+
+;; imports/members : identifier? -> syntax?
+;; given an identifier bound to a signature
+;; returns syntax containing the signature name and the names of each variable contained
+;; in the signature, this is needed to typecheck define-values/invoke-unit forms
+(define-for-syntax (imports/members sig-id)
+  (define-values (_1 imp-mem _2 _3) (signature-members sig-id sig-id))
+  #`(#,sig-id #,@(map (lambda (id)
+                        (local-expand
+                         id
+                         (syntax-local-context)
+                         (kernel-form-identifier-list)))
+                      imp-mem)))
+
+;; Given a list of signature specs
+;; Processes each signature spec to determine the variables exported
+;; and produces syntax containing the signature id and the exported variables
+(define-for-syntax (process-dv-exports es)
+  (for/list ([e (in-list es)])
+    (syntax-parse e
+      [s:sig-spec
+       (define sig-id #'s.sig-name)
+       (define renamer (attribute s.rename))
+       (define-values (_1 ex-mem _2 _3) (signature-members sig-id sig-id))
+       #`(#,sig-id #,@(map renamer ex-mem))])))
+
+;; Typed macro for define-values/invoke-unit
+;; This has to be handled specially because the types of
+;; the defined values must be registered in the environment
+(define-syntax (define-values/invoke-unit stx)
+  (syntax-parse stx 
+    #:literals (import export)
+    [(_ unit-expr
+        (import isig:sig-spec ...)
+        (export esig:sig-spec ...))
+     (define imports-stx (syntax->list #'(isig.sig-name ...)))
+     (define exports-stx (syntax->list #'(esig ...)))
+     (define/with-syntax temp (syntax-local-introduce (generate-temporary)))
+     #`(begin
+         #,(internal (quasisyntax/loc stx
+                       (define-values/invoke-unit-internal
+                         (#,@(map imports/members imports-stx))
+                         (#,@(process-dv-exports exports-stx)))))
+         (: temp (Unit (import isig.sig-name ...)
+                       (export esig.sig-name ...)
+                       (init-depend isig.sig-name ...)
+                       AnyValues))
+         (define temp unit-expr)
+         #,(ignore (quasisyntax/loc stx
+                     (untyped-define-values/invoke-unit unit-expr
+                                                        (import isig ...)
+                                                        (export esig ...)))))]))
+(begin-for-syntax
+  ;; flat signatures allow easy comparisons of whether one
+  ;; such flat-signature implements another
+  ;; - name is the identifier corresponding to the signatures name
+  ;; - implements is a free-id-set of this signature and all its ancestors
+  ;; flat-signatures enable a comparison of whether one signature implements
+  ;; another as a subset comparison on their contained sets of parent signatures
+  (struct flat-signature (name implements) #:transparent)
+
+  ;; implements? : flat-signature? flat-signature? -> Boolean
+  ;; true iff signature sig1 implements signature sig2
+  (define (implements? sig1 sig2)
+    (match* (sig1 sig2)
+      [((flat-signature name1 impls1) (flat-signature name2 impls2))
+       (free-id-subset? impls2 impls1)]))
+
+  ;; Given: a list of identifiers bound to static unit information
+  ;; Returns: two lists
+  ;; 1. A list of flat-signatures representing the signatures imported by
+  ;;    the given units
+  ;; 2. A list of flat-signatures representing the signatures exported by
+  ;;    the given units
+  (define (get-imports/exports unit-ids)
+    (define-values (imports exports) 
+      (for/fold ([imports null]
+                 [exports null])
+                ([unit-id (in-list unit-ids)])
+        (match-define-values ((list (cons _ new-imports) ...)
+                              (list (cons _ new-exports) ...))
+                             (unit-static-signatures unit-id unit-id))
+        (values (append imports new-imports) (append exports new-exports))))
+    (values (map make-flat-signature imports)
+            (map make-flat-signature exports)))
+
+  ;; Given the id of a signature, return a corresponding flat-signature
+  (define (make-flat-signature sig-name)
+    (flat-signature sig-name (get-signature-ancestors sig-name)))
+
+  ;; Walk the chain of parent signatures to build a list, and convert it to
+  ;; a free-id-set
+  (define (get-signature-ancestors sig)
+    (immutable-free-id-set
+     (with-handlers ([exn:fail:syntax? (λ (e) null)])
+       (let loop ([sig sig] [ancestors null])
+         (define-values (parent _1 _2 _3) (signature-members sig sig)) 
+         (if parent
+             (loop parent (cons sig ancestors))
+             (cons sig ancestors))))))
+  
+  ;; Calculate the set of inferred imports for a list of units
+  ;; The inferred imports are those which are not provided as
+  ;; exports from any of the units taking signature subtyping into account
+  (define (infer-imports unit-ids)
+    (define-values (imports exports) (get-imports/exports unit-ids))
+    (define remaining-imports (remove* exports imports implements?))
+    (map flat-signature-name remaining-imports))
+
+  ;; infer-exports returns all the exports from linked
+  ;; units rather than just those that are not also
+  ;; imported
+  (define (infer-exports unit-ids)
+    (define-values (imports exports) (get-imports/exports unit-ids))
+    (map flat-signature-name exports))
+
+  (define-splicing-syntax-class maybe-exports
+    #:literals (export)
+    (pattern (~seq)
+             #:attr exports #f)
+    (pattern (export sig:id ...)
+             #:attr exports (syntax->list #'(sig ...))))
+  
+  (define-syntax-class dviu/infer-unit-spec
+    #:literals (link)
+    (pattern unit-id:id
+             #:attr unit-ids (list #'unit-id))
+    (pattern (link uid-inits:id ...)
+             #:attr unit-ids (syntax->list #'(uid-inits ...)))))
+
+;; Note: This may not correctly handle all use cases of
+;; define-values/invoke-unit/infer
+;; inferred imports and exports are handled in the following way
+;; - the exports of ALL units being linked are added to the export list
+;;   to be registered in tc-toplevel, this appears to be how exports are treated
+;;   by the unit inference process
+;; - inferred imports are those imports which are not provided by
+;;   any of the exports
+;; This seems to correctly handle both recursive and non-recursive
+;; linking patterns
+(define-syntax (define-values/invoke-unit/infer stx)
+  (syntax-parse stx
+    [(_ exports:maybe-exports us:dviu/infer-unit-spec)
+     (define inferred-imports (infer-imports (attribute us.unit-ids)))
+     (define inferred-exports (or (attribute exports.exports)
+                                  (infer-exports (attribute us.unit-ids))))
+     #`(begin
+         #,(internal (quasisyntax/loc stx
+                       (define-values/invoke-unit-internal
+                         (#,@(map imports/members inferred-imports))
+                         (#,@(process-dv-exports inferred-exports)))))
+         #,(ignore
+            (quasisyntax/loc stx (untyped-define-values/invoke-unit/infer #,@#'exports us))))]))
+
+(define-syntax (invoke-unit/infer stx)
+  (syntax-parse stx 
+    [(_ . rest)
+     (ignore
+      (tr:unit:invoke-property
+       (quasisyntax/loc stx (untyped-invoke-unit/infer . rest)) 'infer))]))
+
+;; The typed invoke-unit macro must attach a syntax property to the expression
+;; being invoked in order to reliably find it during typechecking.
+;; Otherwise the expanded syntax may be confused for that of invoke-unit/infer
+;; and be typechecked incorrectly
+(define-syntax (invoke-unit stx)
+  (syntax-parse stx
+    [(invoke-unit expr . rest)
+     (ignore
+      (tr:unit:invoke-property
+       (quasisyntax/loc stx
+         (untyped-invoke-unit
+          #,(tr:unit:invoke:expr-property #'expr #t)
+          . rest)) #t))]))
+
+;; Trampolining macro that cooperates with the unit macro in order
+;; to add information needed for typechecking units
+;; Essentially head expands each expression in the body of a unit
+;;  - leaves define-syntaxes forms alone, to allow for macro definitions in unit bodies
+;;  - Inserts syntax into define-values forms that allow mapping the names of definitions
+;;    to their bodies during type checking
+;;  - Also specially handles type annotations in order to correctly associate variables
+;;    with their types
+;;  - All other expressions are marked as 'expr for typechecking
+(define-syntax (add-tags stx)
+  (syntax-parse stx
+    [(_ e)
+     (define exp-e (local-expand #'e (syntax-local-context) (kernel-form-identifier-list)))
+     (syntax-parse exp-e
+       #:literals (begin define-values define-syntaxes :)
+       [(begin b ...)
+        #'(add-tags b ...)]
+       [(define-syntaxes (name:id ...) rhs:expr)
+        exp-e]
+       ;; Annotations must be handled specially
+       ;; Exported variables are renamed internally in units, which leads
+       ;; to them not being correctly associated with their type annotations
+       ;; This extra bit of inserted syntax allows the typechecker to
+       ;; properly associate all annotated variables with their types.
+       ;; The inserted lambda expression will be expanded to the internal
+       ;; name of the variable being annotated, this internal name
+       ;; can then be associated with the type annotation during typechecking
+       [(define-values () (colon-helper (: name:id type) rest ...))
+        (quasisyntax/loc stx
+          (define-values ()
+            #,(tr:unit:body-exp-def-type-property
+               #`(#%expression
+                  (begin (void (lambda () name))
+                         (colon-helper (: name type) rest ...)))
+               'def/type)))]
+       [(define-values (name:id ...) rhs)
+        (quasisyntax/loc stx
+          (define-values (name ...)
+            #,(tr:unit:body-exp-def-type-property
+               #'(#%expression
+                  (begin
+                    (void (lambda () name ... (void)))
+                    rhs))
+               'def/type)))]
+       [_
+        (tr:unit:body-exp-def-type-property exp-e 'expr)])]
+    [(_ e ...)
+     #'(begin (add-tags e) ...)]))
+
+(define-syntax (unit stx)
+  (syntax-parse stx
+    #:literals (import export)
+    [(unit imports exports init-depends:init-depend-form e ...)
+     (ignore
+      (tr:unit
+       (quasisyntax/loc stx
+         (untyped-unit
+          imports
+          exports
+          #,@(attribute init-depends.form)
+          (add-tags e ...)))))]))
+
+(define-syntax (define-unit stx)
+  (syntax-parse stx
+    #:literals (import export)
+    [(define-unit uid:id
+       imports
+       exports
+       init-depends:init-depend-form
+       e ...)
+     (process-definition-form
+      (λ (stx) (tr:unit stx))
+      (quasisyntax/loc stx
+        (untyped-define-unit uid
+          imports
+          exports
+          #,@(attribute init-depends.form)
+          (add-tags e ...))))]))
+
+(begin-for-syntax
+  (define-syntax-class compound-imports
+    #:literals (import)
+    (pattern (import lb:link-binding ...)
+             #:attr import-tags (syntax->list #'(lb.link-id ...))))
+  (define-syntax-class compound-links
+    #:literals (link)
+    (pattern (link ld:linkage-decl ...)
+             #:attr all-export-links (map syntax->list (syntax->list #'(ld.exported-keys ...)))
+             #:attr all-import-links (map syntax->list (syntax->list #'(ld.imported-keys ...)))))
+  (define-syntax-class linkage-decl
+    (pattern ((lb:link-binding ...)
+              unit-expr:expr
+              link-id:id ...)
+             #:attr exported-keys #'(lb.link-id ...)
+             #:with imported-keys #'(link-id ...)))
+  (define-syntax-class link-binding
+    (pattern (link-id:id : sig-id:id)))
+
+  ;; build-compound-unit-prop : (listof id) (listof (listof id?)) (listof id?)
+  ;;                         -> (list (listof symbol?) 
+  ;;                                  (listof (listof symbol?))
+  ;;                                  (listof (listof symbol?)))
+  ;; Process the link bindings of a compound-unit form
+  ;; to return a syntax property used for typechecking compound-unit forms
+  ;; The return value is a list to be attached as a syntax property to compound-unit
+  ;; forms.
+  ;; The list contains 3 elements
+  ;; - The first element is a list of symbols corresponding to the link-ids of
+  ;;   the compound-unit's imports
+  ;; - The second element is a list of lists of symbols, corresponding to the
+  ;;   link-ids exported by units in the compound-unit's linking clause
+  ;; - The last element is also a list of lists of symbols, corresponding to the
+  ;;   link-ids being imported by units in the compound-unit's linking clause
+  (define (build-compound-unit-prop import-tags all-import-links all-export-links)
+    (define table
+      (make-immutable-free-id-table
+       (for/list ([link (in-list (append import-tags (flatten all-export-links)))])
+         (cons link (gensym (syntax-e link))))))
+    (define imports-tags
+      (map (λ (id) (free-id-table-ref table id #f)) import-tags))
+    (define units-exports
+      (map
+       (λ (lst) (map (λ (id) (free-id-table-ref table id #f)) lst))
+       all-export-links))
+    (define units-imports
+      (for/list ([unit-links (in-list all-import-links)])
+        (for/list ([unit-link (in-list unit-links)])
+          (free-id-table-ref table unit-link #f))))
+    (list imports-tags units-exports units-imports)))
+
+(define-syntax (compound-unit stx)
+  (syntax-parse stx
+    [(_ imports:compound-imports
+        exports
+        links:compound-links)
+     (define import-tags (attribute imports.import-tags))
+     (define all-import-links (attribute links.all-import-links))
+     (define all-export-links (attribute links.all-export-links))
+     (define prop (build-compound-unit-prop import-tags all-import-links all-export-links))
+     (ignore (tr:unit:compound-property
+              (quasisyntax/loc stx (untyped-compound-unit imports exports links))
+              prop))]))
+
+(define-syntax (define-compound-unit stx)
+  (syntax-parse stx
+    [(_ uid 
+        imports:compound-imports
+        exports
+        links:compound-links)
+     (define import-tags (attribute imports.import-tags))
+     (define all-import-links (attribute links.all-import-links))
+     (define all-export-links (attribute links.all-export-links))
+     (define prop (build-compound-unit-prop import-tags all-import-links all-export-links))
+     (process-definition-form
+      (λ (stx) (tr:unit:compound-property stx prop))
+      (quasisyntax/loc stx
+        (untyped-define-compound-unit uid imports exports links)))]))
+
+(define-syntax (compound-unit/infer stx)
+  (syntax-parse stx
+    #:literals (import export link)
+    [(_ . rest)
+     (ignore
+      (tr:unit:compound-property
+       (quasisyntax/loc stx
+         (untyped-compound-unit/infer . rest))
+       'infer))]))
+
+(define-syntax (define-compound-unit/infer stx)
+  (syntax-parse stx
+    [(_ . rest)
+     (process-definition-form 
+      (λ (stx) (tr:unit:compound-property stx'infer))
+      (quasisyntax/loc stx (untyped-define-compound-unit/infer . rest)))]))
+
+(define-syntax (unit-from-context stx)
+  (syntax-parse stx
+    [(_ . rest)
+     (ignore
+      (tr:unit:from-context
+       (quasisyntax/loc stx
+         (untyped-unit-from-context . rest))))]))
+
+(define-syntax (define-unit-from-context stx)
+  (syntax-parse stx
+    [(_ . rest)
+     (process-definition-form
+      (λ (stx) (tr:unit:from-context stx))
+      (quasisyntax/loc stx (untyped-define-unit-from-context . rest)))]))

typed-racket-lib/typed-racket/core.rkt

@@ -39,7 +39,8 @@
                        (do-time "Fixed contract ids"))]
               ;; add the real definitions of contracts on the before- and after-code
               [(before-code ...) (change-provide-fixups (flatten-all-begins pre-before-code))]
-              [(after-code ...) (change-provide-fixups (flatten-all-begins pre-after-code))]
+              [(after-code ...) (begin0 (change-provide-fixups (flatten-all-begins pre-after-code))
+                                  (do-time "Generated contracts"))]
               ;; potentially optimize the code based on the type information
               [(optimized-body ...) (maybe-optimize #'transformed-body)] ;; has own call to do-time
               ;; add in syntax property on useless expression to draw check-syntax arrows
@@ -54,8 +55,6 @@
                      #,(if (unbox include-extra-requires?) extra-requires #'(begin))
                      before-code ... optimized-body ... after-code ... check-syntax-help)))))))]))
 
-(define did-I-suggest-:print-type-already? #f)
-(define :print-type-message " ... [Use (:print-type <expr>) to see more.]")
 (define (ti-core stx )
   (current-type-names (init-current-type-names))
   (syntax-parse stx
@@ -69,67 +68,4 @@
      ;; TODO(endobson): Remove the call to do-standard-inits when it is no longer necessary
      ;; Cast at the top-level still needs this for some reason
      (do-standard-inits)
-     (tc-toplevel/full stx #'form
-       (λ (body2 type)
-         (with-syntax*
-          ([(optimized-body ...) (maybe-optimize #`(#,body2))]
-           ;; Transform after optimization for top-level because the flattening will
-           ;; change syntax object identity (via syntax-track-origin) which doesn't work
-           ;; for looking up types in the optimizer.
-           [(transformed-body ...)
-            (change-contract-fixups (flatten-all-begins #'(begin optimized-body ...)))])
-          (define ty-str
-            (match type
-              ;; 'no-type means the form is not an expression and
-              ;; has no meaningful type to print
-              ['no-type #f]
-              ;; don't print results of type void
-              [(tc-result1: (== -Void type-equal?)) #f]
-              ;; don't print results of unknown type
-              [(tc-any-results: f) #f]
-              [(tc-result1: t f o)
-               ;; Don't display the whole types at the REPL. Some case-lambda types
-               ;; are just too large to print.
-               ;; Also, to avoid showing too precise types, we generalize types
-               ;; before printing them.
-               (define tc (cleanup-type t))
-               (define tg (generalize tc))
-               (format "- : ~a~a~a\n"
-                       (pretty-format-type tg #:indent 4)
-                       (cond [(equal? tc tg) ""]
-                             [else (format " [more precisely: ~a]" tc)])
-                       (cond [(equal? tc t) ""]
-                             [did-I-suggest-:print-type-already? " ..."]
-                             [else (set! did-I-suggest-:print-type-already? #t)
-                                   :print-type-message]))]
-              [(tc-results: t)
-               (define tcs (map cleanup-type t))
-               (define tgs (map generalize tcs))
-               (define tgs-val (make-Values (map -result tgs)))
-               (define formatted (pretty-format-type tgs-val #:indent 4))
-               (define indented? (regexp-match? #rx"\n" formatted))
-               (format "- : ~a~a~a\n"
-                       formatted
-                       (cond [(andmap equal? tgs tcs) ""]
-                             [indented?
-                              (format "\n[more precisely: ~a]"
-                                      (pretty-format-type (make-Values (map -result tcs))
-                                                          #:indent 17))]
-                             [else (format " [more precisely: ~a]" (cons 'Values tcs))])
-                       ;; did any get pruned?
-                       (cond [(andmap equal? t tcs) ""]
-                             [did-I-suggest-:print-type-already? " ..."]
-                             [else (set! did-I-suggest-:print-type-already? #t)
-                                   :print-type-message]))]
-              [x (int-err "bad type result: ~a" x)]))
-          (if (and ty-str
-                   (not (null? (syntax-e #'(transformed-body ...)))))
-              (with-syntax ([(transformed-body ... transformed-last)
-                             #'(transformed-body ...)])
-                #`(begin #,(if (unbox include-extra-requires?)
-                               extra-requires
-                               #'(begin))
-                         #,(arm #'(begin transformed-body ...))
-                         (begin0 #,(arm #'transformed-last)
-                           (display '#,ty-str))))
-              (arm #'(begin transformed-body ...))))))]))
+     (tc-toplevel/full stx #'form)]))

typed-racket-lib/typed-racket/env/env-utils.rkt

@@ -0,0 +1,14 @@
+#lang racket/base
+
+(require racket/dict racket/sequence)
+(provide id< sorted-dict-map in-sorted-dict)
+
+(define (id< a b) (symbol<? (syntax-e a) (syntax-e b)))
+
+(define (sorted-dict-map dict f <)
+  (define sorted (sort #:key car (dict-map dict cons) <))
+  (map (lambda (a) (f (car a) (cdr a))) sorted))
+
+(define (in-sorted-dict dict <)
+  (define sorted (sort #:key car (dict-map dict cons) <))
+  (in-dict sorted))

typed-racket-lib/typed-racket/env/global-env.rkt

@@ -5,6 +5,7 @@
 
 (require "../types/tc-error.rkt"
          "../utils/tc-utils.rkt"
+         "env-utils.rkt"
          syntax/parse
          syntax/id-table
          racket/lazy-require) 
@@ -102,4 +103,4 @@
 ;; map over the-mapping, producing a list
 ;; (id type -> T) -> listof[T]
 (define (type-env-map f)
-  (free-id-table-map the-mapping f))
+  (sorted-dict-map the-mapping f id<))

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

@@ -8,11 +8,12 @@
          "type-name-env.rkt"
          "type-alias-env.rkt"
          "mvar-env.rkt"
+         "signature-env.rkt"
          (rename-in racket/private/sort [sort raw-sort])
-         (rep type-rep object-rep filter-rep rep-utils free-variance)
+         (rep type-rep object-rep prop-rep rep-utils free-variance)
          (for-syntax syntax/parse racket/base)
          (types abbrev union)
-         racket/dict racket/list
+         racket/dict racket/list racket/set racket/promise
          mzlib/pconvert racket/match)
 
 (provide ;; convenience form for defining an initial environment
@@ -26,7 +27,8 @@
          tvariance-env-init-code
          talias-env-init-code
          env-init-code
-         mvar-env-init-code)
+         mvar-env-init-code
+         signature-env-init-code)
 
 (define-syntax (define-initial-env stx)
   (syntax-parse stx
@@ -62,22 +64,28 @@
     [(? Rep? (app (lambda (v) (hash-ref predefined-type-table (Rep-seq v) #f)) (? values id))) id]
     [(Listof: elem-ty)
      `(-lst ,(sub elem-ty))]
-    [(Function: (list (arr: dom (Values: (list (Result: t (FilterSet: (Top:) (Top:)) (Empty:)))) #f #f '())))
+    [(Function: (list (arr: dom (Values: (list (Result: t
+                                                        (PropSet: (TrueProp:)
+                                                                  (TrueProp:))
+                                                        (Empty:))))
+                            #f #f '())))
      `(simple-> (list ,@(map sub dom)) ,(sub t))]
-    [(Function: (list (arr: dom (Values: (list (Result: t (FilterSet: (TypeFilter: ft pth)
-                                                                      (NotTypeFilter: ft pth))
+    [(Function: (list (arr: dom (Values: (list (Result: t (PropSet: (TypeProp: pth ft)
+                                                                     (NotTypeProp: pth ft))
                                                         (Empty:))))
                             #f #f '())))
      `(make-pred-ty (list ,@(map sub dom)) ,(sub t) ,(sub ft) ,(sub pth))]
-    [(Function: (list (arr: dom (Values: (list (Result: t (FilterSet: (NotTypeFilter: (== -False)
-                                                                                      (Path: pth (list 0 0)))
-                                                                      (TypeFilter: (== -False)
-                                                                                   (Path: pth (list 0 0))))
+    [(Function: (list (arr: dom (Values: (list (Result: t (PropSet: (NotTypeProp: (Path: pth (list 0 0))
+                                                                                  (== -False))
+                                                                      (TypeProp: (Path: pth (list 0 0))
+                                                                                 (== -False)))
                                                         (Path: pth (list 0 0)))))
                             #f #f '())))
      `(->acc (list ,@(map sub dom)) ,(sub t) ,(sub pth))]
-    [(Result: t (FilterSet: (Top:) (Top:)) (Empty:)) `(-result ,(sub t))]
+    [(Result: t (PropSet: (TrueProp:) (TrueProp:)) (Empty:)) `(-result ,(sub t))]
     [(Union: elems) (split-union elems)]
+    [(Intersection: elems) `(make-Intersection (set ,@(for/list ([elem (in-immutable-set elems)])
+                                                        (sub elem))))]
     [(Base: n cnt pred _) (int-err "Base type ~a not in predefined-type-table" n)]
     [(Name: stx args struct?)
      `(make-Name (quote-syntax ,stx) ,args ,struct?)]
@@ -118,12 +126,23 @@
               (set-box! cache-box
                         (dict-set (unbox cache-box) v (list name class-type))))
             (if cache-box name class-type)])]
+    [(Signature: name extends mapping)
+     (define (serialize-mapping m)
+       (map (lambda (id/ty) 
+              (define id (car id/ty))
+              (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)
+                      ,serialized-extends
+                      (list ,@(serialize-mapping mapping)))]
     [(arr: dom rng rest drest kws)
      `(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
-    [(TypeFilter: t p)
-     `(make-TypeFilter ,(sub t) ,(sub p))]
-    [(NotTypeFilter: t p)
-     `(make-NotTypeFilter ,(sub t) ,(sub p))]
+    [(TypeProp: o t)
+     `(make-TypeProp ,(sub o) ,(sub t))]
+    [(NotTypeProp: o t)
+     `(make-NotTypeProp ,(sub o) ,(sub t))]
     [(Path: p i)
      `(make-Path ,(sub p) ,(if (identifier? i)
                                `(quote-syntax ,i)
@@ -184,3 +203,8 @@
   (make-init-code
     (λ (f) (dict-map mvar-env f))
     (lambda (id v) (and v #`(register-mutated-var #'#,id)))))
+
+(define (signature-env-init-code)
+  (make-init-code
+   signature-env-map
+   (lambda (id sig) #`(register-signature! #'#,id #,(quote-type sig)))))

typed-racket-lib/typed-racket/env/signature-env.rkt

@@ -0,0 +1,81 @@
+#lang racket/base
+
+;; Environment for signature definitions
+;; to track bindings and type definitions inside of signatures
+
+(provide register-signature!
+         finalize-signatures!
+         lookup-signature
+         lookup-signature/check
+         signature-env-map
+         with-signature-env/extend)
+
+(require syntax/id-table
+         racket/match
+         racket/promise
+         (for-syntax syntax/parse racket/base)
+         "env-utils.rkt"
+         "../utils/utils.rkt"
+         (utils tc-utils)
+         (rep type-rep))
+
+;; initial signature environment
+(define signature-env (make-parameter (make-immutable-free-id-table)))
+
+;; register-signature! : identifier? Signature? -> Void
+;; adds a mapping from the given identifier to the given signature
+;; in the signature environment
+(define (register-signature! id sig)
+  (when (lookup-signature id)
+    (tc-error/fields "duplicate signature definition"
+                     "identifier" (syntax-e id)))
+  (signature-env (free-id-table-set (signature-env) id sig)))
+
+
+(define-syntax-rule (with-signature-env/extend ids sigs . b)
+  (let ([ids* ids]
+        [sigs* sigs])
+    (define new-env 
+      (for/fold ([env (signature-env)])
+                ([id (in-list ids*)]
+                 [sig (in-list sigs*)])
+        (free-id-table-set env id sig)))
+    (parameterize ([signature-env new-env]) . b)))
+
+;; Iterate over the signature environment forcing the types of bindings
+;; in each signature
+(define (finalize-signatures!)
+  (signature-env
+   (make-immutable-free-id-table
+    (signature-env-map
+     (lambda (id sig)
+       (cons
+        id
+        (match sig
+          [(Signature: name extends mapping)
+           (make-Signature
+            name
+            extends
+            (map
+             (match-lambda [(cons id ty) (cons id (force ty))])
+             mapping))]
+          [_ #f])))))))
+
+;; lookup-signature : identifier? -> (or/c #f Signature?)
+;; look up the signature corresponding to the given identifier
+;; in the signature environment
+(define (lookup-signature id)
+  (free-id-table-ref (signature-env) id #f))
+
+;; lookup-signature/check : identifier? -> Signature?
+;; lookup the identifier in the signature environment
+;; errors if there is no such typed signature
+(define (lookup-signature/check id)
+  (or (lookup-signature id)
+      (tc-error/fields "use of untyped signature in typed code"
+                       #:more "consider using `require/typed' to import it"
+                       "signature" (syntax-e id)
+                       #:stx id)))
+
+(define (signature-env-map f)
+  (sorted-dict-map (signature-env) f id<))

typed-racket-lib/typed-racket/env/signature-helper.rkt

@@ -0,0 +1,157 @@
+#lang racket/base
+
+;; This module provides helper functions for typed signatures
+
+(require "../utils/utils.rkt"
+         syntax/id-set
+         (utils tc-utils)
+         (env signature-env)
+         (rep type-rep)
+         (private parse-type)
+         syntax/parse
+         racket/list
+         racket/match
+         racket/promise
+         racket/unit-exptime
+         (for-template racket/base
+                       (submod "../typecheck/internal-forms.rkt" forms)))
+
+(provide parse-and-register-signature! signature->bindings signatures->bindings)
+
+;; parse-signature : Syntax -> Signature
+;; parses the internal syntax of a signature form to build the internal representation
+;; of a typed signature and registers the internal representation with the
+;; Signature environment
+;; The parsed syntax is created by uses of `define-signature-internal` which are
+;; inserted by the typed version of the `define-signature` macro, this function
+;; uses that syntax to created a Typed Representation of the signature to
+;; place in the Signature environment
+;; The parsed syntax contains the following fields:
+;; - name is the name of the signature being defined
+;; - the parent-signature is the name of the signature being extended or #f
+;;   if the signature defintion does not extend any signature
+;; - a list of bindings, each of the form [name : Type], for each variable
+;;   in the signature
+;; - The check field indicates that this syntax came from a use of require/typed
+;;   using the #:signature clause, and listed bindings muct be checked to ensure
+;;   they are consistent with the statically known signature variables
+(define (parse-and-register-signature! form)
+  (syntax-parse form
+    #:literal-sets (kernel-literals)
+    #:literals (values define-signature-internal)
+    [(define-values ()
+       (begin
+         (quote-syntax
+          (define-signature-internal name
+            #:parent-signature super
+            (binding ...)
+            #:check? check) #:local)
+              (#%plain-app values)))
+     (define raw-map (syntax->list #'(binding ...)))
+     (define check? (syntax->datum #'check))
+     (define extends (get-extended-signature #'name #'super check? form))
+     (define super-bindings (get-signature-mapping extends))
+     (define new-bindings (map parse-signature-binding raw-map))
+     (define pre-mapping (append super-bindings new-bindings))
+
+     ;; Make sure a require/typed signature has bindings listed
+     ;; that are consistent with its statically determined bindings
+     (when check?
+       (check-signature-bindings #'name (map car pre-mapping) form))
+
+     ;; require/typed signature bindings may not be in the correct order
+     ;; this fixes the ordering based on the static order determined
+     ;; by signature-members
+     (define mapping (if check?
+                         (fix-order #'name pre-mapping)
+                         pre-mapping))
+     (define signature (make-Signature #'name extends mapping))
+     (register-signature! #'name signature)]))
+
+;; check-signature-bindings : Identifier (Listof Identifier) -> Void
+;; checks that the bindings of a signature identifier are consistent with
+;; those listed in a require/typed clause
+(define (check-signature-bindings name vars stx)
+  (match-define-values (_ inferred-vars inferred-defs _) (signature-members name name))
+  (define (make-id-set set) (immutable-free-id-set set #:phase (add1 (syntax-local-phase-level))))
+  (define inferred-vars-set (make-id-set inferred-vars))
+  (define vars-set (make-id-set vars))
+  (unless (empty? inferred-defs)
+    (tc-error/stx name "untyped signatures containing definitions are prohibited"))
+  (unless (free-id-set=? inferred-vars-set vars-set)
+    (tc-error/fields "required signature declares inconsistent members"
+                     "expected members" (map syntax-e inferred-vars)
+                     "received members" (map syntax-e vars)
+                     #:stx stx)))
+
+;; get-extended-signature : Identifier Syntax Boolean -> (Option Signature)
+;; Checks if the extended signature information must be inferred and looks
+;; up the super signature in the environment
+;; Raises an error if a super signature is inferred that is not in the
+;; signature environment indicative of a signature that should be require/typed
+;; but was not, a typed binding for the parent signature is necessary to correctly
+;; check subtyping for units
+(define (get-extended-signature name super check? stx)
+  (cond
+   [check?
+    (match-define-values (inferred-super _ _ _) (signature-members name name))
+    (and inferred-super
+         (or (and (lookup-signature inferred-super) inferred-super)
+             (tc-error/fields "required signature extends an untyped signature"
+                              "required signature" (syntax-e name)
+                              "extended signature" (syntax-e inferred-super)
+                              #:stx stx)))]
+   [(not (syntax->datum super)) #f]
+   ;; This case should probably be an error, because if the signature was not false
+   ;; the lookup may still silently fail which should not be allowed here
+   [else (or (and (lookup-signature super) super)
+             (tc-error/fields "signature definition extends untyped signature"
+                              "in the definition of signature" (syntax-e name)
+                              "which extends signature" (syntax-e super)
+                              #:stx stx))]))
+
+;; parse-signature-binding : Syntax -> (list/c identifier? syntax?)
+;; parses the binding forms inside of a define signature into the 
+;; form used by the Signature type representation
+;; The call to `parse-type` is delayed to allow signatures and type aliases
+;; to be mutually recursive, after aliases are registered in the environment
+;; the promise will be forced to perform the actual type parsing
+(define (parse-signature-binding binding-stx)
+  (syntax-parse binding-stx
+    [[name:id type]
+     (cons #'name (delay (parse-type #'type)))]))
+
+;; signature->bindings : identifier? -> (listof (cons/c identifier? type?))
+;; GIVEN: a signature name
+;; RETURNS: the list of variables bound by that signature
+;;          inherited bindings come first
+(define (signature->bindings sig-id)
+  (define sig (lookup-signature sig-id))
+  (let loop ([sig (Signature-extends sig)]
+             [mapping (Signature-mapping sig)]
+             [bindings null])
+    (if sig
+        (loop (Signature-extends (lookup-signature sig))
+              (Signature-mapping (lookup-signature sig))
+              (append mapping bindings))
+        (append mapping bindings))))
+
+;; (listof identifier?) -> (listof (cons/c identifier? type?))
+;; GIVEN: a list of signature names
+;; RETURNS: the list of all bindings from those signatures
+;; TODO: handle required renamings/prefix/only/except
+(define (signatures->bindings ids)
+  (append-map signature->bindings ids))
+
+;; get-signature-mapping : (Option Signature) -> (Listof (Cons Id Type))
+(define (get-signature-mapping sig)
+  (if sig (Signature-mapping (lookup-signature sig)) null))
+
+;; fix-order : id (listof (cons/c id type?)) -> (listof (cons/c id type?)
+;; Returns a reordered list of signature bindings to match the order given
+;; by signature-members
+(define (fix-order sig-id sig-bindings)
+  (match-define-values (_ members _ _) (signature-members sig-id sig-id))
+  (map
+   (lambda (id) (assoc id sig-bindings free-transformer-identifier=?))
+   members))

typed-racket-lib/typed-racket/env/type-alias-env.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require "../utils/utils.rkt"
+         "env-utils.rkt"
          syntax/id-table racket/dict
          (utils tc-utils)
          (typecheck renamer)
@@ -61,6 +62,6 @@
 ;; map over the-mapping, producing a list
 ;; (id type -> T) -> listof[T]
 (define (type-alias-env-map f)  
-  (for/list ([(id t) (in-dict the-mapping)]
+  (for/list ([(id t) (in-sorted-dict the-mapping id<)]
              #:when (resolved? t))
     (f id (resolved-ty t))))

typed-racket-lib/typed-racket/env/type-env-structs.rkt

@@ -6,12 +6,12 @@
          (contract-req)
          (rep object-rep))
 
-(require-for-cond-contract (rep type-rep filter-rep))
+(require-for-cond-contract (rep type-rep prop-rep))
 
 ;; types is a free-id-table of identifiers to types
 ;; props is a list of known propositions
 (define-struct/cond-contract env ([types immutable-free-id-table?] 
-                                  [props (listof Filter/c)]
+                                  [props (listof Prop?)]
                                   [aliases immutable-free-id-table?])
   #:transparent
   #:property prop:custom-write
@@ -23,8 +23,8 @@
   [extend (env? identifier? Type/c . -> . env?)]
   [extend/values (env? (listof identifier?) (listof Type/c) . -> . env?)]
   [lookup (env? identifier? (identifier? . -> . any) . -> . any)]
-  [env-props (env? . -> . (listof Filter/c))]
-  [replace-props (env? (listof Filter/c) . -> . env?)]
+  [env-props (env? . -> . (listof Prop?))]
+  [replace-props (env? (listof Prop?) . -> . env?)]
   [empty-prop-env env?]
   [extend+alias/values (env? (listof identifier?) (listof Type/c) (listof Object?) . -> . env?)]
   [lookup-alias (env? identifier? (identifier? . -> . (or/c #f Object?)) . -> . (or/c #f Object?))])

typed-racket-lib/typed-racket/env/type-name-env.rkt

@@ -2,7 +2,8 @@
 
 ;; Environment for type names
 
-(require "../utils/utils.rkt")
+(require "../utils/utils.rkt"
+         "env-utils.rkt")
 
 (require syntax/id-table
          (contract-req)
@@ -58,7 +59,7 @@
 ;; map over the-mapping, producing a list
 ;; (id type -> T) -> listof[T]
 (define (type-name-env-map f)
-  (free-id-table-map the-mapping f))
+  (sorted-dict-map the-mapping f id<))
 
 (define (add-alias from to)
   (when (lookup-type-name to (lambda () #f))
@@ -83,7 +84,7 @@
 ;; map over the-mapping, producing a list
 ;; (id variance -> T) -> listof[T]
 (define (type-variance-env-map f)
-  (free-id-table-map variance-mapping f))
+  (sorted-dict-map variance-mapping f id<))
 
 ;; Refines the variance of a type in the name environment
 (define (refine-variance! names types tvarss)

typed-racket-lib/typed-racket/infer/constraints.rkt

@@ -7,7 +7,7 @@
          racket/match
          racket/list)
 
-(import restrict^ dmap^)
+(import intersect^ dmap^)
 (export constraints^)
 
 ;; Widest constraint possible
@@ -34,7 +34,7 @@
 ;; intersect the given types. produces a lower bound on both, but
 ;; perhaps not the GLB
 (define (meet S T)
-  (let ([s* (restrict S T)])
+  (let ([s* (intersect S T)])
     (if (and (subtype s* S)
              (subtype s* T))
         s*

typed-racket-lib/typed-racket/infer/fail.rkt

@@ -14,7 +14,7 @@
              #'((early-return rhs ...))))
  (syntax-parse stx
   [(_ e [c . r:rhs] ...)
-   #'(match* e [c . r.r] ...)]))
+   (syntax/loc stx (match* e [c . r.r] ...))]))
 
 (begin-for-syntax
   (define-splicing-syntax-class arg

typed-racket-lib/typed-racket/infer/infer-unit.rkt

@@ -11,7 +11,7 @@
          (except-in
           (combine-in
            (utils tc-utils)
-           (rep free-variance type-rep filter-rep object-rep rep-utils)
+           (rep free-variance type-rep prop-rep object-rep rep-utils)
            (types utils abbrev numeric-tower union subtype resolve
                   substitute generalize prefab)
            (env index-env tvar-env))
@@ -19,7 +19,7 @@
          "constraint-structs.rkt"
          "signatures.rkt" "fail.rkt"
          "promote-demote.rkt"
-         racket/match
+         racket/match racket/set
          mzlib/etc
          (contract-req)
          (for-syntax
@@ -212,7 +212,7 @@
       [(_ seq) #'(app List->seq (? values seq))])))
 
 
-;; generate-dbound-prefix: Symbol Type/c Natural Symbol -> (Values (Listof Symbol) (Listof Type/c))
+;; generate-dbound-prefix: Symbol Type/c Natural (U Symbol #f) -> (Values (Listof Symbol) (Listof Type/c))
 ;; Substitutes n fresh new variables, replaces dotted occurences of v in t with the variables (and
 ;; maybe new-end), and then for each variable substitutes it in for regular occurences of v.
 (define (generate-dbound-prefix v ty n new-end)
@@ -224,23 +224,23 @@
       (substitute (make-F var) v ty*))))
 
 
-(define/cond-contract (cgen/filter context s t)
-  (context? Filter? Filter? . -> . (or/c #f cset?))
+(define/cond-contract (cgen/prop context s t)
+  (context? Prop? Prop? . -> . (or/c #f cset?))
   (match* (s t)
     [(e e) (empty-cset/context context)]
-    [(e (Top:)) (empty-cset/context context)]
+    [(e (TrueProp:)) (empty-cset/context context)]
     ;; FIXME - is there something to be said about the logical ones?
-    [((TypeFilter: s p) (TypeFilter: t p)) (cgen/inv context s t)]
-    [((NotTypeFilter: s p) (NotTypeFilter: t p)) (cgen/inv context s t)]
+    [((TypeProp: o s) (TypeProp: o t)) (cgen/inv context s t)]
+    [((NotTypeProp: o s) (NotTypeProp: o t)) (cgen/inv context s t)]
     [(_ _) #f]))
 
-;; s and t must be *latent* filter sets
-(define/cond-contract (cgen/filter-set context s t)
-  (context? FilterSet? FilterSet? . -> . (or/c #f cset?))
+;; s and t must be *latent* prop sets
+(define/cond-contract (cgen/prop-set context s t)
+  (context? PropSet? PropSet? . -> . (or/c #f cset?))
   (match* (s t)
     [(e e) (empty-cset/context context)]
-    [((FilterSet: s+ s-) (FilterSet: t+ t-))
-     (% cset-meet (cgen/filter context s+ t+) (cgen/filter context s- t-))]
+    [((PropSet: p+ p-) (PropSet: q+ q-))
+     (% cset-meet (cgen/prop context p+ q+) (cgen/prop context p- q-))]
     [(_ _) #f]))
 
 (define/cond-contract (cgen/object context s t)
@@ -320,7 +320,7 @@
           (% move-dotted-rest-to-dmap (cgen (context-add-var context dbound) s-dty t-dty) dbound dbound*)))]
     [((seq ss (dotted-end s-dty dbound))
       (seq ts (dotted-end t-dty dbound*)))
-     #:when (inferable-index? context dbound*)
+     #:return-unless (inferable-index? context dbound*) #f
      #:return-unless (= (length ss) (length ts)) #f
      (% cset-meet
         (cgen/list context ss ts)
@@ -439,26 +439,26 @@
           ;; CG-Top
           [(_ (Univ:)) empty]
           ;; AnyValues
-          [((AnyValues: s-f) (AnyValues: t-f))
-           (cgen/filter context s-f t-f)]
+          [((AnyValues: p) (AnyValues: q))
+           (cgen/prop context p q)]
 
-          [((or (Values: (list (Result: _ fs _) ...))
-                (ValuesDots: (list (Result: _ fs _) ...) _ _))
-            (AnyValues: t-f))
+          [((or (Values: (list (Result: _ psets _) ...))
+                (ValuesDots: (list (Result: _ psets _) ...) _ _))
+            (AnyValues: q))
            (cset-join
              (filter identity
-               (for/list ([f (in-list fs)])
-                 (match f
-                   [(FilterSet: f+ f-)
-                    (% cset-meet (cgen/filter context f+ t-f) (cgen/filter context f- t-f))]))))]
+               (for/list ([pset (in-list psets)])
+                 (match pset
+                   [(PropSet: p+ p-)
+                    (% cset-meet (cgen/prop context p+ q) (cgen/prop context p- q))]))))]
 
           ;; check all non Type/c first so that calling subtype is safe
 
           ;; check each element
-          [((Result: s f-s o-s)
-            (Result: t f-t o-t))
+          [((Result: s pset-s o-s)
+            (Result: t pset-t o-t))
            (% cset-meet (cg s t)
-                        (cgen/filter-set context f-s f-t)
+                        (cgen/prop-set context pset-s pset-t)
                         (cgen/object context o-s o-t))]
 
           ;; Values just delegate to cgen/seq, except special handling for -Bottom.
@@ -525,6 +525,19 @@
           [((? Mu? s) t) (cg (unfold s) t)]
           [(s (? Mu? t)) (cg s (unfold t))]
 
+          ;; find *an* element of elems which can be made a subtype of T
+          [((Intersection: ts) T)
+           (cset-join
+            (for*/list ([t (in-immutable-set ts)]
+                        [v (in-value (cg t T))]
+                        #:when v)
+              v))]
+          
+          ;; constrain S to be below *each* element of elems, and then combine the constraints
+          [(S (Intersection: ts))
+           (define cs (for/list/fail ([ts (in-immutable-set ts)]) (cg S ts)))
+           (and cs (cset-meet* (cons empty cs)))]
+          
           ;; constrain *each* element of es to be below T, and then combine the constraints
           [((Union: es) T)
            (define cs (for/list/fail ([e (in-list es)]) (cg e T)))
@@ -540,6 +553,13 @@
                         #:when v)
               v))]
 
+          ;; from define-new-subtype
+          [((Distinction: nm1 id1 S) (app resolve (Distinction: nm2 id2 T)))
+           #:when (and (equal? nm1 nm2) (equal? id1 id2))
+           (cg S T)]
+          [((Distinction: _ _ S) T)
+           (cg S T)]
+
           ;; two structs with the same name
           ;; just check pairwise on the fields
           [((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _))
@@ -861,21 +881,22 @@
   (early-return
    (define short-S (take S (length T)))
    (define rest-S (drop S (length T)))
-   (define ctx (context null X (list dotted-var)))
-   (define expected-cset (if expected
-                             (cgen ctx R expected)
-                             (empty-cset '() '())))
-   #:return-unless expected-cset #f
-   (define cs-short (cgen/list ctx short-S T #:expected-cset expected-cset))
-   #:return-unless cs-short #f
+   ;; Generate a new type corresponding to T-dotted for every extra arg.
    (define-values (new-vars new-Ts)
      (generate-dbound-prefix dotted-var T-dotted (length rest-S) #f))
-   (define cs-dotted (cgen/list (context-add-vars ctx new-vars) rest-S new-Ts
-                                #:expected-cset expected-cset))
-   #:return-unless cs-dotted #f
-   (define cs-dotted* (move-vars-to-dmap cs-dotted dotted-var new-vars))
-   #:return-unless cs-dotted* #f
-   (define cs (cset-meet cs-short cs-dotted*))
+   (define (subst t)
+     (substitute-dots (map make-F new-vars) #f dotted-var t))
+   (define ctx (context null (append new-vars X) (list dotted-var)))
+
+   (define expected-cset (if expected
+                             (cgen ctx (subst R) expected)
+                             (empty-cset '() '())))
+   #:return-unless expected-cset #f
+   (define cs (% move-vars-to-dmap
+                 (% cset-meet
+                    (cgen/list ctx short-S (map subst T) #:expected-cset expected-cset)
+                    (cgen/list ctx rest-S new-Ts #:expected-cset expected-cset))
+                 dotted-var new-vars))
    #:return-unless cs #f
    (define m (cset-meet cs expected-cset))
    #:return-unless m #f

typed-racket-lib/typed-racket/infer/infer.rkt

@@ -1,11 +1,11 @@
 #lang racket/base
 
 (require "infer-unit.rkt" "constraints.rkt" "dmap.rkt" "signatures.rkt"
-         "restrict.rkt"
+         "intersect.rkt"
          (only-in racket/unit provide-signature-elements
                   define-values/invoke-unit/infer link))
 
-(provide-signature-elements restrict^ infer^)
+(provide-signature-elements intersect^ infer^)
 
 (define-values/invoke-unit/infer
-  (link infer@ constraints@ dmap@ restrict@))
+  (link infer@ constraints@ dmap@ intersect@))

typed-racket-lib/typed-racket/infer/intersect.rkt

@@ -0,0 +1,71 @@
+#lang racket/unit
+
+(require "../utils/utils.rkt")
+(require (rep type-rep)
+         (types abbrev base-abbrev union subtype resolve)
+         "signatures.rkt"
+         racket/match
+         racket/set)
+
+(import infer^)
+(export intersect^)
+
+
+;; compute the intersection of two types
+;; (note: previously called restrict)
+(define (intersect t1 t2)
+  ;; build-type: build a type while propogating bottom
+  (define (build-type constructor . args)
+    (if (memf Bottom? args) -Bottom (apply constructor args)))
+  ;; resolved is a set tracking previously seen intersect cases
+  ;; (i.e. pairs of t1 t2) to prevent infinite unfolding.
+  ;; subtyping performs a similar check for the same
+  ;; reason
+  (let intersect
+    ([t1 t1] [t2 t2] [resolved (set)])
+    (match*/no-order
+     (t1 t2)
+      ;; already a subtype
+      [(t1 t2) #:no-order #:when (subtype t1 t2) t1]
+      
+      ;; polymorphic intersect
+      [(t1 (Poly: vars t))
+       #:no-order
+       #:when (infer vars null (list t1) (list t) #f)
+       t1]
+      
+      ;; structural recursion on types
+      [((Pair: a1 d1) (Pair: a2 d2)) 
+       (build-type -pair 
+                   (intersect a1 a2 resolved) 
+                   (intersect d1 d2 resolved))]
+      ;; FIXME: support structural updating for structs when structs are updated to
+      ;; contain not only *if* they are polymorphic, but *which* fields are too  
+      ;;[((Struct: _ _ _ _ _ _)
+      ;; (Struct: _ _ _ _ _ _))]
+      [((Syntax: t1*) (Syntax: t2*))
+       (build-type -Syntax (intersect t1* t2* resolved))]
+      [((Promise: t1*) (Promise: t2*))
+       (build-type -Promise (intersect t1* t2* resolved))]
+      
+      ;; unions
+      [((Union: t1s) t2)
+       #:no-order
+       (apply Un (map (λ (t1) (intersect t1 t2 resolved)) t1s))]
+
+      ;; intersections
+      [((Intersection: t1s) t2)
+       #:no-order
+       (apply -unsafe-intersect (for/list ([t1 (in-immutable-set t1s)])
+                                  (intersect t1 t2 resolved)))]
+      
+      ;; resolve resolvable types if we haven't already done so
+      [((? needs-resolving? t1) t2)
+       #:no-order
+       #:when (not (or (set-member? resolved (cons t1 t2))
+                       (set-member? resolved (cons t2 t1))))
+       (intersect (resolve t1) t2 (set-add resolved (cons t1 t2)))]
+     
+      ;; t2 and t1 have a complex relationship, so we build an intersection
+      ;; (note: intersection checks for overlap)
+      [(t1 t2) (-unsafe-intersect t1 t2)])))

typed-racket-lib/typed-racket/infer/promote-demote.rkt

@@ -15,13 +15,13 @@
   (for/or ([e (in-list (append* (map fv ts)))])
     (memq e V)))
 
-;; get-filters : SomeValues -> FilterSet
-;; extract filters out of the range of a function type
-(define (get-filters rng)
+;; get-propset : SomeValues -> PropSet
+;; extract prop sets out of the range of a function type
+(define (get-propsets rng)
   (match rng
-    [(AnyValues: f) (list (-FS f f))]
-    [(Values: (list (Result: _ lf _) ...)) lf]
-    [(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
+    [(AnyValues: p) (list (-PS p p))]
+    [(Values: (list (Result: _ propsets _) ...)) propsets]
+    [(ValuesDots: (list (Result: _ propsets _) ...) _ _) propsets]))
 
 
 (begin-encourage-inline
@@ -43,7 +43,7 @@
       (match arr
         [(arr: dom rng rest drest kws)
          (cond
-           [(apply V-in? V (get-filters rng))
+           [(apply V-in? V (get-propsets rng))
             #f]
            [(and drest (memq (cdr drest) V))
             (make-arr (map contra dom)
@@ -63,7 +63,7 @@
       [(Function: arrs)
        (make-Function (filter-map arr-change arrs))]
       [(? structural?) (structural-map T structural-recur)]
-      [(? Filter?) ((sub-f co) T)]
+      [(? Prop?) ((sub-f co) T)]
       [(? Object?) ((sub-o co) T)]
       [(? Type?) ((sub-t co) T)]))
   (define (var-promote T V)

typed-racket-lib/typed-racket/infer/restrict.rkt

@@ -1,68 +0,0 @@
-#lang racket/unit
-
-(require "../utils/utils.rkt")
-(require (rep type-rep)
-         (types abbrev base-abbrev union subtype remove-intersect resolve)
-         "signatures.rkt"
-         racket/match
-         racket/set)
-
-(import infer^)
-(export restrict^)
-
-
-;; restrict t1 to be a subtype of t2
-;; if `pref' is 'new, use t2 when giving up, otherwise use t1
-(define (restrict t1 t2 [pref 'new])
-  ;; build-type: build a type while propogating bottom
-  (define (build-type constructor . args)
-    (if (memf Bottom? args) -Bottom (apply constructor args)))
-  ;; resolved is a set tracking previously seen restrict cases
-  ;; (i.e. pairs of t1 t2) to prevent infinite unfolding.
-  ;; subtyping performs a similar check for the same
-  ;; reason
-  (define (restrict* t1 t2 pref resolved)
-    (match* (t1 t2)
-      ;; already a subtype
-      [(_ _) #:when (subtype t1 t2) 
-             t1]
-      
-      ;; polymorphic restrict
-      [(_ (Poly: vars t)) #:when (infer vars null (list t1) (list t) #f)
-                          t1]
-      
-      ;; structural recursion on types
-      [((Pair: a1 d1) (Pair: a2 d2)) 
-       (build-type -pair 
-                   (restrict* a1 a2 pref resolved) 
-                   (restrict* d1 d2 pref resolved))]
-      ;; FIXME: support structural updating for structs when structs are updated to
-      ;; contain not only *if* they are polymorphic, but *which* fields are too  
-      ;;[((Struct: _ _ _ _ _ _)
-      ;; (Struct: _ _ _ _ _ _))]
-      [((Syntax: t1*) (Syntax: t2*))
-       (build-type -Syntax (restrict* t1* t2* pref resolved))]
-      [((Promise: t1*) (Promise: t2*))
-       (build-type -Promise (restrict* t1* t2* pref resolved))]
-      
-      ;; unions
-      [((Union: t1s) _) (apply Un (map (λ (t1*) (restrict* t1* t2 pref resolved)) t1s))]
-      [(_ (Union: t2s)) (apply Un (map (λ (t2*) (restrict* t1 t2* pref resolved)) t2s))]
-      
-      ;; resolve resolvable types if we haven't already done so
-      [((? needs-resolving?) _) #:when (not (set-member? resolved (cons t1 t2)))
-                                (restrict* (resolve t1) t2 pref (set-add resolved (cons t1 t2)))]
-      [(_ (? needs-resolving?)) #:when (not (set-member? resolved (cons t1 t2)))
-                                (restrict* t1 (resolve t2) pref (set-add resolved (cons t1 t2)))]
-      
-      ;; we don't actually want this - want something that's a part of t1
-      [(_ _) #:when (subtype t2 t1)
-             t2]
-      
-      ;; there's no overlap, so the restriction is empty
-      [(_ _) #:when (not (overlap t1 t2)) 
-             (Un)]
-      
-      ;; t2 and t1 have a complex relationship, so we punt
-      [(_ _) (if (eq? pref 'new) t2 t1)]))
-  (restrict* t1 t2 pref (set)))

typed-racket-lib/typed-racket/infer/signatures.rkt

@@ -20,8 +20,8 @@
    [cond-contracted cset-join ((listof cset?) . -> . cset?)]
    [cond-contracted c-meet ((c? c?) (symbol?) . ->* . (or/c #f c?))]))
 
-(define-signature restrict^
-  ([cond-contracted restrict ((Type/c Type/c) ((or/c 'new 'orig)) . ->* . Type/c)]))
+(define-signature intersect^
+  ([cond-contracted intersect (Type/c Type/c . -> . Type/c)]))
 
 (define-signature infer^
   ([cond-contracted infer ((;; variables from the forall

typed-racket-lib/typed-racket/optimizer/extflonum.rkt

@@ -42,12 +42,12 @@
   #:literal-sets (kernel-literals)
   (pattern (#%plain-app op:unary-extflonum-op t:opt-expr)
     #:do [(log-extfl-opt "unary extflonum")]
-    #:with opt #'(op.unsafe t.opt))
+    #:with opt (syntax/loc this-syntax (op.unsafe t.opt)))
   (pattern (#%plain-app op:binary-extflonum-op t1:opt-expr t2:opt-expr)
     #:do [(log-extfl-opt "binary extflonum")]
-    #:with opt #'(op.unsafe t1.opt t2.opt))
+    #:with opt (syntax/loc this-syntax (op.unsafe t1.opt t2.opt)))
 
   (pattern (#%plain-app :fx->extfl-op f:fixnum-expr)
     #:do [(log-extfl-opt "fixnum to extflonum conversion")]
-    #:with opt #'(unsafe-fx->extfl f.opt))
+    #:with opt (syntax/loc this-syntax (unsafe-fx->extfl f.opt)))
   )

typed-racket-lib/typed-racket/optimizer/fixnum.rkt

@@ -142,13 +142,13 @@
     #:with opt #'(op.unsafe n.opt))
   (pattern (op:fixnum-binary-op (~between ns:fixnum-expr 2 +inf.0) ...)
     #:do [(log-fx-opt "binary fixnum")]
-    #:with opt (n-ary->binary #'op.unsafe #'(ns.opt ...)))
+    #:with opt (n-ary->binary this-syntax #'op.unsafe #'(ns.opt ...)))
   (pattern (op:fixnum-binary-comp n1:fixnum-expr n2:fixnum-expr)
     #:do [(log-fx-opt "binary fixnum comp")]
     #:with opt #'(op.unsafe n1.opt n2.opt))
   (pattern (op:fixnum-binary-comp n1:fixnum-expr n2:fixnum-expr ns:fixnum-expr ...)
     #:do [(log-fx-opt "multi fixnum comp")]
-    #:with opt (n-ary-comp->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))
+    #:with opt (n-ary-comp->binary this-syntax #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))
 
   (pattern (op:nonzero-fixnum-binary-op n1:fixnum-expr n2:nonzero-fixnum-expr)
     #:do [(log-fx-opt "binary nonzero fixnum")]
@@ -202,7 +202,7 @@
   (pattern (op:potentially-bounded-fixnum-op (~between ns:fixnum-expr 2 +inf.0) ...)
     #:when (check-if-safe stx)
     #:do [(log-fx-opt "fixnum bounded expr")]
-    #:with opt (n-ary->binary #'op.unsafe #'(ns.opt ...)))
+    #:with opt (n-ary->binary this-syntax #'op.unsafe #'(ns.opt ...)))
   (pattern (op:potentially-bounded-nonzero-fixnum-op n1:fixnum-expr n2:nonzero-fixnum-expr)
     #:when (check-if-safe stx)
     #:do [(log-fx-opt "nonzero fixnum bounded expr")]

typed-racket-lib/typed-racket/optimizer/float-complex.rkt

@@ -1,11 +1,12 @@
 #lang racket/base
 
-(require syntax/parse syntax/stx racket/promise
+(require syntax/parse syntax/stx syntax/id-table racket/promise
          racket/syntax racket/match syntax/parse/experimental/specialize
          "../utils/utils.rkt" racket/unsafe/ops racket/sequence
          (for-template racket/base racket/math racket/flonum racket/unsafe/ops)
          (types numeric-tower subtype type-table utils)
-         (optimizer utils numeric-utils logging float unboxed-tables))
+         (optimizer utils numeric-utils logging float unboxed-tables)
+         (utils tc-utils))
 
 (provide float-complex-opt-expr
          float-complex-expr
@@ -50,14 +51,56 @@
       "The optimizer could optimize it better if it had type Float-Complex.")
     this-syntax))
 
-;; If a part is 0.0?
-(define (0.0? stx)
-  (equal? (syntax->datum stx) 0.0))
+;; keep track of operands that were reals (and thus had exact 0 as imaginary part)
+(define real-id-table (make-free-id-table))
+(define (was-real? stx)
+  (free-id-table-ref real-id-table stx #f))
+(define (mark-as-real stx)
+  (free-id-table-set! real-id-table stx #t)
+  stx)
+;; keep track of operands that were not floats (i.e. rationals and single floats)
+;; to avoid prematurely converting to floats, which may change results
+(define non-float-table (make-hash))
+(define (as-non-float stx)
+  (hash-ref non-float-table stx #f))
+(define (mark-as-non-float stx [orig stx])
+  (hash-set! non-float-table stx orig)
+  stx)
 
+(define (n-ary->binary/non-floats op unsafe this-syntax cs)
+  (let loop ([o (stx-car cs)] [cs (stx-cdr cs)])
+    ;; we're guaranteed to hit non-"non-float" operands before
+    ;; we hit the end of the list. otherwise we wouldn't be doing
+    ;; float-complex optimizations
+    (define c1 (stx-car cs))
+    (define o-nf (as-non-float o))
+    (define c1-nf (as-non-float c1))
+    (if (or o-nf c1-nf)
+        ;; can't convert those to floats just yet, or may change
+        ;; the result
+        (let ([new-o (mark-as-non-float
+                      (quasisyntax/loc this-syntax
+                        (#,op #,(or o-nf o) #,(or c1-nf c1))))])
+          (if (stx-null? (stx-cdr cs))
+              new-o
+              (loop new-o
+                    (stx-cdr cs))))
+        ;; we've hit floats, can start coercing
+        (n-ary->binary this-syntax unsafe (cons #`(real->double-flonum #,(or o-nf o)) cs)))))
 
 ;; a+bi / c+di, names for real and imag parts of result -> one let-values binding clause
 (define (unbox-one-complex-/ a b c d res-real res-imag)
-  (define both-real? (and (0.0? b) (0.0? d)))
+  (define first-arg-real? (was-real? b))
+  (define second-arg-real? (was-real? d))
+  ;; if both are real, we can short-circuit a lot
+  (define both-real? (and first-arg-real? second-arg-real?))
+  (define first-non-float (as-non-float a))
+  (define second-non-float (as-non-float c))
+
+  (when (and first-non-float (not second-non-float))
+    ;; we're going from non-float to float operands, so need to coerce the first
+    (set! a #`(real->double-flonum #,a)))
+
   ;; we have the same cases as the Racket `/' primitive (except for the non-float ones)
   (define d=0-case
     #`(values (unsafe-fl+ (unsafe-fl/ #,a #,c)
@@ -85,10 +128,42 @@
                         (unsafe-fl/ (unsafe-fl- (unsafe-fl* b r) a) den))])
         (values (unsafe-fl/ (unsafe-fl+ b (unsafe-fl* a r)) den)
                 i)))
-  (cond [both-real?
-         #`[(#,res-real #,res-imag)
+
+  (cond [(and first-non-float second-non-float both-real?)
+         ;; we haven't hit float operands, so we shouldn't coerce to float yet
+         #`[(#,(mark-as-non-float res-real)
+             #,(mark-as-real res-imag)) ; this case implies real
+            (values (/ #,first-non-float #,second-non-float)
+                    0.0)]]
+        [second-non-float
+         ;; may be dividing by exact 0, be conservative to preserve error
+         ;; (res-real can't be non-float, since we've hit a float, so we either
+         ;; error or coerce)
+         #`[(#,res-real #,(if both-real?
+                              (mark-as-real res-imag)
+                              res-imag))
+            (let-values ([(res-div)
+                          (/ #,(if first-arg-real?
+                                   a
+                                   #`(make-rectangular #,a #,b))
+                             #,(if second-arg-real?
+                                   second-non-float
+                                   #`(make-rectangular #,second-non-float
+                                                       #,d)))])
+              #,(if both-real?
+                    #'(values res-div 0.0)
+                    #'(values (real-part res-div)
+                              (imag-part res-div))))]]
+        [both-real?
+         #`[(#,res-real #,(mark-as-real res-imag))
             (values (unsafe-fl/ #,a #,c)
                     0.0)]] ; currently not propagated
+        [second-arg-real?
+         #`[(#,res-real #,res-imag)
+            (values (unsafe-fl/ #,a #,c)
+                    (unsafe-fl/ #,b #,c))]]
+        [first-arg-real?
+         (unbox-one-float-complex-/ a c d res-real res-imag)]
         [else
          #`[(#,res-real #,res-imag)
             (cond [(unsafe-fl= #,d 0.0) #,d=0-case]
@@ -112,7 +187,7 @@
     #`(let* ([cm    (unsafe-flabs #,c)]
              [dm    (unsafe-flabs #,d)]
              [swap? (unsafe-fl< cm dm)]
-             [a     #,a]
+             [a     #,a] ; don't swap with `b` (`0`) here, but handle below
              [c     (if swap? #,d #,c)]
              [d     (if swap? #,c #,d)]
              [r     (unsafe-fl/ c d)]
@@ -145,15 +220,25 @@
     #:with (bindings ...)
       #`(cs.bindings ... ...
          #,@(let ()
-               (define (fl-sum cs) (n-ary->binary #'unsafe-fl+ cs))
+              (define (fl-sum cs)
+                (n-ary->binary/non-floats #'+ #'unsafe-fl+ this-syntax cs))
+              (define non-0-imags
+                ;; to preserve result sign, ignore exact 0s
+                ;; o/w, can have (+ -0.0 (->fl 0)) => 0.0, but would be -0.0
+                ;; without the coercion
+                (for/list ([i (syntax->list #'(cs.imag-binding ...))]
+                           #:unless (was-real? i))
+                  i))
                (list
                 #`((real-binding) #,(fl-sum #'(cs.real-binding ...)))
-                #`((imag-binding) #,(fl-sum #'(cs.imag-binding ...)))))))
+                #`((imag-binding)
+                   #,(if (null? (cdr non-0-imags)) ; only one actual imag part
+                         (car non-0-imags)
+                         (fl-sum non-0-imags)))))))
   (pattern (#%plain-app op:+^ :unboxed-float-complex-opt-expr)
     #:when (subtypeof? this-syntax -FloatComplex)
     #:do [(log-unboxing-opt "unboxed unary float complex")])
 
-
   (pattern (#%plain-app op:-^ (~between cs:unboxed-float-complex-opt-expr 2 +inf.0) ...)
     #:when (subtypeof? this-syntax -FloatComplex)
     #:with (real-binding imag-binding) (binding-names)
@@ -161,10 +246,21 @@
     #:with (bindings ...)
       #`(cs.bindings ... ...
          #,@(let ()
-              (define (fl-subtract cs) (n-ary->binary #'unsafe-fl- cs))
+              (define (fl-subtract cs)
+                (n-ary->binary/non-floats #'- #'unsafe-fl- this-syntax cs))
               (list
                #`((real-binding) #,(fl-subtract #'(cs.real-binding ...)))
-               #`((imag-binding) #,(fl-subtract #'(cs.imag-binding ...)))))))
+               #`((imag-binding)
+                  ;; can't ignore exact 0 imag parts from real numbers, as with
+                  ;; addition, because the first value is special
+                  ;; so just conservatively use generic subtraction
+                  #,(if (ormap was-real? (syntax->list #'(cs.imag-binding ...)))
+                        (n-ary->binary
+                         this-syntax
+                         #'-
+                         (for/list ([i (syntax->list #'(cs.imag-binding ...))])
+                           (if (was-real? i) #'0 i)))
+                        (fl-subtract #'(cs.imag-binding ...))))))))
   (pattern (#%plain-app op:-^ c1:unboxed-float-complex-opt-expr) ; unary -
     #:when (subtypeof? this-syntax -FloatComplex)
     #:with (real-binding imag-binding) (binding-names)
@@ -198,27 +294,45 @@
                                               #'(cs.imag-binding ...))
                                      (list #'imag-binding))]
                          [res '()])
-                (if (null? e1)
-                    (reverse res)
-                    (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is)
-                          ;; complex multiplication, imag part, then real part (reverse)
-                          ;; we eliminate operations on the imaginary parts of reals
-                          (let ((o-real? (0.0? o2))
-                                (e-real? (0.0? (car e2))))
-                            (list* #`((#,(car is))
-                                      #,(cond ((and o-real? e-real?) #'0.0)
-                                              (o-real? #`(unsafe-fl* #,o1 #,(car e2)))
-                                              (e-real? #`(unsafe-fl* #,o2 #,(car e1)))
-                                              (else
-                                               #`(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1))
-                                                             (unsafe-fl* #,o1 #,(car e2))))))
-                                   #`((#,(car rs))
-                                      #,(cond ((or o-real? e-real?)
-                                               #`(unsafe-fl* #,o1 #,(car e1)))
-                                              (else
-                                               #`(unsafe-fl- (unsafe-fl* #,o1 #,(car e1))
-                                                             (unsafe-fl* #,o2 #,(car e2))))))
-                                 res))))))))
+                (cond
+                 [(null? e1)
+                  (reverse res)]
+                 [else
+                  (define o-real? (was-real? o2))
+                  (define e-real? (was-real? (car e2)))
+                  (define both-real? (and o-real? e-real?))
+                  (define o-nf (as-non-float o1))
+                  (define e-nf (as-non-float (car e1)))
+                  (define new-imag-id (if both-real?
+                                          (mark-as-real (car is))
+                                          (car is)))
+                  (loop (car rs) new-imag-id (cdr e1) (cdr e2) (cdr rs) (cdr is)
+                        ;; complex multiplication, imag part, then real part (reverse)
+                        ;; we eliminate operations on the imaginary parts of reals
+                        (list* #`((#,new-imag-id)
+                                  #,(cond ((and o-real? e-real?) #'0.0)
+                                          (o-real? #`(unsafe-fl* #,o1 #,(car e2)))
+                                          (e-real? #`(unsafe-fl* #,o2 #,(car e1)))
+                                          (else
+                                           #`(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1))
+                                                         (unsafe-fl* #,o1 #,(car e2))))))
+                               #`((#,(car rs))
+                                  #,(cond [(and o-nf e-nf both-real?)
+                                           ;; we haven't seen float operands yet, so
+                                           ;; shouldn't prematurely convert to floats
+                                           (mark-as-non-float (car rs))
+                                           #`(* #,o-nf #,e-nf)]
+                                          [(or o-real? e-real?)
+                                           #`(unsafe-fl*
+                                              #,(if (as-non-float o1)
+                                                    ;; we hit floats, need to coerce
+                                                    #`(real->double-flonum #,o1)
+                                                    o1)
+                                              #,(car e1))]
+                                          [else
+                                           #`(unsafe-fl- (unsafe-fl* #,o1 #,(car e1))
+                                                         (unsafe-fl* #,o2 #,(car e2)))]))
+                               res))])))))
   (pattern (#%plain-app op:*^ :unboxed-float-complex-opt-expr)
     #:when (subtypeof? this-syntax -FloatComplex)
     #:do [(log-unboxing-opt "unboxed unary float complex")])
@@ -332,10 +446,21 @@
          ((real-binding) (unsafe-flreal-part e*))
          ((imag-binding) (unsafe-flimag-part e*))))
 
-  ;; The following optimization is incorrect and causes bugs because it turns exact numbers into inexact
   (pattern e:number-expr
     #:with e* (generate-temporary)
-    #:with (real-binding imag-binding) (binding-names)
+    #:with (real-binding* imag-binding*) (binding-names)
+    #:with real-binding (if (and (subtypeof? #'e -Real)
+                                 (not (subtypeof? #'e -Flonum)))
+                            ;; values that were originally non-floats (e.g.
+                            ;; rationals or single floats) may need to be
+                            ;; handled specially
+                            (mark-as-non-float #'real-binding* #'e*)
+                            #'real-binding*)
+    #:with imag-binding (if (subtypeof? #'e -Real)
+                            ;; values that were originally reals may need to be
+                            ;; handled specially
+                            (mark-as-real #'imag-binding*)
+                            #'imag-binding*)
     #:do [(log-unboxing-opt
             (if (subtypeof? #'e -Flonum)
                 "float in complex ops"
@@ -443,9 +568,13 @@
           [(#%plain-app op:magnitude^ c:unboxed-float-complex-opt-expr)
            (log-unboxing-opt "unboxed unary float complex")
            #`(let*-values (c.bindings ...)
-               (unsafe-flsqrt
-                 (unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding)
-                             (unsafe-fl* c.imag-binding c.imag-binding))))])))
+               ;; reuses the algorithm used by the Racket runtime
+               (let*-values ([(r) (unsafe-flabs c.real-binding)]
+                             [(i) (unsafe-flabs c.imag-binding)]
+                             [(q) (unsafe-fl/ r i)])
+                 (unsafe-fl* i
+                             (unsafe-flsqrt (unsafe-fl+ 1.0
+                                                        (unsafe-fl* q q))))))])))
 
 
   (pattern (#%plain-app op:float-complex-op e:expr ...)

typed-racket-lib/typed-racket/optimizer/float.rkt

@@ -192,16 +192,16 @@
                          this-syntax extra-precision-subexprs)))
                     safe-to-opt?)
            #:do [(log-fl-opt "binary float")]
-           #:with opt (n-ary->binary #'op.unsafe #'(fs.opt ...)))
+           #:with opt (n-ary->binary this-syntax #'op.unsafe #'(fs.opt ...)))
   (pattern (#%plain-app op:binary-float-comp f1:float-expr f2:float-expr)
     #:do [(log-fl-opt "binary float comp")]
-    #:with opt #'(op.unsafe f1.opt f2.opt))
+    #:with opt (syntax/loc this-syntax (op.unsafe f1.opt f2.opt)))
   (pattern (#%plain-app op:binary-float-comp
                         f1:float-expr
                         f2:float-expr
                         fs:float-expr ...)
     #:do [(log-fl-opt "multi float comp")]
-    #:with opt (n-ary-comp->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))
+    #:with opt (n-ary-comp->binary this-syntax #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))
   (pattern (#%plain-app op:binary-float-comp args:opt-expr ...)
     ;; some args, but not all (otherwise above would have matched) are floats
     ;; mixed-type comparisons are slow and block futures
@@ -227,13 +227,13 @@
 
   (pattern (#%plain-app op:-^ f:float-expr)
     #:do [(log-fl-opt "unary float")]
-    #:with opt #'(unsafe-fl* -1.0 f.opt))
+    #:with opt (syntax/loc this-syntax (unsafe-fl* -1.0 f.opt)))
   (pattern (#%plain-app op:/^ f:float-expr)
     #:do [(log-fl-opt "unary float")]
-    #:with opt #'(unsafe-fl/ 1.0 f.opt))
+    #:with opt (syntax/loc this-syntax (unsafe-fl/ 1.0 f.opt)))
   (pattern (#%plain-app op:sqr^ f:float-expr)
     #:do [(log-fl-opt "unary float")]
-    #:with opt #'(let ([tmp f.opt]) (unsafe-fl* tmp tmp)))
+    #:with opt (syntax/loc this-syntax (let ([tmp f.opt]) (unsafe-fl* tmp tmp))))
 
   ;; we can optimize exact->inexact if we know we're giving it an Integer
   (pattern (#%plain-app op:->float^ n:int-expr)
@@ -250,19 +250,19 @@
 
   (pattern (#%plain-app op:zero?^ f:float-expr)
     #:do [(log-fl-opt "float zero?")]
-    #:with opt #'(unsafe-fl= f.opt 0.0))
+    #:with opt (syntax/loc this-syntax (unsafe-fl= f.opt 0.0)))
 
   (pattern (#%plain-app op:add1^ n:float-expr)
     #:do [(log-fl-opt "float add1")]
-    #:with opt #'(unsafe-fl+ n.opt 1.0))
+    #:with opt (syntax/loc this-syntax (unsafe-fl+ n.opt 1.0)))
   (pattern (#%plain-app op:sub1^ n:float-expr)
     #:do [(log-fl-opt "float sub1")]
-    #:with opt #'(unsafe-fl- n.opt 1.0))
+    #:with opt (syntax/loc this-syntax (unsafe-fl- n.opt 1.0)))
 
   (pattern (#%plain-app op:random-op prng:opt-expr)
     #:when (subtypeof? #'prng -Pseudo-Random-Generator)
     #:do [(log-fl-opt "float random")]
-    #:with opt #'(unsafe-flrandom prng.opt))
+    #:with opt (syntax/loc this-syntax (unsafe-flrandom prng.opt)))
   (pattern (#%plain-app op:random^) ; random with no args
     #:do [(log-fl-opt "float 0-arg random")
           ;; We introduce a reference to `current-pseudo-random-generator',
@@ -270,7 +270,7 @@
           ;; from triggering down the line (see hidden-cost.rkt), so we need
           ;; to do the logging ourselves.
           (log-optimization-info "hidden parameter (random)" #'op)]
-    #:with opt #'(unsafe-flrandom (current-pseudo-random-generator)))
+    #:with opt (syntax/loc this-syntax (unsafe-flrandom (current-pseudo-random-generator))))
 
   ;; warn about (potentially) exact real arithmetic, in general
   ;; Note: These patterns don't perform optimization. They only produce logging
@@ -278,15 +278,15 @@
   (pattern (#%plain-app op:binary-float-op n:opt-expr ...)
     #:when (maybe-exact-rational? this-syntax)
     #:do [(log-opt-info "possible exact real arith")]
-    #:with opt #'(op n.opt ...))
+    #:with opt (syntax/loc this-syntax (op n.opt ...)))
   (pattern (#%plain-app op:binary-float-comp n:opt-expr ...)
      ;; can't look at return type, since it's always bool
      #:when (andmap maybe-exact-rational? (syntax->list #'(n ...)))
      #:do [(log-opt-info "possible exact real arith")]
-     #:with opt #'(op n.opt ...))
+     #:with opt (syntax/loc this-syntax (op n.opt ...)))
   (pattern (#%plain-app op:unary-float-op n:opt-expr ...)
      #:when (maybe-exact-rational? this-syntax)
      #:do [(log-opt-info "possible exact real arith")]
-     #:with opt #'(op n.opt ...))
+     #:with opt (syntax/loc this-syntax (op n.opt ...)))
   )
 

typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt

@@ -4,7 +4,7 @@
          (for-template racket/base)
          "../utils/utils.rkt"
          (optimizer utils logging)
-         (types abbrev struct-table))
+         (types abbrev numeric-tower struct-table))
 
 (provide hidden-cost-log-expr)
 
@@ -45,18 +45,6 @@
     #:do [(log-optimization-info "hidden parameter (random)" #'op)]
     #:with opt (syntax/loc this-syntax (op args.opt ...)))
 
-  ;; Log calls to struct constructors, so that OC can report those used in
-  ;; hot loops.
-  ;; Note: Sometimes constructors are wrapped in `#%expression', need to watch
-  ;;  for that too.
-  (pattern (#%plain-app (~and op-part (~or op:id (#%expression op:id)))
-                        args:opt-expr ...)
-    #:when (let ([constructor-for (syntax-property #'op 'constructor-for)])
-             (or (and constructor-for (struct-constructor? constructor-for))
-                 (struct-constructor? #'op)))
-    #:do [(log-optimization-info "struct constructor" #'op)]
-    #:with opt (syntax/loc this-syntax (op-part args.opt ...)))
-
   ;; regexp-match (or other regexp operation) with non-regexp pattern argument
   ;; (i.e. string or bytes)
   (pattern (#%plain-app op:regexp-function pattern-arg:opt-expr
@@ -64,4 +52,12 @@
     #:when (not (or (subtypeof? #'pattern-arg -Regexp)
                     (subtypeof? #'pattern-arg -Byte-Regexp)))
     #:do [(log-optimization-info "non-regexp pattern" #'pattern-arg)]
-    #:with opt (syntax/loc this-syntax (op pattern-arg.opt args.opt ...))))
+    #:with opt (syntax/loc this-syntax (op pattern-arg.opt args.opt ...)))
+
+  ;; vectors of floats can be replaced with flvectors in most cases
+  ;; need to deconstruct to not infinite loop
+  (pattern (#%plain-app es ...)
+    #:when (subtypeof? this-syntax (-vec -Flonum))
+    #:with (es*:opt-expr ...) #'(es ...)
+    #:do [(log-optimization-info "vector of floats" this-syntax)]
+    #:with opt (syntax/loc this-syntax (es*.opt ...))))

typed-racket-lib/typed-racket/optimizer/optimizer.rkt

@@ -24,9 +24,9 @@
   (pattern opt:ignore-table^)
 
   ;; Can't optimize the body of this code because it isn't typechecked
-  (pattern (~and _:kw-lambda^
-             ((~and op let-values)
-              ([(i:id) e-rhs:opt-expr]) e-body:expr ...))
+  (pattern (~and (~or _:kw-lambda^ _:opt-lambda^)
+                 ((~and op let-values)
+                  ([(i:id) e-rhs:opt-expr]) e-body:expr ...))
            #:with opt (quasisyntax/loc/origin this-syntax #'op
                         (op ([(i) e-rhs.opt]) e-body ...)))
 

typed-racket-lib/typed-racket/optimizer/pair.rkt

@@ -6,7 +6,7 @@
          (for-syntax racket/base syntax/parse racket/syntax)
          "../utils/utils.rkt"
          (rep type-rep)
-         (types type-table utils base-abbrev)
+         (types type-table utils base-abbrev resolve subtype)
          (typecheck typechecker)
          (optimizer utils logging))
 
@@ -25,10 +25,7 @@
 
 
 (define (has-pair-type? e)
-  (and (subtypeof? e (-pair Univ Univ))
-       ;; sometimes composite operations end up with Nothing as result type,
-       ;; not sure why. TODO investigate
-       (not (isoftype? e -Bottom))))
+  (subtypeof? e (-pair Univ Univ)))
 ;; can't do the above for mpairs, as they are invariant
 (define (has-mpair-type? e)
   (match (type-of e) ; type of the operand
@@ -67,25 +64,12 @@
 
 
 ;; change the source location of a given syntax object
-(define (relocate stx loc-stx)
+(define ((relocate loc-stx) stx)
   (datum->syntax stx (syntax->datum stx) loc-stx stx stx))
 
 ;; if the equivalent sequence of cars and cdrs is guaranteed not to fail,
 ;; we can optimize
 
-;; accessors is a list of syntax objects, all #'car or #'cdr
-(define (gen-alt accessors op arg stx)
-  (define (gen-alt-helper accessors)
-    (for/fold [(accum arg)] [(acc (reverse accessors))]
-      (quasisyntax/loc stx (#%plain-app #,(relocate acc op) #,accum))))
-  (let ((ty  (type-of stx))
-        (obj (gen-alt-helper accessors)))
-    ;; we're calling the typechecker, but this is just a shortcut, we're
-    ;; still conceptually single pass (we're not iterating). we could get
-    ;; the same result by statically destructing the types.
-    (tc-expr/check obj ty)
-    obj))
-
 (define-syntax gen-pair-derived-expr
   (syntax-parser
     [(_ name:id (orig:id seq ...) ...)
@@ -96,8 +80,9 @@
            (define-literal-syntax-class lit-class-name (orig))
            (define-syntax-class syntax-class-name
              #:commit
+             #:attributes (arg alt)
              (pattern (#%plain-app (~var op lit-class-name) arg)
-               #:with alt (gen-alt (list seq ...) #'op #'arg this-syntax)))) ...
+               #:with alt (map (relocate #'op) (list seq ...))))) ...
          (define-merged-syntax-class name (syntax-class-name ...)))]))
 
 (gen-pair-derived-expr pair-derived-expr
@@ -144,5 +129,30 @@
 (define-syntax-class pair-derived-opt-expr
   #:commit
   (pattern e:pair-derived-expr
-           #:with e*:pair-opt-expr #'e.alt
-           #:with opt #'e*.opt))
+    #:with opt
+    ;; optimize alt inside-out, as long as it's safe to
+    (let-values
+        ([(t res)
+          (for/fold ([t   (match (type-of #'e.arg)
+                            [(tc-result1: t) t])]
+                     [res #'e.arg])
+              ([accessor (in-list (reverse (syntax->list #'e.alt)))])
+            (cond
+             [(and t (subtype t (-pair Univ Univ))) ; safe to optimize this one layer
+              (syntax-parse accessor
+                [op:pair-op
+                 (log-pair-opt)
+                 (values
+                  (match (resolve t)
+                    [(Pair: a d) ; peel off one layer of the type
+                     (syntax-parse #'op
+                       [:car^ a]
+                       [:cdr^ d])]
+                    [_ ; not a pair type, give up on optimizing more
+                     #f])
+                  #`(op.unsafe #,res))])]
+             [else ; unsafe, just rebuild the rest of the accessors
+              (log-pair-missed-opt accessor #'e.arg)
+              (values t ; stays unsafe from now on
+                      #`(#,accessor #,res))]))])
+      res)))

typed-racket-lib/typed-racket/optimizer/unboxed-let.rkt

@@ -99,14 +99,15 @@
          (define-syntax-class unboxed-clauses
            #:attributes (bindings)
            (pattern (clauses:unboxed-clause ...)
-             #:attr bindings (delay (template ((?@ . clauses.bindings) ...)))))]
+             #:attr bindings (delay (template ((?@ . clauses.bindings) ...)))))
+         (define top-stx this-syntax)]
 
    #:attr opt
      (syntax-parse #'(clause ...)
       [clauses:unboxed-clauses
         (delay
           (quasisyntax/loc/origin
-            this-syntax #'letk.kw
+            top-stx #'letk.kw
             (letk.key ... clauses.bindings body.opt ...)))])))
 
 

typed-racket-lib/typed-racket/optimizer/utils.rkt

@@ -51,11 +51,12 @@
 
 ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
 ;; this works on operations that are (A A -> A)
-(define (n-ary->binary op stx)
+(define (n-ary->binary src-stx op stx)
   (for/fold ([o (stx-car stx)]) ([e (in-syntax (stx-cdr stx))])
-    #`(#,op #,o #,e)))
+    (quasisyntax/loc src-stx
+      (#,op #,o #,e))))
 ;; this works on operations that are (A A -> B)
-(define (n-ary-comp->binary op arg1 arg2 rest)
+(define (n-ary-comp->binary src-stx op arg1 arg2 rest)
   ;; First, generate temps to bind the result of each arg2 args ...
   ;; to avoid computing them multiple times.
   (define lifted (stx-map (lambda (x) (generate-temporary)) #`(#,arg2 #,@rest)))
@@ -69,10 +70,11 @@
                         (car l)
                         (cdr l))])))
   ;; Finally, build the whole thing.
-  #`(let #,(for/list ([lhs (in-list lifted)]
+  (quasisyntax/loc src-stx
+    (let #,(for/list ([lhs (in-list lifted)]
                       [rhs (in-syntax #`(#,arg2 #,@rest))])
              #`(#,lhs #,rhs))
-      (and #,@tests)))
+      (and #,@tests))))
 
 ;; to avoid mutually recursive syntax classes
 ;; will be set to the actual optimization function at the entry point

typed-racket-lib/typed-racket/private/cast-table.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+
+(provide cast-table-ref
+         cast-table-set!)
+
+(require syntax/id-table)
+
+;; A module that helps store information about the original types of casted
+;; expressions.
+;;
+;; Casts in Typed Racket must generate two contracts. One from typed to untyped,
+;; and another from untyped to typed. The contract from typed to untyped is
+;; generated based on the existing type of the expression, which must be stored
+;; in this table so that it can be looked up later in the contract-generation
+;; pass.
+
+(define cast-table (make-free-id-table))
+
+;; cast-table-set! : Id Type-Stx -> Void
+(define (cast-table-set! id type-stx)
+  (free-id-table-set! cast-table id type-stx))
+
+;; cast-table-ref : Id -> (U False Type-Stx)
+(define (cast-table-ref id)
+  (free-id-table-ref cast-table id #f))

typed-racket-lib/typed-racket/private/oc-button.rkt

@@ -0,0 +1,16 @@
+#lang racket/base
+
+;; Control whether the OC button show up for TR files in DrR.
+
+(provide maybe-show-OC)
+
+(define (maybe-show-OC)
+  ;; If Optimization Coach is installed, load it.
+  (with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
+    (collection-path "optimization-coach")
+    (if (dynamic-require 'optimization-coach/tool
+                         'optimization-coach-loaded?)
+        ;; OC is loaded, show button
+        (list (dynamic-require 'optimization-coach/tool
+                               'optimization-coach-drracket-button))
+        '())))

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

@@ -2,16 +2,18 @@
 
 ;; This module provides functions for parsing types written by the user
 
-(require "../utils/utils.rkt"
+(require (rename-in "../utils/utils.rkt" [infer infer-in])
          (except-in (rep type-rep object-rep) make-arr)
-         (rename-in (types abbrev union utils filter-ops resolve
-                           classes prefab)
+         (rename-in (types abbrev union utils prop-ops resolve
+                           classes prefab signatures)
                     [make-arr* make-arr])
+         (only-in (infer-in infer) intersect)
          (utils tc-utils stxclass-util literal-syntax-class)
          syntax/stx (prefix-in c: (contract-req))
          syntax/parse racket/sequence
          (env tvar-env type-alias-env mvar-env
-              lexical-env index-env row-constraint-env)
+              lexical-env index-env row-constraint-env
+              signature-env)
          racket/dict
          racket/list
          racket/promise
@@ -20,6 +22,7 @@
          "parse-classes.rkt"
          (for-label
            (except-in racket/base case-lambda)
+           racket/unit
            "../base-env/colon.rkt"
            "../base-env/base-types-extra.rkt"
            ;; match on the `case-lambda` binding in the TR primitives
@@ -79,6 +82,10 @@
 (define-literal-syntax-class #:for-label cons)
 (define-literal-syntax-class #:for-label Class)
 (define-literal-syntax-class #:for-label Object)
+(define-literal-syntax-class #:for-label Unit)
+(define-literal-syntax-class #:for-label import)
+(define-literal-syntax-class #:for-label export)
+(define-literal-syntax-class #:for-label init-depend)
 (define-literal-syntax-class #:for-label Refinement)
 (define-literal-syntax-class #:for-label Instance)
 (define-literal-syntax-class #:for-label List)
@@ -98,8 +105,12 @@
 (define-literal-syntax-class #:for-label Prefab)
 (define-literal-syntax-class #:for-label Values)
 (define-literal-syntax-class #:for-label values)
+(define-literal-syntax-class #:for-label AnyValues)
 (define-literal-syntax-class #:for-label Top)
 (define-literal-syntax-class #:for-label Bot)
+(define-literal-syntax-class #:for-label Distinction)
+(define-literal-syntax-class #:for-label Sequenceof)
+(define-literal-syntax-class #:for-label ∩)
 
 ;; (Syntax -> Type) -> Syntax Any -> Syntax
 ;; See `parse-type/id`. This is a curried generalization.
@@ -218,7 +229,7 @@
   #:attributes (type)
   (pattern (~optional (~seq #:rest type:non-keyword-ty))))
 
-;; syntax classes for filters, objects, and related things
+;; syntax classes for props, objects, and related things
 (define-syntax-class path-elem
   #:description "path element"
   (pattern :car^
@@ -235,8 +246,8 @@
   #:description "!"
   (pattern (~datum !)))
 
-(define-splicing-syntax-class simple-latent-filter
-  #:description "latent filter"
+(define-splicing-syntax-class simple-latent-prop
+  #:description "latent prop"
   (pattern (~seq t:expr :@ pe:path-elem ...)
            #:attr type (parse-type #'t)
            #:attr path (attribute pe.pe))
@@ -245,54 +256,54 @@
            #:attr path '()))
 
 (define-syntax-class (prop doms)
-  #:description "filter proposition"
+  #:description "proposition"
   #:attributes (prop)
-  (pattern :Top^ #:attr prop -top)
-  (pattern :Bot^ #:attr prop -bot)
+  (pattern :Top^ #:attr prop -tt)
+  (pattern :Bot^ #:attr prop -ff)
   ;; Here is wrong check
-  (pattern (t:expr :@ ~! pe:path-elem ... (~var o (filter-object doms)))
-           #:attr prop (-filter (parse-type #'t) (-acc-path (attribute pe.pe) (attribute o.obj))))
+  (pattern (t:expr :@ ~! pe:path-elem ... (~var o (prop-object doms)))
+           #:attr prop (-is-type (-acc-path (attribute pe.pe) (attribute o.obj)) (parse-type #'t)))
   ;; Here is wrong check
-  (pattern (:! t:expr :@ ~! pe:path-elem ... (~var o (filter-object doms)))
-           #:attr prop (-not-filter (parse-type #'t) (-acc-path (attribute pe.pe) (attribute o.obj))))
+  (pattern (:! t:expr :@ ~! pe:path-elem ... (~var o (prop-object doms)))
+           #:attr prop (-not-type (-acc-path (attribute pe.pe) (attribute o.obj)) (parse-type #'t)))
   (pattern (:! t:expr)
-           #:attr prop (-not-filter (parse-type #'t) 0))
+           #:attr prop (-not-type 0 (parse-type #'t)))
   (pattern ((~datum and) (~var p (prop doms)) ...)
            #:attr prop (apply -and (attribute p.prop)))
   (pattern ((~datum or) (~var p (prop doms)) ...)
            #:attr prop (apply -or (attribute p.prop)))
   (pattern ((~literal implies) (~var p1 (prop doms)) (~var p2 (prop doms)))
-           #:attr prop (-imp (attribute p1.prop) (attribute p2.prop)))
+           #:attr prop (-or (negate-prop (attribute p1.prop)) (attribute p2.prop)))
   (pattern t:expr
-           #:attr prop (-filter (parse-type #'t) 0)))
+           #:attr prop (-is-type 0 (parse-type #'t))))
 
-(define-splicing-syntax-class (filter-object doms)
-  #:description "filter object"
+(define-splicing-syntax-class (prop-object doms)
+  #:description "prop object"
   #:attributes (obj)
   (pattern i:id
            #:fail-unless (identifier-binding #'i)
-           "Filters for predicates may not reference identifiers that are unbound"
+           "Propositions for predicates may not reference identifiers that are unbound"
            #:fail-when (is-var-mutated? #'i)
-           "Filters for predicates may not reference identifiers that are mutated"
+           "Propositions for predicates may not reference identifiers that are mutated"
            #:attr obj (-id-path #'i))
   (pattern idx:nat
            #:do [(define arg (syntax-e #'idx))]
            #:fail-unless (< arg (length doms))
-           (format "Filter proposition's object index ~a is larger than argument length ~a"
+           (format "Proposition's object index ~a is larger than argument length ~a"
                    arg (length doms))
            #:attr obj (-arg-path arg 0))
   (pattern (~seq depth-idx:nat idx:nat)
            #:do [(define arg (syntax-e #'idx))
                  (define depth (syntax-e #'depth-idx))]
            #:fail-unless (<= depth (length (current-arities)))
-           (format "Index ~a used in a filter, but the use is only within ~a enclosing functions"
+           (format "Index ~a used in a proposition, but the use is only within ~a enclosing functions"
                    depth (length (current-arities)))
            #:do [(define actual-arg
                    (if (zero? depth)
                        (length doms)
                        (list-ref (current-arities) (sub1 depth))))]
            #:fail-unless (< arg actual-arg)
-           (format "Filter proposition's object index ~a is larger than argument length ~a"
+           (format "Proposition's object index ~a is larger than argument length ~a"
                    depth actual-arg)
            #:attr obj (-arg-path arg (syntax-e #'depth-idx))))
 
@@ -374,6 +385,42 @@
                                  "given" v)
                     (make-Instance (Un)))
              (make-Instance v)))]
+      [(:Unit^ (:import^ import:id ...)
+               (:export^ export:id ...)
+               (~optional (:init-depend^ init-depend:id ...) 
+                          #:defaults ([(init-depend 1) null]))
+               (~optional result
+                          #:defaults ([result #f])))
+       ;; Lookup an identifier in the signature environment
+       ;; Fail with a parse error, if the lookup returns #f
+       (define (id->sig id)
+         (or (lookup-signature id)
+             (parse-error #:stx id
+                          #:delayed? #f
+                          "Unknown signature used in Unit type"
+                          "signature" (syntax-e id))))
+       (define (import/export-error)
+         (parse-error #:stx stx
+                      #:delayed? #f
+                      "Unit types must import and export distinct signatures"))
+       (define (init-depend-error)
+         (parse-error
+            #:stx stx
+            #:delayed? #f
+            "Unit type initialization dependencies must be a subset of imports"))
+       (define imports
+         (check-imports/exports (stx-map id->sig #'(import ...)) import/export-error))
+       (define exports
+         (check-imports/exports (stx-map id->sig #'(export ...)) import/export-error))
+       (define init-depends
+         (check-init-depends/imports (stx-map id->sig #'(init-depend ...))
+                                     imports
+                                     init-depend-error))
+       (define res (attribute result))
+       (make-Unit imports
+                  exports
+                  init-depends
+                  (if res (parse-values-type res) (-values (list -Void))))]
       [(:List^ ts ...)
        (parse-list-type stx)]
       [(:List*^ ts ... t)
@@ -421,17 +468,30 @@
                  t*))))]
       [(:U^ ts ...)
        (apply Un (parse-types #'(ts ...)))]
+      [(:∩^ ts ...)
+       (for/fold ([ty Univ])
+                 ([t (in-list (parse-types #'(ts ...)))])
+         (intersect ty t))]
       [(:quote^ t)
        (parse-quoted-type #'t)]
       [(:All^ . rest)
        (parse-all-type stx)]
       [(:Opaque^ p?:id)
        (make-Opaque #'p?)]
+      [(:Distinction^ name:id unique-id:id rep-ty:expr)
+       (-Distinction (syntax-e #'name) (syntax-e #'unique-id) (parse-type #'rep-ty))]
       [(:Parameter^ t)
        (let ([ty (parse-type #'t)])
          (-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 ...))))))]
+      [(:Sequenceof^ t ...)
+       (apply -seq (parse-types #'(t ...)))]
       ;; curried function notation
       [((~and dom:non-keyword-ty (~not :->^)) ...
         :->^
@@ -444,9 +504,9 @@
             (list (make-arr
                    doms
                    (parse-type (syntax/loc stx (rest-dom ...))))))))]
-      [(~or (:->^ dom rng :colon^ latent:simple-latent-filter)
-            (dom :->^ rng :colon^ latent:simple-latent-filter))
-       ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
+      [(~or (:->^ dom rng :colon^ latent:simple-latent-prop)
+            (dom :->^ rng :colon^ latent:simple-latent-prop))
+       ;; use parse-type instead of parse-values-type because we need to add the props from the pred-ty
        (with-arity 1
          (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (attribute latent.type)
                        (-acc-path (attribute latent.path) (-arg-path 0))))]
@@ -506,11 +566,11 @@
              :colon^ (~var latent (full-latent (syntax->list #'(dom ...)))))
             (dom:non-keyword-ty ... :->^ rng:expr
              ~! :colon^ (~var latent (full-latent (syntax->list #'(dom ...))))))
-       ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
+       ;; use parse-type instead of parse-values-type because we need to add the props from the pred-ty
        (with-arity (length (syntax->list #'(dom ...)))
          (->* (parse-types #'(dom ...))
               (parse-type #'rng)
-              : (-FS (attribute latent.positive) (attribute latent.negative))
+              : (-PS (attribute latent.positive) (attribute latent.negative))
               : (attribute latent.object)))]
       [(:->*^ (~var mand (->*-args #t))
               (~optional (~var opt (->*-args #f))
@@ -546,7 +606,8 @@
             (when (current-referenced-aliases)
               (define alias-box (current-referenced-aliases))
               (set-box! alias-box (cons #'id (unbox alias-box))))
-            (add-disappeared-use (syntax-local-introduce #'id))
+            (and (syntax-transforming?)
+                 (add-disappeared-use (syntax-local-introduce #'id)))
             t)]
          [else
           (parse-error #:delayed? #t (~a "type name `" (syntax-e #'id) "' is unbound"))
@@ -619,7 +680,7 @@
        (-Tuple (parse-types #'(tys ...)))])))
 
 ;; Syntax -> Type
-;; Parse a (Values ...) type
+;; Parse a (Values ...) or AnyValues type
 (define (parse-values-type stx)
   (parameterize ([current-orig-stx stx])
     (syntax-parse stx
@@ -641,6 +702,7 @@
                        var))]
       [((~or :Values^ :values^) tys ...)
        (-values (parse-types #'(tys ...)))]
+      [:AnyValues^ ManyUniv]
       [t
        (-values (list (parse-type #'t)))])))
 
@@ -868,10 +930,12 @@
 (define (parse-tc-results stx)
   (syntax-parse stx
     [((~or :Values^ :values^) t ...)
+     (define empties (stx-map (λ (x) #f) #'(t ...)))
      (ret (parse-types #'(t ...))
-          (stx-map (lambda (x) -no-filter) #'(t ...))
-          (stx-map (lambda (x) -no-obj) #'(t ...)))]
-    [t (ret (parse-type #'t) -no-filter -no-obj)]))
+          empties
+          empties)]
+    [:AnyValues^ (tc-any-results #f)]
+    [t (ret (parse-type #'t) #f #f)]))
 
 (define parse-type/id (parse/id parse-type))
 

typed-racket-lib/typed-racket/private/syntax-properties.rkt

@@ -50,9 +50,10 @@
   (ignore typechecker:ignore #:mark)
   (ignore-some typechecker:ignore-some #:mark)
   (ignore-some-expr typechecker:ignore-some)
-  (contract-def typechecker:contract-def)
+  (contract-def typechecker:contract-def) ; -> Contract-Def (struct in type-contract.rkt)
   (contract-def/provide typechecker:contract-def/provide)
   (external-check typechecker:external-check)
+  (casted-expr typechecker:casted-expr) ; Type -> Void, takes the original type of the casted expr
   (with-type typechecker:with-type #:mark)
   (type-ascription type-ascription)
   (type-inst type-inst)
@@ -74,5 +75,10 @@
   (tr:class:local-table tr:class:local-table)
   (tr:class:name-table tr:class:name-table)
   (tr:class:def tr:class:def)
-  )
-
+  (tr:unit tr:unit #:mark)
+  (tr:unit:body-exp-def-type tr:unit:body-exp-def-type)
+  (tr:unit:invoke tr:unit:invoke)
+  (tr:unit:invoke:expr tr:unit:invoke:expr)
+  (tr:unit:compound tr:unit:compound)
+  (tr:unit:from-context tr:unit:from-context #:mark)
+  (unsafe-provide unsafe-provide #:mark))

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

@@ -5,19 +5,19 @@
 (require
  "../utils/utils.rkt"
  syntax/parse
- (rep type-rep filter-rep object-rep)
+ (rep type-rep prop-rep object-rep)
  (utils tc-utils)
  (env type-name-env row-constraint-env)
  (rep rep-utils)
  (types resolve union utils printer)
- (prefix-in t: (types abbrev numeric-tower))
+ (prefix-in t: (types abbrev numeric-tower subtype))
  (private parse-type syntax-properties)
  racket/match racket/syntax racket/list
  racket/format
- racket/dict
+ racket/dict racket/set
  syntax/flatten-begin
- (only-in (types abbrev) -Bottom)
- (static-contracts instantiate optimize structures combinators)
+ (only-in (types abbrev) -Bottom -Boolean)
+ (static-contracts instantiate optimize structures combinators constraints)
  ;; TODO make this from contract-req
  (prefix-in c: racket/contract)
  (contract-req)
@@ -39,14 +39,26 @@
 ;; submod for testing
 (module* test-exports #f (provide type->contract))
 
+;; has-contrat-def-property? : Syntax -> Boolean
+(define (has-contract-def-property? stx)
+  (syntax-parse stx
+    #:literal-sets (kernel-literals)
+    [(define-values (_) e)
+     (and (contract-def-property #'e)
+          #t)]
+    [_ #f]))
+
 (struct contract-def (type flat? maker? typed-side) #:prefab)
 
+;; get-contract-def-property : Syntax -> (U False Contract-Def)
 ;; Checks if the given syntax needs to be fixed up for contract generation
 ;; and if yes it returns the information stored in the property
 (define (get-contract-def-property stx)
   (syntax-parse stx
     #:literal-sets (kernel-literals)
-    [(define-values (_) e) (contract-def-property #'e)]
+    [(define-values (_) e)
+     (and (contract-def-property #'e)
+          ((contract-def-property #'e)))]
     [_ #f]))
 
 ;; type->contract-fail : Syntax Type #:ctc-str String
@@ -111,7 +123,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 +134,15 @@
                                  "type" #,(pretty-format-type type #:indent 8)))]
            [else
             (match-define (list defs ctc) result)
+            (define maybe-inline-val
+              (should-inline-contract?/cache 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 +150,16 @@
                                         #,(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?/cache ctc-stx cache)
+  (and (identifier? ctc-stx)
+       (let ([match? (assoc ctc-stx (hash-values cache) free-identifier=?)])
+         (and match?
+              (should-inline-contract? (cdr match?))
+              (cdr match?)))))
+
 ;; The below requires are needed since they provide identifiers that
 ;; may appear in the residual program.
 
@@ -147,7 +174,10 @@
       typed-racket/utils/opaque-object
       typed-racket/utils/evt-contract
       typed-racket/utils/sealing-contract
-      unstable/contract racket/contract/parametric))
+      typed-racket/utils/promise-not-name-contract
+      typed-racket/utils/simple-result-arrow
+      racket/sequence
+      racket/contract/parametric))
 
 ;; Should the above requires be included in the output?
 ;;   This box is only used for contracts generated for `require/typed`
@@ -160,7 +190,7 @@
   (define sc-cache (make-hash))
   (with-new-name-tables
    (for/list ((e (in-list forms)))
-     (if (not (get-contract-def-property e))
+     (if (not (has-contract-def-property? e))
          e
          (begin (set-box! include-extra-requires? #t)
                 (generate-contract-def e ctc-cache sc-cache))))))
@@ -186,6 +216,15 @@
                                      ctc-cache sc-cache)))]
        [_ form]))))
 
+;; get-max-contract-kind
+;; static-contract -> (or/c 'flat 'chaperone 'impersonator)
+;; recurse into a contract finding the max
+;; kind (e.g. flat < chaperone < impersonator)
+(define (get-max-contract-kind sc)
+    (define (get-restriction sc)
+      (sc->constraints sc get-restriction))
+    (kind-max-max (contract-restrict-value (get-restriction sc))))
+
 ;; To avoid misspellings
 (define impersonator-sym 'impersonator)
 (define chaperone-sym 'chaperone)
@@ -267,9 +306,6 @@
 (define (same sc)
   (triple sc sc sc))
 
-;; Keep track of the bound names and don't cache types where those are free
-(define bound-names (make-parameter null))
-
 ;; Macro to simplify (and avoid reindentation) of the match below
 ;;
 ;; The sc-cache hashtable is used to memoize static contracts. The keys are
@@ -284,7 +320,9 @@
                [else
                 (define sc (match type match-clause ...))
                 (define fvs (fv type))
-                (unless (or (ormap (λ (n) (member n fvs)) (bound-names))
+                ;; Only cache closed terms, otherwise open terms may show up
+                ;; out of context.
+                (unless (or (not (null? fv))
                             ;; Don't cache types with applications of Name types because
                             ;; it does the wrong thing for recursive references
                             (has-name-app? type))
@@ -361,6 +399,32 @@
          (if numeric-sc
              (apply or/sc numeric-sc (map t->sc non-numeric))
              (apply or/sc (map t->sc elems)))]
+        [(Intersection: ts)
+         (define-values (chaperones/impersonators others)
+           (for/fold ([cs/is null] [others null])
+                     ([elem (in-immutable-set ts)])
+             (define c (t->sc elem))
+             (if (equal? flat-sym (get-max-contract-kind c))
+                 (values cs/is (cons c others))
+                 (values (cons c cs/is) others))))
+         (cond
+           [(> (length chaperones/impersonators) 1)
+            (fail #:reason (~a "Intersection type contract contains"
+                               " more than 1 non-flat contract: "
+                               type))]
+           [else
+            (apply and/sc (append others chaperones/impersonators))])]
+        [(and t (Function: arrs))
+         #:when (any->bool? arrs)
+         ;; Avoid putting (-> any T) contracts on struct predicates (where Boolean <: T)
+         ;; Optimization: if the value is typed, we can assume it's not wrapped
+         ;;  in a type-unsafe chaperone/impersonator and use the unsafe contract
+         (let* ([unsafe-spp/sc (flat/sc #'struct-predicate-procedure?)]
+                [safe-spp/sc (flat/sc #'struct-predicate-procedure?/c)]
+                [optimized/sc (if (from-typed? typed-side)
+                                  unsafe-spp/sc
+                                  safe-spp/sc)])
+           (or/sc optimized/sc (t->sc/fun t)))]
         [(and t (Function: _)) (t->sc/fun t)]
         [(Set: t) (set/sc (t->sc t))]
         [(Sequence: ts) (apply sequence/sc (map t->sc ts))]
@@ -396,6 +460,7 @@
         [(Prompt-TagTop:) (only-untyped prompt-tag?/sc)]
         [(Continuation-Mark-KeyTop:) (only-untyped continuation-mark-key?/sc)]
         [(ClassTop:) (only-untyped class?/sc)]
+        [(UnitTop:) (only-untyped unit?/sc)]
         [(StructTypeTop:) (struct-type/sc null)]
         ;; TODO Figure out how this should work
         ;[(StructTop: s) (struct-top/sc s)]
@@ -418,13 +483,11 @@
          (case typed-side
            [(both) (recursive-sc
                      (list both-n*)
-                     (parameterize ([bound-names (cons n (bound-names))])
-                       (list (loop b 'both rv)))
+                     (list (loop b 'both rv))
                      (recursive-sc-use both-n*))]
            [(typed untyped)
             (define (rec b side rv)
-              (parameterize ([bound-names (cons n (bound-names))])
-                (loop b side rv)))
+              (loop b side rv))
             ;; TODO not fail in cases that don't get used
             (define untyped (rec b 'untyped rv))
             (define typed (rec b 'typed rv))
@@ -514,6 +577,25 @@
          (if seal/sc
              (and/sc seal/sc sc-for-class)
              sc-for-class)]
+        [(Unit: imports exports init-depends results)
+         (define (traverse sigs)
+           (for/list ([sig (in-list sigs)])
+             (define mapping 
+               (map
+                (match-lambda 
+                  [(cons id type) (cons id (t->sc type))])
+                (Signature-mapping sig)))
+             (signature-spec (Signature-name sig) (map car mapping) (map cdr mapping))))
+         
+         (define imports-specs (traverse imports))
+         (define exports-specs (traverse exports))
+         (define init-depends-ids (map Signature-name init-depends))
+         (match results
+           [(? AnyValues?)
+            (fail #:reason (~a "cannot generate contract for unit type"
+                               " with unknown return values"))]
+           [(Values: (list (Result: rngs _ _) ...))
+            (unit/sc imports-specs exports-specs init-depends-ids (map t->sc rngs))])]
         [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?)
          (cond
            [(dict-ref recursive-values nm #f)]
@@ -537,7 +619,14 @@
         [(Syntax: t)
          (syntax/sc (t->sc t))]
         [(Value: v)
-         (flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))) v)]
+         (if (and (c:flat-contract? v)
+                  ;; numbers used as contracts compare with =, but TR
+                  ;; requires an equal? check
+                  (not (number? v))
+                  ;; regexps don't match themselves when used as contracts
+                  (not (regexp? v)))
+             (flat/sc #`(quote #,v))
+             (flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))) v))]
         [(Param: in out) 
          (parameter/sc (t->sc in) (t->sc out))]
         [(Hashtable: k v)
@@ -560,17 +649,21 @@
   ;; and call the given thunk or raise an error
   (define (handle-range arr convert-arr)
     (match arr
-      ;; functions with no filters or objects
-      [(arr: dom (Values: (list (Result: rngs (FilterSet: (Top:) (Top:)) (Empty:)) ...)) rst drst kws)
+      ;; functions with no props or objects
+      [(arr: dom (Values: (list (Result: rngs
+                                         (PropSet: (TrueProp:)
+                                                   (TrueProp:))
+                                         (Empty:)) ...))
+             rst drst kws)
        (convert-arr)]
       ;; Functions that don't return
       [(arr: dom (Values: (list (Result: (== -Bottom) _ _) ...)) rst drst kws)
        (convert-arr)]
-      ;; functions with filters or objects
+      ;; functions with props or objects
       [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst drst kws)
        (if (from-untyped? typed-side)
            (fail #:reason (~a "cannot generate contract for function type"
-                              " with filters or objects."))
+                              " with props or objects."))
            (convert-arr))]
       [(arr: dom (? ValuesDots?) rst drst kws)
        (fail #:reason (~a "cannot generate contract for function type"
@@ -612,7 +705,7 @@
                      (map conv opt-kws))))
          (define range (map t->sc rngs))
          (define rest (and rst (listof/sc (t->sc/neg rst))))
-         (function/sc (process-dom mand-args) opt-args mand-kws opt-kws rest range))
+         (function/sc (from-typed? typed-side) (process-dom mand-args) opt-args mand-kws opt-kws rest range))
        (handle-range first-arr convert-arr)]
       [else
        (define ((f case->) a)
@@ -629,6 +722,7 @@
                           (and rst (listof/sc (t->sc/neg rst)))
                           (map t->sc rngs))
                   (function/sc
+                    (from-typed? typed-side)
                     (process-dom (map t->sc/neg dom))
                     null
                     (map conv mand-kws)
@@ -692,9 +786,8 @@
           (define rv (for/fold ((rv recursive-values)) ((temp temporaries)
                                                         (v-nm vs-nm))
                        (hash-set rv v-nm (same (parametric-var/sc temp)))))
-          (parameterize ([bound-names (append (bound-names) vs-nm)])
-            (parametric->/sc temporaries
-              (t->sc b #:recursive-values rv)))))))
+          (parametric->/sc temporaries
+            (t->sc b #:recursive-values rv))))))
 
 ;; Generate a contract for a variable-arity polymorphic function type
 (define (t->sc/polydots type fail typed-side recursive-values t->sc)
@@ -732,12 +825,11 @@
                                ([temp temporaries]
                                 [v-nm vs-nm])
                        (hash-set rv v-nm (same (sealing-var/sc temp)))))
-          (parameterize ([bound-names (append (bound-names) vs-nm)])
-            ;; Only the first three sets of constraints seem to be needed
-            ;; since augment clauses don't make sense without a corresponding
-            ;; public method too. This invariant has to be enforced though.
-            (sealing->/sc temporaries (take constraints 3)
-              (t->sc b #:recursive-values rv)))))))
+          ;; Only the first three sets of constraints seem to be needed
+          ;; since augment clauses don't make sense without a corresponding
+          ;; public method too. This invariant has to be enforced though.
+          (sealing->/sc temporaries (take constraints 3)
+            (t->sc b #:recursive-values rv))))))
 
 ;; Predicate that checks for an App type with a recursive
 ;; Name type in application position
@@ -745,7 +837,7 @@
   (let/ec escape
     (let loop ([type type])
       (type-case
-       (#:Type loop #:Filter (sub-f loop) #:Object (sub-o loop))
+       (#:Type loop #:Prop (sub-f loop) #:Object (sub-o loop))
        type
        [#:App arg _ _
         (match arg
@@ -753,6 +845,15 @@
           [_ type])]))
     #f))
 
+;; True if the arities `arrs` are what we'd expect from a struct predicate
+(define (any->bool? arrs)
+  (match arrs
+    [(list (arr: (list (Univ:))
+                 (Values: (list (Result: t _ _)))
+                 #f #f '()))
+     (t:subtype -Boolean t)]
+    [_ #f]))
+
 (module predicates racket/base
   (require racket/extflonum)
   (provide nonnegative? nonpositive?
@@ -788,7 +889,7 @@
   (define positive-integer/sc (numeric/sc Positive-Integer (and/c exact-integer? positive?)))
   (define natural/sc (numeric/sc Natural exact-nonnegative-integer?))
   (define negative-integer/sc (numeric/sc Negative-Integer (and/c exact-integer? negative?)))
-  (define nonpositive-integer/sc (numeric/sc Nonpositive-Integer (and/c exact-integer? nonpostive?)))
+  (define nonpositive-integer/sc (numeric/sc Nonpositive-Integer (and/c exact-integer? nonpositive?)))
   (define integer/sc (numeric/sc Integer exact-integer?))
   (define positive-rational/sc (numeric/sc Positive-Rational (and/c t:exact-rational? positive?)))
   (define nonnegative-rational/sc (numeric/sc Nonnegative-Rational (and/c t:exact-rational? nonnegative?)))

typed-racket-lib/typed-racket/private/with-types.rkt

@@ -154,10 +154,11 @@
 (define (type-stxs->ids+defs type-stxs typed-side)
   (for/lists (_1 _2) ([t (in-list type-stxs)])
     (define ctc-id (generate-temporary))
+    (define contract-def `#s(contract-def ,t #f #f ,typed-side))
     (values ctc-id
             #`(define-values (#,ctc-id)
                 #,(contract-def-property
-                   #'#f `#s(contract-def ,t #f #f ,typed-side))))))
+                   #'#f (λ () contract-def))))))
 
 (define (wt-core stx)
   (define-syntax-class typed-id

typed-racket-lib/typed-racket/rep/filter-rep.rkt

@@ -1,67 +1,4 @@
 #lang racket/base
 
-;;TODO use contract-req
-(require "rep-utils.rkt" "free-variance.rkt" racket/contract/base
-         racket/lazy-require)
-
-;; TODO use something other than lazy-require.
-(lazy-require ["type-rep.rkt" (Type/c Univ? Bottom?)]
-              ["object-rep.rkt" (Path?)])
-
-(provide Filter/c FilterSet/c name-ref/c hash-name filter-equal?)
-
-(define (Filter/c-predicate? e)
-  (and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e))))
-(define Filter/c (flat-named-contract 'Filter Filter/c-predicate?))
-
-(define FilterSet/c
-  (flat-named-contract
-   'FilterSet
-   (λ (e) (or (FilterSet? e) (NoFilter? e)))))
-
-;; A Name-Ref is any value that represents an object.
-;; As an identifier, it represents a free variable in the environment
-;; As a list, it represents a De Bruijn indexed bound variable
-(define name-ref/c (or/c identifier? (list/c integer? integer?)))
-(define (hash-name v) (if (identifier? v) (hash-id v) (list v)))
-
-(define ((length>=/c len) l)
-  (and (list? l)
-       (>= (length l) len)))
-
-(def-filter Bot () [#:fold-rhs #:base])
-(def-filter Top () [#:fold-rhs #:base])
-
-(def-filter TypeFilter ([t (and/c Type/c (not/c Univ?) (not/c Bottom?))] [p Path?])
-  [#:intern (list (Rep-seq t) (Rep-seq p))]
-  [#:frees (λ (f) (combine-frees (map f (list t p))))]
-  [#:fold-rhs (*TypeFilter (type-rec-id t) (object-rec-id p))])
-
-(def-filter NotTypeFilter ([t (and/c Type/c (not/c Univ?) (not/c Bottom?))] [p Path?])
-  [#:intern (list (Rep-seq t) (Rep-seq p))]
-  [#:frees (λ (f) (combine-frees (map f (list t p))))]
-  [#:fold-rhs (*NotTypeFilter (type-rec-id t) (object-rec-id p))])
-
-;; implication
-(def-filter ImpFilter ([a Filter/c] [c Filter/c]))
-
-(def-filter OrFilter ([fs (and/c (length>=/c 2)
-                                 (listof (or/c TypeFilter? NotTypeFilter? ImpFilter?)))])
-  [#:intern (map Rep-seq fs)]
-  [#:fold-rhs (*OrFilter (map filter-rec-id fs))]
-  [#:frees (λ (f) (combine-frees (map f fs)))])
-
-(def-filter AndFilter ([fs (and/c (length>=/c 2)
-                                  (listof (or/c OrFilter? TypeFilter? NotTypeFilter? ImpFilter?)))])
-  [#:intern (map Rep-seq fs)]
-  [#:fold-rhs (*AndFilter (map filter-rec-id fs))]
-  [#:frees (λ (f) (combine-frees (map f fs)))])
-
-(def-filter FilterSet ([thn Filter/c] [els Filter/c])
-  [#:fold-rhs (*FilterSet (filter-rec-id thn) (filter-rec-id els))])
-
-;; represents no info about the filters of this expression
-;; should only be used for parsing type annotations and expected types
-(def-filter NoFilter () [#:fold-rhs #:base])
-
-(define (filter-equal? a b) (= (Rep-seq a) (Rep-seq b)))
+(require "prop-rep.rkt")
+(provide (all-from-out "prop-rep.rkt"))

typed-racket-lib/typed-racket/rep/object-rep.rkt

@@ -5,7 +5,7 @@
 ;;
 ;; See "Logical Types for Untyped Languages" pg.3
 
-(require "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt" "../utils/utils.rkt" (contract-req))
+(require "rep-utils.rkt" "free-variance.rkt" "prop-rep.rkt" "../utils/utils.rkt" (contract-req))
 (provide object-equal?)
 
 (def-pathelem CarPE () [#:fold-rhs #:base])
@@ -25,16 +25,4 @@
   [#:frees (λ (f) (combine-frees (map f p)))]
   [#:fold-rhs (*Path (map pathelem-rec-id p) v)])
 
-;; represents no info about the object of this expression
-;; should only be used for parsing type annotations and expected types
-(def-object NoObject () [#:fold-rhs #:base])
-
 (define (object-equal? o1 o2) (= (Rep-seq o1) (Rep-seq o2)))
-
-#|
-(dlo LEmpty () [#:fold-rhs #:base])
-
-(dlo LPath ([p (listof PathElem?)] [idx index/c])
-  [#:frees (λ (f) (combine-frees (map f p)))]
-  [#:fold-rhs (*LPath (map pathelem-rec-id p) idx)])
-|#

typed-racket-lib/typed-racket/rep/prop-rep.rkt

@@ -0,0 +1,56 @@
+#lang racket/base
+
+(require "../utils/utils.rkt" "rep-utils.rkt" "free-variance.rkt")
+
+(provide hash-name prop-equal?)
+
+(begin-for-cond-contract
+  (require racket/contract/base racket/lazy-require)
+  (lazy-require ["type-rep.rkt" (Type/c Univ? Bottom?)]
+                ["object-rep.rkt" (Path?)]))
+
+(provide-for-cond-contract name-ref/c)
+
+
+;; A Name-Ref is any value that represents an object.
+;; As an identifier, it represents a free variable in the environment
+;; As a list, it represents a De Bruijn indexed bound variable
+(define-for-cond-contract name-ref/c
+  (or/c identifier? (list/c integer? integer?)))
+(define (hash-name v) (if (identifier? v) (hash-id v) (list v)))
+
+(define-for-cond-contract ((length>=/c len) l)
+  (and (list? l)
+       (>= (length l) len)))
+
+;; the trivially "true" proposition
+(def-prop TrueProp () [#:fold-rhs #:base])
+;; the absurd, "false" proposition
+(def-prop FalseProp () [#:fold-rhs #:base])
+
+(def-prop TypeProp ([p Path?] [t (and/c Type/c (not/c Univ?) (not/c Bottom?))])
+  [#:intern (list (Rep-seq t) (Rep-seq p))]
+  [#:frees (λ (f) (combine-frees (map f (list t p))))]
+  [#:fold-rhs (*TypeProp (object-rec-id p) (type-rec-id t))])
+
+(def-prop NotTypeProp ([p Path?] [t (and/c Type/c (not/c Univ?) (not/c Bottom?))])
+  [#:intern (list (Rep-seq t) (Rep-seq p))]
+  [#:frees (λ (f) (combine-frees (map f (list t p))))]
+  [#:fold-rhs (*NotTypeProp (object-rec-id p) (type-rec-id t))])
+
+(def-prop OrProp ([fs (and/c (length>=/c 2)
+                           (listof (or/c TypeProp? NotTypeProp?)))])
+  [#:intern (map Rep-seq fs)]
+  [#:fold-rhs (*OrProp (map prop-rec-id fs))]
+  [#:frees (λ (f) (combine-frees (map f fs)))])
+
+(def-prop AndProp ([fs (and/c (length>=/c 2)
+                          (listof (or/c OrProp? TypeProp? NotTypeProp?)))])
+  [#:intern (map Rep-seq fs)]
+  [#:fold-rhs (*AndProp (map prop-rec-id fs))]
+  [#:frees (λ (f) (combine-frees (map f fs)))])
+
+(def-prop PropSet ([thn Prop?] [els Prop?])
+  [#:fold-rhs (*PropSet (prop-rec-id thn) (prop-rec-id els))])
+
+(define (prop-equal? a b) (= (Rep-seq a) (Rep-seq b)))

typed-racket-lib/typed-racket/rep/rep-utils.rkt

@@ -7,7 +7,6 @@
          "interning.rkt"
          racket/lazy-require
          racket/stxparam
-         racket/unsafe/ops
          (for-syntax
           racket/match
           (except-in syntax/parse id identifier keyword)
@@ -21,7 +20,7 @@
 
 
 (lazy-require
-  ["../types/printer.rkt" (print-type print-filter print-object print-pathelem)])
+  ["../types/printer.rkt" (print-type print-prop print-object print-pathelem)])
 
 
 (provide == defintern hash-id (for-syntax fold-target))
@@ -33,9 +32,9 @@
 (define-struct Rep (seq free-vars free-idxs stx) #:transparent
                #:methods gen:equal+hash
                [(define (equal-proc x y recur)
-                  (eq? (unsafe-Rep-seq x) (unsafe-Rep-seq y)))
-                (define (hash-proc x recur) (unsafe-Rep-seq x))
-                (define (hash2-proc x recur) (unsafe-Rep-seq x))])
+                  (eq? (Rep-seq x) (Rep-seq y)))
+                (define (hash-proc x recur) (Rep-seq x))
+                (define (hash2-proc x recur) (Rep-seq x))])
 
 ;; evil tricks for hygienic yet unhygienic-looking reference
 ;; in say def-type for type-ref-id
@@ -136,7 +135,7 @@
                           #:defaults
                           ([frees.f1 (combiner #'Rep-free-vars #'flds.fields)]
                            [frees.f2 (combiner #'Rep-free-idxs #'flds.fields)]))
-               ;; This tricky beast is for defining the type/filter/etc.'s
+               ;; This tricky beast is for defining the type/prop/etc.'s
                ;; part of the fold. The make-prim-type's given
                ;; rec-ids are bound in this expression's context.
                (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'name.fold))]
@@ -205,7 +204,7 @@
             provides))])))
 
 ;; rec-ids are identifiers that are of the folded type, so we recur on them.
-;; kws is e.g. '(#:Type #:Filter #:Object #:PathElem)
+;; kws is e.g. '(#:Type #:Prop #:Object #:PathElem)
 (define-for-syntax (mk-fold hashtable rec-ids kws)
   (lambda (stx)
     (define new-hashtable (make-hasheq))
@@ -218,7 +217,7 @@
                         (syntax/loc this-syntax (pats ...))
                         (lambda () #'e)
                         this-syntax))
-      ;; Match on a type (or filter etc) case with keyword k
+      ;; Match on a type (or prop etc) case with keyword k
       ;; pats are the unignored patterns (say for rator rand)
       ;; and e is the expression that will run as fold-rhs.
       (pattern
@@ -352,23 +351,18 @@
                            ;; [unsyntax (*1)]
                            (mk-fold ht
                                     rec-ids
-                                    ;; '(#:Type #:Filter #:Object #:PathElem)
+                                    ;; '(#:Type #:Prop #:Object #:PathElem)
                                     '(i.kw ...)))
                          (list i.hashtable ...))))))]))
 
 (make-prim-type [Type def-type #:Type type-case print-type type-name-ht type-rec-id #:key]
-                [Filter def-filter #:Filter filter-case print-filter filter-name-ht filter-rec-id]
+                [Prop def-prop #:Prop prop-case print-prop prop-name-ht prop-rec-id]
                 [Object def-object #:Object object-case print-object object-name-ht object-rec-id]
                 [PathElem def-pathelem #:PathElem pathelem-case print-pathelem pathelem-name-ht pathelem-rec-id])
 
-;; NOTE: change these if the definitions above change, or everything will segfault
-(define-syntax-rule (unsafe-Rep-seq v) (unsafe-struct*-ref v 0))
-(define-syntax-rule (unsafe-Type-key v) (unsafe-struct*-ref v 4))
-(provide unsafe-Rep-seq unsafe-Type-key)
-
 (define (Rep-values rep)
   (match rep
-    [(? (lambda (e) (or (Filter? e)
+    [(? (lambda (e) (or (Prop? e)
                         (Object? e)
                         (PathElem? e)))
         (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq fv fi stx vals)))
@@ -392,7 +386,7 @@
 (provide/cond-contract
   [rename rep-equal? type-equal? (Type? Type? . -> . boolean?)]
   [rename rep<? type<? (Type? Type? . -> . boolean?)]
-  [rename rep<? filter<? (Filter? Filter? . -> . boolean?)]
+  [rename rep<? prop<? (Prop? Prop? . -> . boolean?)]
   [struct Rep ([seq exact-nonnegative-integer?]
                [free-vars (hash/c symbol? variance?)]
                [free-idxs (hash/c symbol? variance?)]

typed-racket-lib/typed-racket/rep/type-rep.rkt

@@ -7,10 +7,11 @@
 
 ;; TODO use contract-req
 (require (utils tc-utils)
-         "rep-utils.rkt" "object-rep.rkt" "filter-rep.rkt" "free-variance.rkt"
-         racket/match racket/list
+         "rep-utils.rkt" "object-rep.rkt" "prop-rep.rkt" "free-variance.rkt"
+         racket/match racket/list racket/set
          racket/contract
          racket/lazy-require
+         racket/promise
          (for-syntax racket/base syntax/parse))
 
 (provide Mu-name:
@@ -18,10 +19,11 @@
          PolyDots-names:
          PolyRow-names: PolyRow-fresh:
          Type-seq
+         -unsafe-intersect
          Mu-unsafe: Poly-unsafe:
          PolyDots-unsafe:
          Mu? Poly? PolyDots? PolyRow?
-         Filter? Object?
+         Prop? Object?
          Type/c Type/c?
          Values/c SomeValues/c
          Bottom?
@@ -52,32 +54,33 @@
 
 ;; Ugly hack - should use units
 (lazy-require
-  ("../types/union.rkt" (Un))
-  ("../types/resolve.rkt" (resolve-app)))
+ ("../types/union.rkt" (Un))
+ ("../types/overlap.rkt" (overlap?))
+ ("../types/resolve.rkt" (resolve-app)))
 
 (define name-table (make-weak-hasheq))
 
 (define Type/c?
    (λ (e)
      (and (Type? e)
-          (not (Scope? e))
           (not (arr? e))
           (not (fld? e))
           (not (Values? e))
           (not (ValuesDots? e))
           (not (AnyValues? e))
-          (not (Result? e)))))
+          (not (Result? e))
+          (not (Signature? e)))))
 
 ;; (or/c Type/c Values? Results?)
 ;; Anything that can be treated as a Values by sufficient expansion
 (define Values/c?
    (λ (e)
      (and (Type? e)
-          (not (Scope? e))
           (not (arr? e))
           (not (fld? e))
           (not (ValuesDots? e))
-          (not (AnyValues? e)))))
+          (not (AnyValues? e))
+          (not (Signature? e)))))
 
 (define Type/c (flat-named-contract 'Type Type/c?))
 (define Values/c (flat-named-contract 'Values Values/c?))
@@ -90,19 +93,6 @@
 
 ;; Type is defined in rep-utils.rkt
 
-;; t must be a Type
-(def-type Scope ([t (or/c Type/c Scope?)]) [#:key (Type-key t)])
-
-(define (scope-depth k)
-  (flat-named-contract
-   (format "Scope of depth ~a" k)
-   (lambda (sc)
-     (define (f k sc)
-       (cond [(= 0 k) (Type/c? sc)]
-             [(not (Scope? sc)) #f]
-             [else (f (sub1 k) (Scope-t sc))]))
-     (f k sc))))
-
 ;; this is ONLY used when a type error ocurrs
 (def-type Error () [#:frees #f] [#:fold-rhs #:base])
 
@@ -236,48 +226,43 @@
                [(Keyword) 'keyword]
                [else #f]))])
 
-;; body is a Scope
-(def-type Mu ([body (scope-depth 1)]) #:no-provide [#:frees (λ (f) (f body))]
-  [#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))]
+(def-type Mu ([body Type/c]) #:no-provide [#:frees (λ (f) (f body))]
+  [#:fold-rhs (*Mu (type-rec-id body))]
   [#:key (Type-key body)])
 
 ;; n is how many variables are bound here
-;; body is a Scope
+;; body is a type
 (def-type Poly (n body) #:no-provide
-  [#:contract (->i ([n natural-number/c]
-                    [body (n) (scope-depth n)])
+   [#:contract (->i ([n natural-number/c]
+                    [body Type/c])
                    (#:syntax [stx (or/c #f syntax?)])
                    [result Poly?])]
   [#:frees (λ (f) (f body))]
-  [#:fold-rhs (let ([body* (remove-scopes n body)])
-                (*Poly n (add-scopes n (type-rec-id body*))))]
+  [#:fold-rhs (*Poly n (type-rec-id body))]
   [#:key (Type-key body)])
 
 ;; n is how many variables are bound here
 ;; there are n-1 'normal' vars and 1 ... var
-;; body is a Scope
 (def-type PolyDots (n body) #:no-provide
   [#:contract (->i ([n natural-number/c]
-                    [body (n) (scope-depth n)])
+                    [body Type/c])
                    (#:syntax [stx (or/c #f syntax?)])
                    [result PolyDots?])]
   [#:key (Type-key body)]
   [#:frees (λ (f) (f body))]
-  [#:fold-rhs (let ([body* (remove-scopes n body)])
-                (*PolyDots n (add-scopes n (type-rec-id body*))))])
+  [#:fold-rhs (*PolyDots n (type-rec-id body))])
 
 ;; interp. A row polymorphic function type
 ;; constraints are row absence constraints, represented
 ;; as a set for each of init, field, methods
 (def-type PolyRow (constraints body) #:no-provide
   [#:contract (->i ([constraints (list/c list? list? list? list?)]
-                    [body (scope-depth 1)])
+                    [body Type/c])
                    (#:syntax [stx (or/c #f syntax?)])
                    [result PolyRow?])]
   [#:frees (λ (f) (f body))]
-  [#:fold-rhs (let ([body* (remove-scopes 1 body)])
-                (*PolyRow constraints
-                          (add-scopes 1 (type-rec-id body*))))]
+  [#:fold-rhs (*PolyRow constraints
+                        (type-rec-id body))]
   [#:key (Type-key body)])
 
 ;; pred : identifier
@@ -291,9 +276,9 @@
   [#:frees (λ (f) (f ty))]
   [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)])
 
-(def-type Result ([t Type/c] [f FilterSet?] [o Object?])
+(def-type Result ([t Type/c] [f PropSet?] [o Object?])
   [#:frees (λ (frees) (combine-frees (map frees (list t f o))))]
-  [#:fold-rhs (*Result (type-rec-id t) (filter-rec-id f) (object-rec-id o))])
+  [#:fold-rhs (*Result (type-rec-id t) (prop-rec-id f) (object-rec-id o))])
 
 (def-type Values ([rs (listof Result?)])
   [#:intern (map Rep-seq rs)]
@@ -301,7 +286,7 @@
   [#:fold-rhs (*Values (map type-rec-id rs))])
 
 
-(def-type AnyValues ([f Filter/c])
+(def-type AnyValues ([f Prop?])
   [#:fold-rhs #:base])
 
 (def-type ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)])
@@ -466,6 +451,55 @@
      (define d* (remove-duplicates d))
      (if (and (pair? d*) (null? (cdr d*))) (car d*) d*))])
 
+
+;; Intersection
+(def-type Intersection ([elems (and/c (set/c Type/c)
+                                      (λ (s) (>= (set-count s) 2)))])
+  [#:intern (for/set ([e (in-immutable-set elems)])
+              (Rep-seq e))]
+  [#:frees (λ (f) (combine-frees (for/list ([elem (in-immutable-set elems)])
+                                   (f elem))))]
+  [#:fold-rhs (let ([elems (for/list ([elem (in-immutable-set elems)])
+                             (type-rec-id elem))])
+                (apply -unsafe-intersect elems))]
+  [#:key (let ()
+           (define d
+             (let loop ([ts (set->list elems)] [res null])
+               (cond [(null? ts) res]
+                     [else
+                      (define k (Type-key (car ts)))
+                      (cond [(not k) (list #f)]
+                            [(pair? k) (loop (cdr ts) (append k res))]
+                            [else (loop (cdr ts) (cons k res))])])))
+           (define d* (remove-duplicates d))
+           (if (and (pair? d*) (null? (cdr d*))) (car d*) d*))])
+
+;;  constructor for intersections
+;; in general, intersections should be built
+;; using the 'intersect' operator, which worries
+;; about actual subtyping, etc...
+(define (-unsafe-intersect . ts)
+  (let loop ([elems (set)]
+             [ts ts])
+    (match ts
+      [(list)
+       (cond
+         [(set-empty? elems) (Univ)]
+         ;; size = 1 ?
+         [(= 1 (set-count elems)) (set-first elems)]
+         ;; size > 1, build an intersection
+         [else (*Intersection elems)])]
+      [(cons t ts)
+       (match t
+         [(? Bottom?) t]
+         [(Univ:) (loop elems ts)]
+         [(Intersection: ts*) (loop (set-union elems ts*) ts)]
+         [t (cond
+              [(for/or ([elem (in-immutable-set elems)]) (not (overlap? elem t)))
+               (*Union (list))]
+              [else (loop (set-add elems t) ts)])])])))
+
+
 (def-type Univ () [#:frees #f] [#:fold-rhs #:base])
 
 ;; in : Type
@@ -555,6 +589,35 @@
 ;; cls : Class
 (def-type Instance ([cls Type/c]) [#:key 'instance])
 
+;; interp:
+;; name is the id of the signature
+;; extends is the extended signature or #f
+;; mapping maps variables in a signature to their types
+;; This is not a type because signatures are not values
+(def-type Signature ([name identifier?]
+                     [extends (or/c identifier? #f)]
+                     [mapping (listof (cons/c identifier? (or/c promise? Type/c)))])
+  [#:frees (lambda (f) null)]
+  [#:fold-rhs (*Signature name extends mapping)])
+
+;; The supertype of all units, ie values recognized by the
+;; predicate unit?
+(def-type UnitTop () [#:fold-rhs #:base] [#:key 'unit])
+
+;; interp: imports is the list of imported signatures
+;;         exports is the list of exported signatures
+;;         init-depends is the list of init-depend signatures
+;;         result is the type of the body of the unit
+(def-type Unit ([imports (listof Signature?)]
+                [exports (listof Signature?)]
+                [init-depends (listof Signature?)]
+                [result SomeValues/c])
+  [#:frees (lambda (f) (f result))]
+  [#:fold-rhs (*Unit (map type-rec-id imports)
+                     (map type-rec-id exports)
+                     (map type-rec-id init-depends)
+                     (type-rec-id result))])
+
 ;; sequences
 ;; includes lists, vectors, etc
 ;; tys : sequence produces this set of values at each step
@@ -604,24 +667,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (add-scopes n t)
-  (if (zero? n) t
-      (add-scopes (sub1 n) (*Scope t))))
-
-(define (remove-scopes n sc)
-  (if (zero? n)
-      sc
-      (match sc
-        [(Scope: sc*) (remove-scopes (sub1 n) sc*)]
-        [_ (int-err "Tried to remove too many scopes: ~a" sc)])))
-
-
 (define ((sub-f st) e)
-  (filter-case (#:Type st
-                #:Filter (sub-f st)
-                #:PathElem (sub-pe st))
-               e))
+  (prop-case (#:Type st
+              #:Prop (sub-f st)
+              #:PathElem (sub-pe st))
+             e))
 
 
 (define ((sub-o st) e)
@@ -637,11 +687,11 @@
 
 (define ((sub-t st) e)
   (type-case (#:Type st
-              #:Filter (sub-f st))
+              #:Prop (sub-f st))
               e))
 
 
-;; abstract-many : Names Type -> Scope^n
+;; abstract-many : Names Type -> Type
 ;; where n is the length of names
 (define (abstract-many names ty)
   ;; mapping : dict[Type -> Natural]
@@ -658,7 +708,7 @@
                     (f (+ (cdr pr) outer)))]
               [else default]))
       (type-case
-        (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
+        (#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb))
        ty
        [#:F name* (transform name* *B ty)]
        ;; necessary to avoid infinite loops
@@ -681,27 +731,23 @@
        [#:ListDots dty dbound
                    (*ListDots (sb dty)
                               (transform dbound values dbound))]
-       [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
-       [#:PolyRow constraints body*
-                  (let ([body (remove-scopes 1 body*)])
-                    (*PolyRow constraints
-                              (add-scopes 1 (loop (+ 1 outer) body))))]
-       [#:PolyDots n body*
-                   (let ([body (remove-scopes n body*)])
-                     (*PolyDots n (add-scopes n (loop (+ n outer) body))))]
-       [#:Poly n body*
-               (let ([body (remove-scopes n body*)])
-                 (*Poly n (add-scopes n (loop (+ n outer) body))))])))
+       [#:Mu body (*Mu (loop (add1 outer) body))]
+       [#:PolyRow constraints body
+                  (*PolyRow constraints (loop (+ 1 outer) body))]
+       [#:PolyDots n body
+                   (*PolyDots n (loop (+ n outer) body))]
+       [#:Poly n body
+               (*Poly n (loop (+ n outer) body))])))
   (define n (length names))
   (define mapping (for/list ([nm (in-list names)]
                              [i (in-range n 0 -1)])
                     (cons nm (sub1 i))))
-  (add-scopes n (nameTo mapping ty)))
+  (nameTo mapping ty))
 
-;; instantiate-many : List[Type] Scope^n -> Type
+;; instantiate-many : List[Type] Type -> Type
 ;; where n is the length of types
 ;; all of the types MUST be Fs
-(define (instantiate-many images sc)
+(define (instantiate-many images ty)
   ;; mapping : dict[Natural -> Type]
   (define (replace mapping type)
     (let loop ([outer 0] [ty type])
@@ -716,7 +762,7 @@
       (define (sb t) (loop outer t))
       (define sf (sub-f sb))
       (type-case
-       (#:Type sb #:Filter sf #:Object (sub-o sb))
+       (#:Type sb #:Prop sf #:Object (sub-o sb))
        ty
        [#:B idx (transform idx values ty)]
        ;; necessary to avoid infinite loops
@@ -738,21 +784,18 @@
        [#:ListDots dty dbound
                    (*ListDots (sb dty)
                               (transform dbound F-n dbound))]
-       [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
-       [#:PolyRow constraints body*
-                  (let ([body (remove-scopes 1 body*)])
-                    (*PolyRow constraints (add-scopes 1 (loop (+ 1 outer) body))))]
-       [#:PolyDots n body*
-                   (let ([body (remove-scopes n body*)])
-                     (*PolyDots n (add-scopes n (loop (+ n outer) body))))]
-       [#:Poly n body*
-               (let ([body (remove-scopes n body*)])
-                 (*Poly n (add-scopes n (loop (+ n outer) body))))])))
+       [#:Mu body (*Mu (loop (add1 outer) body))]
+       [#:PolyRow constraints body
+                  (*PolyRow constraints (loop (+ 1 outer) body))]
+       [#:PolyDots n body
+                   (*PolyDots n (loop (+ n outer) body))]
+       [#:Poly n body
+               (*Poly n (loop (+ n outer) body))])))
   (define n (length images))
   (define mapping (for/list ([img (in-list images)]
                              [i (in-range n 0 -1)])
                     (cons (sub1 i) img)))
-  (replace mapping (remove-scopes n sc)))
+  (replace mapping ty))
 
 (define (abstract name ty)
   (abstract-many (list name) ty))
@@ -769,8 +812,8 @@
 ;; the 'smart' destructor
 (define (Mu-body* name t)
   (match t
-    [(Mu: scope)
-     (instantiate (*F name) scope)]))
+    [(Mu: body)
+     (instantiate (*F name) body)]))
 
 ;; the 'smart' constructor
 ;;
@@ -793,10 +836,10 @@
 ;; the 'smart' destructor
 (define (Poly-body* names t)
   (match t
-    [(Poly: n scope)
+    [(Poly: n body)
      (unless (= (length names) n)
        (int-err "Wrong number of names: expected ~a got ~a" n (length names)))
-     (instantiate-many (map *F names) scope)]))
+     (instantiate-many (map *F names) body)]))
 
 ;; the 'smart' constructor
 (define (PolyDots* names body)
@@ -808,10 +851,10 @@
 ;; the 'smart' destructor
 (define (PolyDots-body* names t)
   (match t
-    [(PolyDots: n scope)
+    [(PolyDots: n body)
      (unless (= (length names) n)
        (int-err "Wrong number of names: expected ~a got ~a" n (length names)))
-     (instantiate-many (map *F names) scope)]))
+     (instantiate-many (map *F names) body)]))
 
 ;; Constructor and destructor for row polymorphism
 ;;
@@ -826,15 +869,15 @@
 
 (define (PolyRow-body* names t)
   (match t
-    [(PolyRow: constraints scope)
-     (instantiate-many (map *F names) scope)]))
+    [(PolyRow: constraints body)
+     (instantiate-many (map *F names) body)]))
 
 (print-struct #t)
 
 (define-match-expander Mu-unsafe:
   (lambda (stx)
     (syntax-case stx ()
-      [(_ bp) #'(? Mu? (app (lambda (t) (Scope-t (Mu-body t))) bp))])))
+      [(_ bp) #'(? Mu? (app (lambda (t) (Mu-body t)) bp))])))
 
 (define-match-expander Poly-unsafe:
   (lambda (stx)

typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt

@@ -28,7 +28,8 @@
           [(define (sc-map v f) v)
            (define (sc-traverse v f) (void))
            (define (sc->contract v f) #'any/c)
-           (define (sc->constraints v f) (simple-contract-restrict 'flat))]
+           (define (sc->constraints v f) (simple-contract-restrict 'flat))
+           (define (sc-terminal-kind v) 'flat)]
         #:methods gen:custom-write [(define write-proc any-write-proc)])
 
 (define-match-expander any/sc:

typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt

@@ -5,7 +5,6 @@
 
 (require "../structures.rkt" "../constraints.rkt"
          racket/list racket/match
-         unstable/contract
          racket/contract
          (for-template racket/base racket/contract/base)
          (for-syntax racket/base syntax/parse))
@@ -14,8 +13,8 @@
   (contract-out
     [case->/sc ((listof arr-combinator?) . -> . static-contract?)]
     [arr/sc (-> (listof static-contract?)
-                (maybe/c static-contract?)
-                (maybe/c (listof static-contract?))
+                (or/c static-contract? #f)
+                (or/c (listof static-contract?) #f)
                 static-contract?)])
   case->/sc:
   arr/sc:

typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt

@@ -5,14 +5,13 @@
 
 (require "../structures.rkt" "../constraints.rkt"
          racket/list racket/match
-         unstable/contract
          racket/contract
          (for-template racket/base racket/contract/base)
          (for-syntax racket/base syntax/parse))
 
 (provide
   (contract-out
-    [prompt-tag/sc ((listof static-contract?) (maybe/c (listof static-contract?)) . -> . static-contract?)])
+    [prompt-tag/sc ((listof static-contract?) (or/c (listof static-contract?) #f) . -> . static-contract?)])
   prompt-tag/sc:)
 
 (struct prompt-tag-combinator combinator ()

typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt

@@ -6,7 +6,7 @@
 
 (require "simple.rkt" "structural.rkt"
          (for-template racket/base racket/list racket/set racket/promise
-                       racket/class racket/async-channel))
+                       racket/class racket/unit racket/async-channel))
 (provide (all-defined-out))
 
 (define identifier?/sc (flat/sc #'identifier?))
@@ -34,5 +34,6 @@
 (define continuation-mark-key?/sc (flat/sc #'continuation-mark-key?))
 
 (define class?/sc (flat/sc #'class?))
+(define unit?/sc (flat/sc #'unit?))
 
 (define struct-type?/sc (flat/sc #'struct-type?))

typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt

@@ -6,12 +6,13 @@
 (require "../structures.rkt" "../constraints.rkt"
          racket/list racket/match
          racket/contract
-         (for-template racket/base racket/contract/base)
+         (for-template racket/base racket/contract/base "../../utils/simple-result-arrow.rkt")
          (for-syntax racket/base syntax/parse))
 
 (provide
   (contract-out
-    [function/sc (-> (listof static-contract?)
+    [function/sc (-> boolean?
+                     (listof static-contract?)
                      (listof static-contract?)
                      (listof (list/c keyword? static-contract?))
                      (listof (list/c keyword? static-contract?))
@@ -21,7 +22,7 @@
   ->/sc:)
 
 
-(struct function-combinator combinator (indices mand-kws opt-kws)
+(struct function-combinator combinator (indices mand-kws opt-kws typed-side?)
         #:property prop:combinator-name "->/sc"
         #:methods gen:equal+hash [(define (equal-proc a b recur) (function-sc-equal? a b recur))
                                   (define (hash-proc v recur) (function-sc-hash v recur))
@@ -30,6 +31,7 @@
           [(define (sc->contract v f) (function-sc->contract v f))
            (define (sc-map v f) (function-sc-map v f))
            (define (sc-traverse v f) (function-sc-map v f) (void))
+           (define (sc-terminal-kind v) (function-sc-terminal-kind v))
            (define (sc->constraints v f) (function-sc-constraints v f))])
 
 (define (split-function-args ctcs mand-args-end opt-args-end
@@ -44,7 +46,10 @@
     (and range-end (drop (take ctcs range-end) rest-end))))
 
 (define (function-sc->contract sc recur)
-  (match-define (function-combinator args indices mand-kws opt-kws) sc) 
+  (match-define (function-combinator args indices mand-kws opt-kws typed-side?) sc)
+
+  (define-values (mand-scs opt-scs mand-kw-scs opt-kw-scs rest-sc range-scs)
+    (apply split-function-args args indices))
 
   (define-values (mand-ctcs opt-ctcs mand-kw-ctcs opt-kw-ctcs rest-ctc range-ctcs)
     (apply split-function-args (map recur args) indices))
@@ -61,14 +66,24 @@
       #`(values #,@range-ctcs)
       #'any))
 
-
-  #`((#,@mand-ctcs #,@mand-kws-stx)
-     (#,@opt-ctcs #,@opt-kws-stx) 
-     #,@rest-ctc-stx
-     . ->* . #,range-ctc))
+  (cond
+   [(and (null? mand-kws) (null? opt-kws)
+         (null? opt-ctcs)
+         (not rest-ctc)
+         ;; currently simple-result-> only handles up to arity 3
+         (member (length mand-ctcs) '(0 1 2 3))
+         (and range-ctcs (= 1 (length range-ctcs)))
+         (for/and ([a args]) (eq? 'flat (sc-terminal-kind a)))
+         (not typed-side?))
+    #`(simple-result-> #,@range-ctcs #,(length mand-ctcs))]
+   [else
+    #`((#,@mand-ctcs #,@mand-kws-stx)
+       (#,@opt-ctcs #,@opt-kws-stx)
+       #,@rest-ctc-stx
+       . ->* . #,range-ctc)]))
 
 
-(define (function/sc mand-args opt-args mand-kw-args opt-kw-args rest range)
+(define (function/sc typed-side? mand-args opt-args mand-kw-args opt-kw-args rest range)
   (define mand-args-end (length mand-args))
   (define opt-args-end (+ mand-args-end (length opt-args)))
   (define mand-kw-args-end (+ opt-args-end (length mand-kw-args)))
@@ -90,14 +105,15 @@
       (or range null))
     end-indices
     mand-kws
-    opt-kws))
+    opt-kws
+    typed-side?))
 
 (define-match-expander ->/sc:
   (syntax-parser
     [(_ mand-args opt-args mand-kw-args opt-kw-args rest range)
      #'(and (? function-combinator?)
             (app (match-lambda
-                   [(function-combinator args indices mand-kws opt-kws)
+                   [(function-combinator args indices mand-kws opt-kws typed-side?)
                     (define-values (mand-args* opt-args* mand-kw-args* opt-kw-args* rest* range*)
                       (apply split-function-args args indices))
                     (list
@@ -109,13 +125,13 @@
                  (list mand-args opt-args mand-kw-args opt-kw-args rest range)))]))
 
 (define (function-sc-map v f)
-  (match-define (function-combinator args indices mand-kws opt-kws) v) 
+  (match-define (function-combinator args indices mand-kws opt-kws typed-side?) v)
 
   (define-values (mand-args opt-args mand-kw-args opt-kw-args rest-arg range-args)
     (apply split-function-args args indices))
 
   (define new-args
-    (append 
+    (append
       (map (lambda (arg) (f arg 'contravariant))
            (append mand-args opt-args mand-kw-args opt-kw-args (if rest-arg (list rest-arg) null)))
       (if range-args
@@ -124,26 +140,49 @@
           empty)))
 
 
-  (function-combinator new-args indices mand-kws opt-kws))
+  (function-combinator new-args indices mand-kws opt-kws typed-side?))
+
+(define (function-sc-terminal-kind v)
+  (match-define (function-combinator args indices mand-kws opt-kws typed-side?) v)
+  (define-values (mand-args opt-args mand-kw-args opt-kw-args rest-arg range-args)
+    (apply split-function-args args indices))
+  (if (and (not rest-arg)
+           (null? (append mand-kw-args mand-args opt-kw-args opt-args))
+           typed-side?)
+      ;; currently we only handle this trivial case
+      ;; we could probably look at the actual kind of `range-args` as well
+      (if (not range-args) 'flat #f)
+      #f))
+
 
 (define (function-sc-constraints v f)
-  (match-define (function-combinator args indices mand-kws opt-kws) v) 
-  (merge-restricts* 'chaperone (map f args)))
+  (match-define (function-combinator args indices mand-kws opt-kws typed-side?) v)
+  (define-values (mand-args opt-args mand-kw-args opt-kw-args rest-arg range-args)
+    (apply split-function-args args indices))
+  (if (and (not rest-arg)
+           (null? (append mand-kw-args mand-args opt-kw-args opt-args))
+           typed-side?)
+      ;; arity-0 functions end up being flat contracts when they're
+      ;; from the typed side and the result is flat
+      (if range-args
+          (merge-restricts* 'flat (map f range-args))
+          (merge-restricts* 'flat null))
+      (merge-restricts* 'chaperone (map f args))))
 
 (define (function-sc-equal? a b recur)
-  (match-define (function-combinator a-args a-indices a-mand-kws a-opt-kws) a) 
-  (match-define (function-combinator b-args b-indices b-mand-kws b-opt-kws) b) 
+  (match-define (function-combinator a-args a-indices a-mand-kws a-opt-kws a-typed-side?) a)
+  (match-define (function-combinator b-args b-indices b-mand-kws b-opt-kws b-typed-side?) b)
   (and
+    (equal? a-typed-side? b-typed-side?)
     (recur a-indices b-indices)
     (recur a-mand-kws b-mand-kws)
     (recur a-opt-kws b-opt-kws)
     (recur a-args b-args)))
 
 (define (function-sc-hash v recur)
-  (match-define (function-combinator v-args v-indices v-mand-kws v-opt-kws) v) 
+  (match-define (function-combinator v-args v-indices v-mand-kws v-opt-kws typed-side?) v)
   (+ (recur v-indices) (recur v-mand-kws) (recur v-opt-kws) (recur v-args)))
 
 (define (function-sc-hash2 v recur)
-  (match-define (function-combinator v-args v-indices v-mand-kws v-opt-kws) v) 
+  (match-define (function-combinator v-args v-indices v-mand-kws v-opt-kws typed-side?) v)
   (+ (recur v-indices) (recur v-mand-kws) (recur v-opt-kws) (recur v-args)))
-

typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt

@@ -33,6 +33,25 @@
 
 (struct simple-contract static-contract (syntax kind name)
         #:transparent
+        #:methods gen:equal+hash
+         [(define (equal-proc s1 s2 recur)
+            (and ;; only check s-expression equality because it's
+                 ;; unlikely that TR will compile contracts that are
+                 ;; s-exp equal but aren't actually the same contract
+                 (recur (syntax->datum (simple-contract-syntax s1))
+                        (syntax->datum (simple-contract-syntax s2)))
+                 (recur (simple-contract-kind s1)
+                        (simple-contract-kind s2))
+                 (recur (simple-contract-name s1)
+                        (simple-contract-name s2))))
+          (define (hash-proc sc hash-code)
+            (hash-code (list (syntax->datum (simple-contract-syntax sc))
+                             (simple-contract-kind sc)
+                             (simple-contract-name sc))))
+          (define (hash2-proc sc hash-code)
+            (hash-code (list (syntax->datum (simple-contract-syntax sc))
+                             (simple-contract-kind sc)
+                             (simple-contract-name sc))))]
         #:methods gen:sc
          [(define (sc-map v f) v)
           (define (sc-traverse v f) (void))

typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt

@@ -8,14 +8,15 @@
          racket/match
          (for-syntax racket/base racket/syntax syntax/stx syntax/parse)
          racket/set
-         unstable/contract
+         racket/sequence
          (for-template racket/base
                        racket/contract/base
                        racket/set
                        racket/async-channel
-                       unstable/contract
+                       racket/sequence
                        racket/promise
-                       "../../utils/evt-contract.rkt")
+                       "../../utils/evt-contract.rkt"
+                       "../../utils/promise-not-name-contract.rkt")
          racket/contract
          racket/async-channel)
 
@@ -153,7 +154,7 @@
   ((set/sc (#:covariant #:chaperone)) set/c #:flat)
   ((vector/sc . (#:invariant)) vector/c #:chaperone)
   ((vectorof/sc (#:invariant)) vectorof #:chaperone)
-  ((promise/sc (#:covariant)) (λ (x) (and/c (promise/c x) (not/c promise/name?))) #:chaperone)
+  ((promise/sc (#:covariant)) promise-not-name/c #:chaperone)
   ((syntax/sc (#:covariant #:flat)) syntax/c #:flat)
   ((hash/sc (#:invariant #:flat) (#:invariant)) hash/c #:chaperone)
   ((box/sc (#:invariant)) box/c #:chaperone)

typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt

@@ -0,0 +1,109 @@
+#lang racket/base
+
+;; Static contracts for unit contracts
+
+(require "../structures.rkt" "../constraints.rkt"
+         racket/list racket/match
+         racket/dict
+         racket/contract
+         racket/syntax
+         (for-template racket/base racket/unit)
+         (for-syntax racket/base syntax/parse))
+
+
+(provide
+ (contract-out 
+  [struct signature-spec ([name identifier?]
+                          [members (listof identifier?)]
+                          [scs (listof static-contract?)])]
+  [unit/sc (-> (listof signature-spec?) 
+               (listof signature-spec?)
+               (listof identifier?)
+               (listof static-contract?) 
+               static-contract?)]))
+
+
+(struct signature-spec (name members scs) #:transparent)
+
+(struct unit-combinator combinator ()
+        #:transparent
+        #:property prop:combinator-name "unit/sc"
+        #:methods gen:sc
+        [(define (sc-map v f) 
+           (match v
+             [(unit-combinator unit-spec)
+              (unit-combinator (unit-spec-sc-map f unit-spec))]))
+         (define (sc-traverse v f)
+           (match v
+             [(unit-combinator unit-spec)
+              (unit-spec-sc-map f unit-spec)
+              (void)]))
+         (define (sc->contract v f)
+           (unit/sc->contract v f))
+         (define (sc->constraints v f)
+           (merge-restricts* 'chaperone (map f (unit-spec->list (combinator-args v)))))])
+
+(define unit-spec->list
+  (match-lambda
+   [(unit-spec imports exports init-depends invoke)
+    (flatten (append (filter-map signature-spec-scs imports)
+                     (filter-map signature-spec-scs exports)
+                     ;; init-depends do not show up because
+                     ;; there are no contracts attached
+                     (filter-map (lambda (x) x) invoke)))]))
+
+(struct unit-spec (imports exports init-depends invoke) 
+        #:transparent
+        #:property prop:sequence unit-spec->list)
+
+(define (unit-spec-sc-map f seq)
+  (match seq
+    [(unit-spec imports exports init-depends invokes)
+     (unit-spec
+      (map (signature-spec-sc-map f) imports)
+      (map (signature-spec-sc-map f) exports)
+      ;; leave init-depends alone since they don't contain contracts
+      init-depends
+      (map (lambda (invoke) (and invoke (f invoke 'covariant))) invokes))]))
+
+(define ((signature-spec-sc-map f) seq)
+  (match seq
+    [(signature-spec name (list ids ...) (list scs ...))
+     (signature-spec
+      name
+      ids
+      (map (lambda (sc) (and sc (f sc 'invariant))) scs))]))
+
+
+(define (unit/sc->contract v f)
+  (match v
+    [(unit-combinator 
+      (unit-spec (list imports ...)
+                 (list exports ...)
+                 (list deps ...)
+                 (list invoke/scs ...)))
+     
+     (define (sig-spec->syntax sig-spec)
+       (match sig-spec
+         [(signature-spec name members scs)
+          (define member-stx
+            (map (lambda (id sc) #`(#,id #,(f sc))) members scs))
+          #`(#,name #,@member-stx)]))
+     
+     (define (invokes->contract lst)
+       (cond
+        ;; just a single contract
+        [(= 1 (length lst))
+         #`#,(f (first lst))]
+        ;; values contract
+        [else 
+         #`(values #,@(map f lst))]))
+     
+     #`(unit/c
+        (import #,@(map sig-spec->syntax imports))
+        (export #,@(map sig-spec->syntax exports))
+        (init-depend #,@deps)
+        #,(invokes->contract invoke/scs))]))
+
+(define (unit/sc imports exports init-depends invoke)
+  (unit-combinator (unit-spec imports exports init-depends invoke)))

typed-racket-lib/typed-racket/static-contracts/constraints.rkt

@@ -61,7 +61,8 @@
   contract-restrict-recursive-values
 
   contract-restrict?
-  )
+  contract-restrict-value
+  kind-max-max)
 
 (module structs racket/base
   (require racket/contract

typed-racket-lib/typed-racket/static-contracts/instantiate.rkt

@@ -23,7 +23,8 @@
     [instantiate
       (parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
                            (contract-kind? #:cache hash?)
-                           . ->* . (or/c a (list/c (listof syntax?) syntax?))))]))
+                           . ->* . (or/c a (list/c (listof syntax?) syntax?))))]
+    [should-inline-contract? (-> syntax? boolean?)]))
 
 ;; Providing these so that tests can work directly with them.
 (module* internals #f
@@ -47,9 +48,42 @@
             (contract-restrict-recursive-values (compute-constraints sc kind)))
           cache))))
 
+;; computes the definitions that are in / used by `sc`
+;; `(get-all-name-defs)` is not what we want directly, since it also includes
+;; definitions that were optimized away
+;; we restrict it to only variables bound in `sc`
+(define (compute-defs sc)
+  (define all-name-defs (get-all-name-defs))
+  ;; all-name-defs maps lists of ids to defs
+  ;; we want to match if any id in the list matches
+  (define (ref b) (for/first ([(k v) (in-dict all-name-defs)]
+                              #:when (for/or ([k* (in-list k)])
+                                       (free-identifier=? b k*)))
+                    (cons k v)))
+  (define bound '())
+  ;; ignores its second argument (variance, passed by sc-traverse)
+  (let loop ([sc sc] [_ #f])
+    (match sc
+      [(name/sc: name*)
+       (unless (member name* bound free-identifier=?)
+         (set! bound (cons name* bound))
+         ;; traverse what `name` refers to
+         (define r (ref name*))
+         ;; ref returns a rib, get the one definition we want
+         (define target (for/first ([k (car r)]
+                                    [v (cdr r)]
+                                    #:when (free-identifier=? name* k))
+                          v))
+         (loop target #f))]
+      [else (sc-traverse sc loop)]))
+  (for*/hash ([b (in-list bound)]
+              [v (in-value (ref b))]
+              #:when v)
+    (values (car v) (cdr v))))
+
 (define (compute-constraints sc max-kind)
   (define memo-table (make-hash))
-  (define name-defs (get-all-name-defs))
+  (define name-defs (compute-defs sc))
   (define (recur sc)
     (cond [(hash-ref memo-table sc #f)]
           [else
@@ -96,7 +130,9 @@
   (define bound-names (make-parameter null))
   ;; sc-queue : records the order in which to return syntax objects
   (define sc-queue null)
-  (define (recur sc)
+  ;; top-level? is #t only for the first call and not for recursive
+  ;; calls, which helps for inlining
+  (define (recur sc [top-level? #f])
     (cond [(and cache (hash-ref cache sc #f)) => car]
           [(arr/sc? sc) (make-contract sc)]
           [(or (parametric->/sc? sc) (sealing->/sc? sc))
@@ -111,7 +147,14 @@
            (make-contract sc)]
           [else
            (define ctc (make-contract sc))
-           (cond [cache
+           (cond [(and ;; when a contract benefits from inlining
+                       ;; (e.g., ->) and this contract appears
+                       ;; directly in a define-module-boundary-contract
+                       ;; position (i.e, top-level? is #t) then
+                       ;; don't generate a new identifier for it
+                       (or (not (should-inline-contract? ctc))
+                           (not top-level?))
+                       cache)
                   (define fresh-id (generate-temporary))
                   (hash-set! cache sc (cons fresh-id ctc))
                   (set! sc-queue (cons sc sc-queue))
@@ -137,8 +180,8 @@
                (recur body)))]
       [(? sc? sc)
        (sc->contract sc recur)]))
-  (define ctc (recur sc))
-  (define name-defs (get-all-name-defs))
+  (define ctc (recur sc #t))
+  (define name-defs (compute-defs sc))
   ;; These are extra contract definitions for the name static contracts
   ;; that are used for this type. Since these are shared across multiple
   ;; contracts from a single contract fixup pass, we use the name-defined
@@ -163,6 +206,17 @@
                   #`(define #,id #,ctc)))
         ctc))
 
+;; Determine whether the given contract syntax should be inlined or not.
+(define (should-inline-contract? stx)
+  (or
+   ;; no need to generate an extra def for things that are already identifiers
+   (identifier? stx)
+   ;; ->* are handled specially by the contract system
+   (let ([sexp (syntax-e stx)])
+     (and (pair? sexp)
+          (or (free-identifier=? (car sexp) #'->)
+              (free-identifier=? (car sexp) #'->*))))))
+
 ;; determine if a given name is free in the sc
 (define (name-free-in? name sc)
   (let/ec escape

typed-racket-lib/typed-racket/static-contracts/optimize.rkt

@@ -93,6 +93,7 @@
           (fail))
         ;; All the checks passed
         (function/sc
+          #t
           (take longest-args (length shortest-args))
           (drop longest-args (length shortest-args))
           empty
@@ -110,7 +111,7 @@
 (define (trusted-side-reduce sc)
   (match sc
     [(->/sc: mand-args opt-args mand-kw-args opt-kw-args rest-arg (list (any/sc:) ...))
-     (function/sc mand-args opt-args mand-kw-args opt-kw-args rest-arg #f)]
+     (function/sc #t mand-args opt-args mand-kw-args opt-kw-args rest-arg #f)]
     [(arr/sc: args rest (list (any/sc:) ...))
      (arr/sc args rest #f)]
     [(none/sc:) any/sc]

typed-racket-lib/typed-racket/tc-setup.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require "utils/utils.rkt"
+         syntax/kerncase
          syntax/stx
          racket/pretty racket/promise racket/lazy-require
          (env type-name-env type-alias-env mvar-env)
@@ -9,7 +10,8 @@
          (for-syntax racket/base)
          (for-template racket/base))
 (lazy-require [typed-racket/optimizer/optimizer (optimize-top)])
-(lazy-require [typed-racket/typecheck/tc-toplevel (tc-toplevel-form tc-module)])
+(lazy-require [typed-racket/typecheck/tc-toplevel (tc-module)])
+(lazy-require [typed-racket/typecheck/toplevel-trampoline (tc-toplevel-start)])
 
 (provide maybe-optimize init-current-type-names
          tc-module/full
@@ -36,7 +38,7 @@
 
 (define-logger online-check-syntax)
 
-(define (tc-setup orig-stx stx expand-ctxt do-expand checker k)
+(define (tc-setup orig-stx stx expand-ctxt do-expand stop-forms k)
   (set-box! typed-context? #t)
   ;(start-timing (syntax-property stx 'enclosing-module-name))
   (with-handlers
@@ -52,11 +54,11 @@
                    ;; reinitialize disappeared uses
                    [disappeared-use-todo      null]
                    [disappeared-bindings-todo null])
-      (define fully-expanded-stx (disarm* (do-expand stx expand-ctxt (list #'module*))))
+      (define expanded-stx (disarm* (do-expand stx expand-ctxt stop-forms)))
       (when (print-syntax?)
-        (pretty-print (syntax->datum fully-expanded-stx)))
+        (pretty-print (syntax->datum expanded-stx)))
       (do-time "Local Expand Done")
-      (let ([exprs (syntax->list (syntax-local-introduce fully-expanded-stx))])
+      (let ([exprs (syntax->list (syntax-local-introduce expanded-stx))])
         (when (pair? exprs)
           (log-message online-check-syntax-logger
                        'info
@@ -66,17 +68,24 @@
       ;; expansion errors to happen with out paying that cost
       (do-standard-inits)
       (do-time "Initialized Envs")
-      (find-mutated-vars fully-expanded-stx mvar-env)
-      (parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)]
-                     [expanded-module-stx fully-expanded-stx])
-        (do-time "Starting `checker'")
-        (call-with-values (λ () (checker fully-expanded-stx))
-          (λ results
-            (do-time "Typechecking Done")
-            (apply k fully-expanded-stx results)))))))
+      (find-mutated-vars expanded-stx mvar-env)
+      (k expanded-stx))))
 
-(define (tc-toplevel/full orig-stx stx k)
-  (tc-setup orig-stx stx 'top-level local-expand/capture* tc-toplevel-form k))
+;; for top-level use
+(define (tc-toplevel/full orig-stx stx)
+  (tc-setup orig-stx stx 'top-level
+            local-expand/capture* (kernel-form-identifier-list)
+            (λ (head-expanded-stx)
+              (do-time "Trampoline the top-level checker")
+              (tc-toplevel-start (or (orig-module-stx) orig-stx) head-expanded-stx))))
 
 (define (tc-module/full orig-stx stx k)
-  (tc-setup orig-stx stx 'module-begin local-expand tc-module k))
+  (tc-setup orig-stx stx 'module-begin local-expand (list #'module*)
+            (λ (fully-expanded-stx)
+              (do-time "Starting `checker'")
+              (parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)]
+                             [expanded-module-stx fully-expanded-stx])
+                (call-with-values (λ () (tc-module fully-expanded-stx))
+                  (λ results
+                    (do-time "Typechecking Done")
+                    (apply k fully-expanded-stx results)))))))

typed-racket-lib/typed-racket/typecheck/check-below.rkt

@@ -3,9 +3,9 @@
 (require "../utils/utils.rkt"
          racket/match (prefix-in - (contract-req))
          racket/format
-         (types utils union subtype filter-ops abbrev)
+         (types utils union subtype prop-ops abbrev)
          (utils tc-utils)
-         (rep type-rep object-rep filter-rep)
+         (rep type-rep object-rep prop-rep)
          (typecheck error-message))
 
 (provide/cond-contract
@@ -21,7 +21,7 @@
 
 (define (print-object o)
   (match o
-    [(or (NoObject:) (Empty:)) "no object"]
+    [(or #f (Empty:)) "no object"]
     [_ (format "object ~a" o)]))
 
 ;; If expected is #f, then just return tr1
@@ -45,37 +45,36 @@
     (value-string expected) (value-string actual)
     "mismatch in number of values"))
 
-;; fix-filter: FilterSet [FilterSet] -> FilterSet
-;; Turns NoFilter into the actual filter; leaves other filters alone.
-(define (fix-filter f [f2 -top-filter])
-  (match f
-    [(NoFilter:) f2]
-    [else f]))
+;; fix-props:
+;;  PropSet [PropSet] -> PropSet
+;;    or
+;;  Prop [Prop]       -> Prop
+;; Turns #f prop/propset into the actual prop; leaves other props alone.
+(define (fix-props p1 [p2 -tt-propset])
+  (or p1 p2))
 
 ;; fix-object: Object [Object] -> Object
-;; Turns NoObject into the actual object; leaves other objects alone.
-(define (fix-object o [o2 -empty-obj])
-  (match o
-    [(NoObject:) o2]
-    [else o]))
+;; Turns #f into the actual object; leaves other objects alone.
+(define (fix-object o1 [o2 -empty-obj])
+  (or o1 o2))
 
 ;; fix-results: tc-results -> tc-results
-;; Turns NoObject/NoFilter into the Empty/TopFilter
+;; Turns #f Prop or Obj into the Empty/Trivial
 (define (fix-results r)
   (match r
-    [(tc-any-results: f) (tc-any-results (fix-filter f -top))]
-    [(tc-results: ts fs os)
-     (ret ts (map fix-filter fs) (map fix-object os))]
-    [(tc-results: ts fs os dty dbound)
-     (ret ts (map fix-filter fs) (map fix-object os) dty dbound)]))
+    [(tc-any-results: f) (tc-any-results (fix-props f -tt))]
+    [(tc-results: ts ps os)
+     (ret ts (map fix-props ps) (map fix-object os))]
+    [(tc-results: ts ps os dty dbound)
+     (ret ts (map fix-props ps) (map fix-object os) dty dbound)]))
 
 (define (fix-results/bottom r)
   (match r
-    [(tc-any-results: f) (tc-any-results (fix-filter f -bot))]
-    [(tc-results: ts fs os)
-     (ret ts (for/list ([f fs]) (fix-filter f -bot-filter)) (map fix-object os))]
-    [(tc-results: ts fs os dty dbound)
-     (ret ts (for/list ([f fs]) (fix-filter f -bot-filter)) (map fix-object os) dty dbound)]))
+    [(tc-any-results: f) (tc-any-results (fix-props f -ff))]
+    [(tc-results: ts ps os)
+     (ret ts (for/list ([p ps]) (fix-props p -ff-propset)) (map fix-object os))]
+    [(tc-results: ts ps os dty dbound)
+     (ret ts (for/list ([p ps]) (fix-props p -ff-propset)) (map fix-object os) dty dbound)]))
 
 
 
@@ -84,74 +83,74 @@
 ;;                   (Type Results -> Type)
 ;;                   (Type Type -> Type))
 (define (check-below tr1 expected)
-  (define (filter-set-better? f1 f2)
-    (match* (f1 f2)
-      [(f f) #t]
-      [(f (NoFilter:)) #t]
-      [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-))
-       (and (implied-atomic? f2+ f1+)
-            (implied-atomic? f2- f1-))]
+  (define (prop-set-better? p1 p2)
+    (match* (p1 p2)
+      [(p p) #t]
+      [(p #f) #t]
+      [((PropSet: p1+ p1-) (PropSet: p2+ p2-))
+       (and (implies-atomic? p1+ p2+)
+            (implies-atomic? p1- p2-))]
       [(_ _) #f]))
   (define (object-better? o1 o2)
     (match* (o1 o2)
       [(o o) #t]
-      [(o (or (NoObject:) (Empty:))) #t]
+      [(o (or #f (Empty:))) #t]
       [(_ _) #f]))
-  (define (filter-better? f1 f2)
-    (or (NoFilter? f2)
-        (implied-atomic? f2 f1)))
+  (define (prop-better? p1 p2)
+    (or (not p2)
+        (implies-atomic? p1 p2)))
 
   (match* (tr1 expected)
     ;; This case has to be first so that bottom (exceptions, etc.) can be allowed in cases
     ;; where multiple values are expected.
-    ;; We can ignore the filters and objects in the actual value because they would never be about a value
+    ;; We can ignore the props and objects in the actual value because they would never be about a value
     [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _)
      (fix-results/bottom expected)]
 
-    [((tc-any-results: f1) (tc-any-results: f2))
-     (unless (filter-better? f1 f2)
-       (type-mismatch f2 f1 "mismatch in filter"))
-     (tc-any-results (fix-filter f2 f1))]
+    [((tc-any-results: p1) (tc-any-results: p2))
+     (unless (prop-better? p1 p2)
+       (type-mismatch p2 p1 "mismatch in proposition"))
+     (tc-any-results (fix-props p2 p1))]
 
-    [((or (tc-results: _ (list (FilterSet: fs+ fs-) ...) _)
-          (tc-results: _ (list (FilterSet: fs+ fs-) ...) _ _ _))
-      (tc-any-results: f2))
-     (define merged-filter (apply -and (map -or fs+ fs-)))
-     (unless (filter-better? merged-filter f2)
-       (type-mismatch f2 merged-filter "mismatch in filter"))
-     (tc-any-results (fix-filter f2 merged-filter))]
+    [((or (tc-results: _ (list (PropSet: fs+ fs-) ...) _)
+          (tc-results: _ (list (PropSet: fs+ fs-) ...) _ _ _))
+      (tc-any-results: p2))
+     (define merged-prop (apply -and (map -or fs+ fs-)))
+     (unless (prop-better? merged-prop p2)
+       (type-mismatch p2 merged-prop "mismatch in proposition"))
+     (tc-any-results (fix-props p2 merged-prop))]
 
 
-    [((tc-result1: t1 f1 o1) (tc-result1: t2 f2 o2))
+    [((tc-result1: t1 p1 o1) (tc-result1: t2 p2 o2))
      (cond
        [(not (subtype t1 t2))
         (expected-but-got t2 t1)]
-       [(and (not (filter-set-better? f1 f2))
+       [(and (not (prop-set-better? p1 p2))
              (object-better? o1 o2))
-        (type-mismatch f2 f1 "mismatch in filter")]
-       [(and (filter-set-better? f1 f2)
+        (type-mismatch p2 p1 "mismatch in proposition")]
+       [(and (prop-set-better? p1 p2)
              (not (object-better? o1 o2)))
         (type-mismatch (print-object o2) (print-object o1) "mismatch in object")]
-       [(and (not (filter-set-better? f1 f2))
+       [(and (not (prop-set-better? p1 p2))
              (not (object-better? o1 o2)))
-        (type-mismatch (format "`~a' and `~a'" f2 (print-object o2))
-                       (format "`~a' and `~a'" f1 (print-object o1))
-                       "mismatch in filter and object")])
-     (ret t2 (fix-filter f2 f1) (fix-object o2 o1))]
+        (type-mismatch (format "`~a' and `~a'" p2 (print-object o2))
+                       (format "`~a' and `~a'" p1 (print-object o1))
+                       "mismatch in proposition and object")])
+     (ret t2 (fix-props p2 p1) (fix-object o2 o1))]
 
     ;; case where expected is like (Values a ... a) but got something else
-    [((tc-results: t1 f1 o1) (tc-results: t2 f2 o2 dty dbound))
+    [((tc-results: t1 p1 o1) (tc-results: t2 p2 o2 dty dbound))
      (value-mismatch expected tr1)
      (fix-results expected)]
 
     ;; case where you have (Values a ... a) but expected something else
-    [((tc-results: t1 f1 o1 dty dbound) (tc-results: t2 f2 o2))
+    [((tc-results: t1 p1 o1 dty dbound) (tc-results: t2 p2 o2))
      (value-mismatch expected tr1)
      (fix-results expected)]
 
-    [((tc-results: t1 f1 o1 dty1 dbound)
-      (tc-results: t2 (list (or (NoFilter:) (FilterSet: (Top:) (Top:))) ...)
-                      (list (or (NoObject:) (Empty:)) ...) dty2 dbound))
+    [((tc-results: t1 p1 o1 dty1 dbound)
+      (tc-results: t2 (list (or #f (PropSet: (TrueProp:) (TrueProp:))) ...)
+                      (list (or #f (Empty:)) ...) dty2 dbound))
      (cond
        [(= (length t1) (length t2))
         (unless (andmap subtype t1 t2)
@@ -162,7 +161,7 @@
          (value-mismatch expected tr1)])
      (fix-results expected)]
 
-    [((tc-results: t1 f1 o1 dty1 dbound) (tc-results: t2 f2 o2 dty2 dbound))
+    [((tc-results: t1 p1 o1 dty1 dbound) (tc-results: t2 p2 o2 dty2 dbound))
      (cond
        [(= (length t1) (length t2))
         (unless (andmap subtype t1 t2)
@@ -173,9 +172,9 @@
          (value-mismatch expected tr1)])
      (fix-results expected)]
 
-    [((tc-results: t1 f1 o1)
-      (tc-results: t2 (list (or (NoFilter:) (FilterSet: (Top:) (Top:))) ...)
-                      (list (or (NoObject:) (Empty:)) ...)))
+    [((tc-results: t1 p1 o1)
+      (tc-results: t2 (list (or #f (PropSet: (TrueProp:) (TrueProp:))) ...)
+                      (list (or #f (Empty:)) ...)))
      (unless (= (length t1) (length t2))
        (value-mismatch expected tr1))
      (unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s))
@@ -189,7 +188,7 @@
        (expected-but-got (stringify t2) (stringify t1)))
      (fix-results expected)]
 
-    [((tc-results: t1 f1 o1) (tc-results: t2 f2 o2)) (=> continue)
+    [((tc-results: t1 p1 o1) (tc-results: t2 p2 o2)) (=> continue)
      (if (= (length t1) (length t2))
          (continue)
          (value-mismatch expected tr1))
@@ -204,5 +203,5 @@
        (expected-but-got t2 t1))
      expected]
     [((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*))
-     (int-err "dotted types with different bounds/filters/objects in check-below nyi: ~a ~a" tr1 expected)]
+     (int-err "dotted types with different bounds/propositions/objects in check-below nyi: ~a ~a" tr1 expected)]
     [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)]))

typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt

@@ -461,7 +461,7 @@
   (define-values (alias-names alias-map) (get-type-alias-info type-aliases))
   (register-all-type-aliases alias-names alias-map)
 
-  ;; Filter top level expressions into several groups, each processed
+  ;; Prop top level expressions into several groups, each processed
   ;; into appropriate data structures
   ;;
   ;; Augment annotations go in their own table, because they're
@@ -550,21 +550,10 @@
         #:when (set-member? (hash-ref parse-info 'private-fields) name))
     (hash-set! private-field-types name (list type)))
 
-  ;; Hash<Syntax -> Listof<Listof<Syntax>, Listof<Type>>>
-  ;; Maps the outermost `let-values` expressions introduced by the expansion of
-  ;;  `define-values` within the class body to a list of identifier syntaxes
-  ;;  that represent variables and a list of corresponding types.
-  ;;  The variables temporarily hold the values of the initializer expression;
-  ;;  a field mutator is called on each one in the body of the `let-values`.
-  ;;  Typechecking of these calls is done in `check-field-set!s` and requires
-  ;;  the types of the initial values.
-  (define inits-temporaries-types (make-hasheq))
-
   (define synthesized-init-val-stxs
     (synthesize-private-field-types private-field-stxs
                                     local-private-field-table
-                                    private-field-types
-                                    inits-temporaries-types))
+                                    private-field-types))
 
   ;; Detect mutation of private fields for occurrence typing
   (for ([stx (in-sequences
@@ -609,8 +598,7 @@
   (with-lexical-env/extend-types lexical-names/top-level lexical-types/top-level
     (check-field-set!s (hash-ref parse-info 'initializer-body)
                        synthesized-init-val-stxs
-                       inits
-                       inits-temporaries-types))
+                       inits))
   (do-timestamp "checked field initializers")
   (define checked-method-types
     (with-lexical-env/extend-types lexical-names lexical-types
@@ -995,7 +983,7 @@
            (do-timestamp (format "finished method ~a" external-name))
            (cons (list external-name pre-method-type) checked)]
           ;; Only try to type-check if these names are in the
-          ;; filter when it's provided. This allows us to, say, only
+          ;; prop when it's provided. This allows us to, say, only
           ;; type-check pubments/augments.
           [(set-member? names-to-check external-name)
            (do-timestamp (format "started checking method ~a" external-name))
@@ -1035,11 +1023,11 @@
            (tc-expr/t xformed-stx)])))
 
 ;; check-field-set!s : Syntax Listof<Syntax> Dict<Symbol, Type>
-;;                     Dict<Syntax, List<Listof<Syntax>, Listof<Type>> -> Void
+;;                     -> Void
 ;; Check that fields are initialized to the correct type
 ;; FIXME: use syntax classes for matching and clearly separate the handling
 ;;        of field initialization and set! uses
-(define (check-field-set!s stx synthed-stxs inits inits-temporaries-types)
+(define (check-field-set!s stx synthed-stxs inits)
   (for ([form (syntax->list stx)])
     (syntax-parse form
       #:literal-sets (kernel-literals)
@@ -1106,12 +1094,21 @@
          (tc-expr/check processed (ret type)))]
       ;; multiple private fields
       [(let-values ([(names:id ...) val-expr]) begins ... (#%plain-app _))
-       (match-define (list t-names t-types)
-         (hash-ref inits-temporaries-types form (list empty empty)))
+       ;; This seems like it's duplicating work since the synthesis pass
+       ;; earlier had to do this, but it needs to be re-checked in this context
+       ;; so that it has the right environment. An earlier approach did
+       ;; check this only in the synthesis stage, but caused some regressions.
+       (define temp-names (syntax->list #'(names ...)))
+       (define init-types
+         (match (tc-expr #'val-expr)
+           [(tc-results: xs ) xs]))
+       (unless (= (length temp-names) (length init-types))
+         (tc-error/expr "wrong number of values: expected ~a but got ~a"
+                        (length temp-names) (length init-types)))
        ;; Extend lexical type env with temporaries introduced in the
        ;; expansion of the field initialization or setter
-       (with-lexical-env/extend-types t-names t-types
-         (check-field-set!s #'(begins ...) synthed-stxs inits inits-temporaries-types))]
+       (with-lexical-env/extend-types temp-names init-types
+         (check-field-set!s #'(begins ...) synthed-stxs inits))]
       [_ (void)])))
 
 ;; setter->type : Id -> Type
@@ -1144,11 +1141,11 @@
           [else
            (tc-expr/check init-val (ret init-type))])))
 
-;; synthesize-private-field-types : Listof<Syntax> Dict Hash Hash -> Listof<Syntax>
+;; synthesize-private-field-types : Listof<Syntax> Dict Hash -> Listof<Syntax>
 ;; Given top-level expressions in the class, synthesize types from
 ;; the initialization expressions for private fields. Returns the initial
 ;; value expressions that were type synthesized.
-(define (synthesize-private-field-types stxs locals types inits-temporaries-types)
+(define (synthesize-private-field-types stxs locals types)
   (for/fold ([synthed-stxs null])
             ([stx (in-list stxs)])
     (syntax-parse stx
@@ -1186,23 +1183,18 @@
        (define field-names (map syntax-e (syntax-e (tr:class:def-property stx))))
        (define temporary-stxs (syntax-e #'(initial-value-name ...)))
        (define init-types
-         (match (tc-expr/check #'initial-values #f)
-           [(tc-results: xs ) xs]))
-       (unless (= (length field-names) (length init-types))
-         (tc-error/expr "wrong number of values: expected ~a but got ~a"
-                        (length field-names) (length init-types)))
-       (define temporaries-types
-         (for/list
-              ([name (in-list field-names)]
-               [temp-stx (in-list temporary-stxs)]
-               [type (in-list init-types)])
-           (define type-table-val (generalize type))
-           (unless (hash-has-key? types name)
-             (hash-set! types name (list type-table-val)))
-           (cons temp-stx type-table-val)))
-       (hash-set! inits-temporaries-types stx
-                  (list (map car temporaries-types)
-                        (map cdr temporaries-types)))
+         ;; this gets re-checked later, so don't throw any errors yet
+         (match (tc-expr/check? #'initial-values #f)
+           [(tc-results: xs ) xs]
+           ;; We have to return something here so use the most conservative type
+           [#f (make-list (length field-names) Univ)]))
+       (for ([name (in-list field-names)]
+             [temp-stx (in-list temporary-stxs)]
+             [type (in-list init-types)])
+         (define type-table-val (generalize type))
+         (unless (hash-has-key? types name)
+           (hash-set! types name (list type-table-val)))
+         (cons temp-stx type-table-val))
        (cons #'initial-values synthed-stxs)])))
 
 ;; Syntax -> Dict<Symbol, Id> Dict<Symbol, Id>
@@ -1605,7 +1597,7 @@
      (make-PolyRow ns constraints (method->function type))]
     [_ (tc-error/expr #:return -Bottom "expected a function type for method")]))
 
-;; process-method-syntax : Syntax (Option Type) -> Syntax
+;; process-method-syntax : Syntax Type (Option Type) -> Syntax
 ;; Register types for identifiers in a method that don't come with types and
 ;; propagate syntax properties as needed
 (define (process-method-syntax stx self-type method-type)

typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt

@@ -11,7 +11,7 @@
          (utils tc-utils)
          (for-syntax racket/base syntax/parse)
          (for-template racket/base)
-         (rep type-rep filter-rep object-rep))
+         (rep type-rep prop-rep object-rep))
 
 (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
 (export check-subforms^)
@@ -42,14 +42,14 @@
 
   ;; syntax tc-result1 type -> tc-results
   ;; The result of applying the function to a single argument of the type of its first argument
-  (define (get-range-result stx t filter-type)
+  (define (get-range-result stx t prop-type)
     (let loop ((t t))
       (match t
         [(Function: (list _ ... (arr: (list arg1) _ _ #f (list (Keyword: _ _ #f) ...)) _ ...))
-         #:when (subtype filter-type arg1)
+         #:when (subtype prop-type arg1)
          (tc/funapp #'here #'(here) t (list (ret arg1)) #f)]
         [(Function: (list _ ... (arr: '() _ (? values rest) #f (list (Keyword: _ _ #f) ...)) _ ...))
-         #:when (subtype filter-type rest)
+         #:when (subtype prop-type rest)
          (tc/funapp #'here #'(here) t (list (ret rest)) #f)]
         [(? needs-resolving? t)
          (loop (resolve t))]
@@ -58,17 +58,17 @@
         ;; This clause should raise an error via the check-below test
         [_
          (cond [;; a redundant test, but it ensures an error message below
-                (not (subtype t (-> filter-type Univ)))
+                (not (subtype t (-> prop-type Univ)))
                 (parameterize ([current-orig-stx stx])
-                  (check-below t (-> filter-type Univ)))]
-               [else (int-err "get-range-result: should not happen. type ~a filter ~a"
-                              t filter-type)])
+                  (check-below t (-> prop-type Univ)))]
+               [else (int-err "get-range-result: should not happen. type ~a prop ~a"
+                              t prop-type)])
          (ret (Un))])))
 
   ;; Syntax Type -> (Option Type)
-  ;; Extract the type for the filter in a predicate type, or #f if
+  ;; Extract the type for the prop in a predicate type, or #f if
   ;; the type is an invalid predicate type.
-  (define (get-filter-type stx pred-type)
+  (define (get-prop-type stx pred-type)
     (cond [;; make sure the predicate has an appropriate type
            (subtype pred-type (-> Univ Univ))
            (define fun-type
@@ -78,10 +78,10 @@
            (match fun-type
              ;; FIXME: Almost all predicates fall into this case, but it may
              ;;        be worth being more precise here for some rare code.
-             [(PredicateFilter: fs)
-              (match fs
-                [(FilterSet: (TypeFilter: ft (Path: '() '(0 0))) _) ft]
-                [(Bot:) (Un)]
+             [(PredicateProp: ps)
+              (match ps
+                [(PropSet: (TypeProp: (Path: '() '(0 0)) ft) _) ft]
+                [(FalseProp:) (Un)]
                 [_ Univ])]
              [_ Univ])]
           [else
@@ -98,12 +98,12 @@
         (hash-ref predicate-map key))
       (match-define (list handler-stx handler-type)
         (hash-ref handler-map key))
-      (define filter-type
-        (get-filter-type predicate-stx predicate-type))
+      (define prop-type
+        (get-prop-type predicate-stx predicate-type))
       ;; if the predicate doesn't check, then don't bother
       ;; with the RHS and return no result
-      (if filter-type
-          (get-range-result handler-stx handler-type filter-type)
+      (if prop-type
+          (get-range-result handler-stx handler-type prop-type)
           (ret (Un)))))
 
   (find-syntax form

typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt

@@ -0,0 +1,753 @@
+#lang racket/unit
+
+;; This module provides a unit for type-checking units
+;; The general strategy for typechecking all of the racket/unit forms
+;; is to match the entire expanded syntax and parse out the relevant
+;; pieces of information.
+;;
+;; Each typing rule knows the expected expansion of the form being checked
+;; and specifically parses that syntax. This implementation is extremely
+;; brittle and will require changes should the expansion of any of the unit
+;; forms change.
+;;
+;; For unit forms the general idea is to parse expanded syntax to find information
+;; related to:
+;; - imports
+;; - exports
+;; - init-depend
+;; - subexpressions that require typechecking
+;; And use these pieces to typecheck the entire form
+;;
+;; For the `unit` form imports, exports, and init-depends are parsed to generate
+;; the type of the expression and to typecheck the body of the unit since imported signatures
+;; introduce bindings of variables to types, and exported variables must be defined
+;; with subtypes of their expected types.
+;;
+;; The `invoke-unit` expansion is more complex and depends on whether or not
+;; imports were specified. In the case of no imports, the strategy is simply to
+;; find the expression being invoked and ensure it has the type of a unit with
+;; no imports. When there are imports to an `invoke-unit` form, the syntax contains
+;; local definitions of units defined using `unit-from-context`. These forms
+;; are parsed to determine which imports were declared to check subtyping on the
+;; invoked expression and to ensure that imports pulled from the current context
+;; have the correct types.
+;;
+;; The `compound-unit` expansion contains information about the imports and exports
+;; of each unit expression being linked. Additionally the typed `compound-unit` macro
+;; attaches a syntax property that specifies the exact linking structure of the compound
+;; unit. These pieces of information enable the calculation of init-depends for the entire
+;; compound unit and to properly check subtyping on each linked expression.
+;;
+;; `unit-from-context` is handled similarly to `invoke-unit`, the expansion is exactly
+;; that of a unit created using the `unit` form, but lacks the annotations that are placed
+;; there by the typed `unit` macro. In this case the body of the unit is searched for
+;; syntax corresponding to definitions which are checked against the declared exports
+;; to ensure the form is well typed.
+;;
+;; The handling of the various `infer` forms (invoke-unit/infer compound-unit/infer)
+;; is generally identical to the corresponding form lacking inference, however, in these
+;; cases typechecking can be more lax. In particular, the unit implementation knows that
+;; only valid unit expressions are used in these forms and so there is no need to typecheck
+;; each unit subexpression unless it is needed to determine the result type. The
+;; `compund-unit/infer` form, however, requires the cooperation of the unit implementation
+;; to attach a syntax property that specified the init-depends of the compound unit, otherwise
+;; this information is extremely difficult to obtain from the syntax alone.
+
+(require "../utils/utils.rkt"
+         syntax/id-set
+         racket/set
+         racket/dict
+         racket/format
+         racket/list
+         racket/match
+         racket/syntax
+         syntax/id-table
+         syntax/parse
+         syntax/stx
+         syntax/strip-context
+         racket/unit-exptime
+         "signatures.rkt"
+         (private parse-type syntax-properties type-annotation)
+         (only-in (base-env base-special-env) make-template-identifier)
+         (env lexical-env tvar-env global-env 
+              signature-env)
+         (types utils abbrev union subtype resolve generalize signatures)
+         (typecheck check-below internal-forms)
+         (utils tc-utils)
+         (rep type-rep)
+         (for-syntax racket/base racket/unit-exptime syntax/parse)
+         (for-template racket/base
+                       racket/unsafe/undefined
+                       (submod "internal-forms.rkt" forms)))
+
+(import tc-let^ tc-expr^)
+(export check-unit^)
+
+;; Syntax class definitions
+;; variable annotations are modified by the expansion of the typed unit
+;; macro in order to allow annotations on exported variables, this
+;; syntax class allows conversion back to the usual internal syntax
+;; for type annotations which may be used by tc-letrec/values
+(define-syntax-class unit-body-annotation
+  #:literal-sets (kernel-literals)
+  #:literals (void values :-internal cons)
+  (pattern
+   (#%expression
+    (begin
+      (#%plain-app void (#%plain-lambda () var-int))
+      (begin
+        (quote-syntax
+         (:-internal var:id t) #:local)
+        (#%plain-app values))))
+   #:attr name #'var
+   #:attr fixed-form (quasisyntax/loc this-syntax
+                       (begin
+                           (quote-syntax (:-internal var-int t) #:local)
+                           (#%plain-app values)))))
+
+;; Syntax class matching the syntax of the rhs of definitions within unit bodies
+;; The typed unit macro attaches the lambda to allow unit typechecking to associate
+;; variable names with their definitions which are otherwise challenging to recover
+(define-syntax-class unit-body-definition
+  #:literal-sets (kernel-literals)
+  #:literals (void)
+  (pattern
+   (#%expression
+    (begin
+      (#%plain-app void (#%plain-lambda () var:id ... (#%plain-app void)))
+      e))
+   #:with vars #'(var ...)
+   #:with body #'e))
+
+;; Process the syntax of annotations and definitions from a unit
+;; produces two values representing the names and the exprs corresponding
+;; to each definition or annotation
+;; Note:
+;; - definitions may produce multiple names via define-values
+;; - annotations produce no names
+(define (process-ann/def-for-letrec ann/defs)
+  (for/fold ([names #`()]
+             [exprs #`()])
+            ([a/d (in-list ann/defs)])
+    (syntax-parse a/d
+      [a:unit-body-annotation
+       (define name (attribute a.name))
+       ;; TODO:
+       ;; Duplicate annotations from imports
+       ;; are not currently detected due to a bug
+       ;; in tc/letrec-values
+       ;; See Problem Report: 15145
+       (define fixed (attribute a.fixed-form))
+       (values #`(#,@names ()) #`(#,@exprs #,fixed))]
+      [d:unit-body-definition
+       (values #`(#,@names d.vars) #`(#,@exprs d.body))])))
+
+;; A Sig-Info is a (sig-info identifier? (listof identifier?) (listof identifier?))
+;; name is the identifier corresponding to the signature this sig-info represents
+;; externals is the list of external names for variables in the signature
+;; internals is the list of internal names for variables in the signature
+;; Note:
+;; - external names are those attached to signatures stored in static information
+;;   and in the Siganture representation
+;; - internal names are the internal renamings of those variables in fully expanded
+;;   unit syntax, this renaming is performed by the untyped unit macro
+;; - All references within a unit body use the internal names
+(struct sig-info (name externals internals) #:transparent)
+
+;; Process the various pieces of the fully expanded unit syntax to produce
+;; sig-info structures for the unit's imports and exports, and a list of the
+;; identifiers corresponding to init-depends of the unit
+(define (process-unit-syntax import-sigs import-internal-ids import-tags
+                             export-sigs export-temp-ids export-temp-internal-map
+                             init-depend-tags)
+  ;; build a mapping of import-tags to import signatures
+  ;; since init-depends are referenced by the tags only in the expanded syntax
+  ;; this map is used to determine the actual signatures corresponding to the
+  ;; given signature tags of the init-depends
+  (define tag-map (make-immutable-free-id-table (map cons import-tags import-sigs)))
+  (define lookup-temp (λ (temp) (free-id-table-ref export-temp-internal-map temp #f)))
+  
+  (values (for/list ([sig-id  (in-list import-sigs)]
+                     [sig-internal-ids (in-list import-internal-ids)])
+            (sig-info sig-id
+                      (map car (Signature-mapping (lookup-signature/check sig-id)))
+                      sig-internal-ids))
+          ;; export-temp-ids is a flat list which must be processed
+          ;; sequentially to map them to the correct internal/external identifiers
+          (let-values ([(_ si)
+                        (for/fold ([temp-ids export-temp-ids]
+                                   [sig-infos '()])
+                                  ([sig (in-list export-sigs)])
+                          (define external-ids
+                            (map car (Signature-mapping (lookup-signature/check sig))))
+                          (define len (length external-ids))
+                          (values (drop temp-ids len)
+                                  (cons (sig-info sig
+                                                  external-ids
+                                                  (map lookup-temp (take temp-ids len)))
+                                        sig-infos)))])
+            (reverse si))
+          (map (λ (x) (free-id-table-ref tag-map x #f)) init-depend-tags)))
+
+;; The following three syntax classes are used to parse specific pieces of
+;; information from parts of the expansion of units
+
+;; Needed to parse out signature names, and signature-tags from the unit syntax
+;; the tags are used to lookup init-depend signatures
+(define-syntax-class sig-vector
+  #:literal-sets (kernel-literals)
+  #:literals (vector-immutable cons)
+  (pattern (#%plain-app 
+            vector-immutable
+            (#%plain-app cons 
+                         (quote sig:id)
+                         (#%plain-app vector-immutable sig-tag tag-rest ...))
+            ...)
+           #:with sigs #'(sig ...)
+           #:with sig-tags #'(sig-tag ...)))
+
+(define-syntax-class init-depend-list
+  #:literal-sets (kernel-literals)
+  #:literals (list cons)
+  (pattern (#%plain-app list (#%plain-app cons _ sig-tag) ...)
+           #:with init-depend-tags #'(sig-tag ...)))
+
+(define-syntax-class export-table
+  #:literal-sets (kernel-literals)
+  #:literals (make-immutable-hash list cons vector-immutable check-not-unsafe-undefined unbox)
+  (pattern (#%plain-app
+            make-immutable-hash
+            (#%plain-app
+             list
+             (#%plain-app
+              cons
+              signature-tag:id
+              (#%plain-app
+               vector-immutable
+               (#%plain-lambda () 
+                 (#%plain-app check-not-unsafe-undefined (#%plain-app unbox export-temp-id) external-id))
+               ...))
+             ...))
+           #:attr export-temp-ids (map syntax->list (syntax->list #'((export-temp-id ...) ...)))))
+
+;; This syntax class matches the whole expansion of unit forms
+(define-syntax-class unit-expansion
+  #:literal-sets (kernel-literals)
+  #:attributes (body-stx 
+                import-internal-ids 
+                import-sigs 
+                import-sig-tags 
+                export-sigs 
+                export-temp-ids
+                init-depend-tags)
+  (pattern (#%plain-app
+            make-unit:id
+            name:expr 
+            import-vector:sig-vector
+            export-vector:sig-vector
+            list-dep:init-depend-list
+            (let-values (_ ...)
+              (let-values (_ ...)
+                (#%expression
+                 (#%plain-lambda ()
+                   (let-values (((export-temp-id:id) _) ...)
+                     (#%plain-app
+                      values
+                      (#%plain-lambda (import-table:id)
+                                      (let-values (((import:id ...) _) ...)
+                                        unit-body:expr))
+                      et:export-table
+                      _ ...)))))))
+           #:attr import-sigs (syntax->list #'import-vector.sigs)
+           #:attr import-sig-tags (syntax->list #'import-vector.sig-tags)
+           #:attr export-sigs (syntax->list #'export-vector.sigs)
+           #:attr export-temp-ids (syntax->list #'(export-temp-id ...))
+           #:attr init-depend-tags (syntax->list #'list-dep.init-depend-tags)
+           #:attr import-internal-ids (map syntax->list (syntax->list #'((import ...) ...)))
+           #:with body-stx #'unit-body))
+
+;; Extract the identifiers referenced in unit-from-context and invoke-unit forms
+;; in order to typecheck them in the current environment
+ (define (extract-definitions stx)
+   (trawl-for-property
+    stx
+    (lambda (stx) (syntax-parse stx [((int:id) ref:id) #t] [_ #f]))
+    (lambda (stx) (syntax-parse stx [((int:id) ref:id) #'ref]))))
+
+;; Syntax inside the expansion of units that allows recovering a mapping
+;; from temp-ids of exports to their internal identifiers
+(define-syntax-class export-temp-internal-map-elem
+  #:literal-sets (kernel-literals)
+  #:literals (set-box!)
+  (pattern (#%plain-app set-box! temp-id:id internal-id:id)))
+
+(define export-map-elem?
+  (syntax-parser [e:export-temp-internal-map-elem #t]
+                 [_ #f]))
+(define extract-export-map-elem
+  (syntax-parser [e:export-temp-internal-map-elem (cons #'e.temp-id #'e.internal-id)]))
+
+;; get a reference to the actual `invoke-unit/core` function to properly parse
+;; the fully expanded syntax of `invoke-unit` forms
+(define invoke-unit/core (make-template-identifier 'invoke-unit/core 'racket/unit))
+
+;; Syntax class for all the various expansions of invoke-unit forms
+;; This also includes the syntax for the invoke-unit/infer forms
+(define-syntax-class invoke-unit-expansion
+  #:literal-sets (kernel-literals)
+  (pattern (#%plain-app iu/c unit-expr)
+           #:when (free-identifier=? #'iu/c invoke-unit/core)
+           #:attr units '()
+           #:attr expr #'unit-expr
+           #:attr imports '())
+  (pattern
+   (let-values ()
+     body:invoke-unit-linkings)
+   #:attr units (attribute body.units)
+   #:attr expr (attribute body.expr)
+   #:attr imports (attribute body.imports)))
+
+(define-syntax-class invoke-unit-linkings
+  #:literal-sets (kernel-literals)
+  (pattern
+   (let-values ([(u-temp:id)
+                 (let-values ([(deps) _]
+                              [(sig-provider) _] ...
+                              [(temp) ie:invoked-expr])
+                   _ ...)])
+     (#%plain-app iu/c (#%plain-app values _)))
+   #:when (free-identifier=? #'iu/c invoke-unit/core)
+   #:attr units '()
+   #:attr expr (if (tr:unit:invoke:expr-property #'ie) #'ie #'ie.invoke-expr)
+   #:attr imports '())
+  (pattern
+   (let-values ([(temp-id) u:unit-expansion])
+     rest:invoke-unit-linkings)
+   #:attr units (cons #'u (attribute rest.units))
+   #:attr expr (attribute rest.expr)
+   #:attr imports (append (attribute u.export-sigs) (attribute rest.imports))))
+
+;; This should be used ONLY when an invoke/infer is used with the link clause ...
+(define-syntax-class invoked-expr
+  #:literal-sets (kernel-literals)
+  #:literals (values)
+  (pattern
+   (let-values ([(deps2:id) _]
+                [(local-unit-id:id) unit:id] ...
+                [(invoke-temp) invoke-unit])
+     _ ...)
+   #:attr invoke-expr #'invoke-unit)
+  (pattern invoke-expr:expr))
+
+;; Compound Unit syntax classes
+(define-syntax-class compound-unit-expansion
+  #:literal-sets (kernel-literals)
+  #:literals (vector-immutable cons)
+  (pattern 
+   (let-values ([(deps:id) _]
+                [(local-unit-name) unit-expr] ...)
+     (~seq (#%plain-app check-unit _ ...)
+           (#%plain-app check-sigs _
+                        (#%plain-app 
+                         vector-immutable
+                         (#%plain-app cons (quote import-sig:id) _) ...)
+                        (#%plain-app
+                         vector-immutable
+                         (#%plain-app cons (quote export-sig:id) _) ...)
+                        _)
+           (let-values ([(fht) _]
+                        [(rht) _])
+             _ ...)) ...
+     (#%plain-app
+            make-unit:id
+            name:expr 
+            import-vector:sig-vector
+            export-vector:sig-vector
+            deps-ref
+            internals))
+   #:attr unit-exprs (syntax->list #'(unit-expr ...))
+   #:attr unit-imports (map syntax->list (syntax->list #'((import-sig ...) ...)))
+   #:attr unit-exports (map syntax->list (syntax->list #'((export-sig ...) ...)))
+   #:attr compound-imports (syntax->list #'import-vector.sigs)
+   #:attr compound-exports (syntax->list #'export-vector.sigs)))
+
+;; A cu-expr-info represents an element of the link clause in
+;; a compound-unit form
+;; - expr : the unit expression being linked
+;; - import-sigs : the Signatures specified as imports for this link-element
+;; - import-links : the symbols that correspond to the link-bindings
+;;                  imported by this unit
+;; - export-sigs : the Signatures specified as exports for this link-element
+;; - export-links : the symbols corresponding to the link-bindings exported
+;;                  by this unit
+(struct cu-expr-info (expr import-sigs import-links export-sigs export-links)
+  #:transparent)
+
+;; parse-compound-unit : Syntax -> (Values (Listof (Cons Symbol Id))
+;;                                         (Listof Symbol)
+;;                                         (Listof Signature)
+;;                                         (Listof Signature)
+;;                                         (Listof cu-expr-info))
+;; Returns a mapping of link-ids to sig-ids, a list of imported sig ids
+;; a list of exported link-ids
+(define (parse-compound-unit stx)
+  (define (list->sigs l) (map lookup-signature/check l))
+  (syntax-parse stx
+    [cu:compound-unit-expansion
+     (define link-binding-info (tr:unit:compound-property stx))
+     (match-define (list cu-import-syms unit-export-syms unit-import-syms)
+       link-binding-info)
+     (define compound-imports (attribute cu.compound-imports))
+     (define compound-exports (attribute cu.compound-exports))
+     (define unit-exprs (attribute cu.unit-exprs))
+     (define unit-imports (attribute cu.unit-imports))
+     (define unit-exports (attribute cu.unit-exports))
+     ;; Map signature ids to link binding symbols
+     (define mapping
+       (let ()
+         (define link-syms (append cu-import-syms (flatten unit-export-syms)))
+         (define sig-ids (append compound-imports (flatten unit-exports)))
+         (map cons link-syms (map lookup-signature/check sig-ids))))
+     (define cu-exprs
+       (for/list ([unit-expr (in-list unit-exprs)]
+                  [import-sigs (in-list unit-imports)]
+                  [import-links (in-list unit-import-syms)]
+                  [export-sigs (in-list unit-exports)]
+                  [export-links (in-list unit-export-syms)])
+         (cu-expr-info unit-expr
+                       (list->sigs import-sigs) import-links
+                       (list->sigs export-sigs) export-links)))
+     (values 
+      mapping
+      cu-import-syms
+      (list->sigs compound-imports)
+      (list->sigs compound-exports)
+      cu-exprs)]))
+
+;; Sig-Info -> (listof (pairof identifier? Type))
+;; GIVEN: signature information
+;; RETURNS: a mapping from internal names to types
+(define (make-local-type-mapping si)
+  (define sig (lookup-signature/check (sig-info-name si)))
+  (define internal-names (sig-info-internals si))
+  (define sig-types 
+    (map cdr (Signature-mapping sig)))
+  (map cons internal-names sig-types))
+
+;; Syntax Option<TCResults> -> TCResults
+;; Type-check a unit form
+(define (check-unit form [expected #f])
+  (define expected-type
+    (match expected
+      [(tc-result1: type) (resolve type)]
+      [_ #f]))
+  (match expected-type
+    [(? Unit? unit-type)
+     (ret (parse-and-check-unit form unit-type))]
+    [_ (ret (parse-and-check-unit form #f))]))
+
+;; Syntax Option<TCResultss> -> TCResults
+
+(define (check-invoke-unit form [expected #f])
+  (define expected-type 
+    (match expected
+      [(tc-result1: type) (resolve type)]
+      [_ #f]))
+  (ret (parse-and-check-invoke form expected-type)))
+
+(define (check-compound-unit form [expected #f])
+  (define infer? (eq? (tr:unit:compound-property form) 'infer))
+  (define expected-type
+    (match expected
+      [(tc-result1: type) (resolve type)]
+      [_ #f]))
+  (if infer?
+      (ret (parse-and-check-compound/infer form expected-type))
+      (ret (parse-and-check-compound form expected-type))))
+
+(define (check-unit-from-context form [expected #f])
+  (define expected-type
+    (match expected
+      [(tc-result1: type) (resolve type)]
+      [_ #f]))
+  (ret (parse-and-check-unit-from-context form expected-type)))
+
+(define (parse-and-check-unit-from-context form expected-type)
+  (syntax-parse form
+    [u:unit-expansion
+     (define export-sigs (map lookup-signature/check (attribute u.export-sigs)))
+     (define body-stx (attribute u.body-stx))
+     (for ([sig (in-list export-sigs)])
+       (define ids (extract-definitions body-stx))
+       (define types (map cdr (Signature-mapping sig)))
+       (for ([type (in-list types)]
+             [id (in-list ids)])
+         (define lexical-type (lookup-type/lexical id))
+         (unless (subtype lexical-type type)
+           (tc-error/fields "type mismatch in unit-from-context export"
+                            "expected" type
+                            "given" lexical-type
+                            "exported variable" (syntax-e id)
+                            "exported-signature" (syntax-e (Signature-name sig))
+                            #:stx form
+                            #:delayed #t))))
+     (-unit null export-sigs null (-values (list -Void)))]))
+
+(define (parse-and-check-compound form expected-type)
+  (define-values (link-mapping
+                  import-syms
+                  import-sigs
+                  export-sigs
+                  cu-exprs)
+    (parse-compound-unit form))
+  
+  (define (lookup-link-id id) (dict-ref link-mapping id #f))
+  (define-values (check _ init-depends)
+    (for/fold ([check -Void]
+               [seen-init-depends import-syms]
+               [calculated-init-depends '()])
+              ([form (in-list cu-exprs)])
+      (match-define (cu-expr-info unit-expr-stx
+                                  import-sigs
+                                  import-links
+                                  export-sigs
+                                  export-links)
+        form)
+      (define unit-expected-type 
+        (-unit import-sigs 
+               export-sigs 
+               (map lookup-link-id (set-intersect seen-init-depends import-links))
+               ManyUniv))
+      (define unit-expr-type (tc-expr/t unit-expr-stx))
+      (check-below unit-expr-type unit-expected-type)
+      (define-values (body-type new-init-depends)
+        (match unit-expr-type
+          [(Unit: _ _ ini-deps ty)
+           ;; init-depends here are strictly subsets of the units imports
+           ;; but these may not exactly match with the provided links
+           ;; so all of the extended signatures must be traversed to find the right
+           ;; signatures for init-depends
+           (define extended-imports
+             (map cons import-links
+                  (map (λ (l) (map Signature-name (flatten-sigs l))) import-sigs)))
+           (define init-depend-links
+             (for*/list ([sig-name (in-list (map Signature-name ini-deps))]
+                         [(import-link import-family) (in-dict extended-imports)]
+                         #:when (member sig-name import-family free-identifier=?))
+               import-link))
+           ;; new init-depends are the init-depends of this unit that
+           ;; overlap with the imports to the compound-unit
+           (values ty (set-intersect import-syms init-depend-links))]
+          ;; unit-expr was not actually a unit, but we want to delay the errors
+          [_ (values #f '())]))
+      (values body-type
+              ;; Add the exports to the list of seen-init-depends
+              (set-union seen-init-depends export-links)
+              ;; Add the new-init-depends to those already calculated
+              (set-union calculated-init-depends new-init-depends))))
+  (if check
+      (-unit import-sigs
+             export-sigs
+             (map lookup-link-id init-depends)
+             check)
+      ;; Error case when one of the links was not a unit
+      -Bottom))
+
+(define (parse-and-check-compound/infer form expected-type)
+  (define init-depend-refs (syntax-property form 'unit:inferred-init-depends))
+  (syntax-parse form
+    [cu:compound-unit-expansion
+     (define unit-exprs (attribute cu.unit-exprs))
+     (define compound-imports (map lookup-signature/check (attribute cu.compound-imports)))
+     (define compound-exports (map lookup-signature/check (attribute cu.compound-exports)))
+     (define import-vector (apply vector compound-imports))
+     (define import-length (vector-length import-vector))
+     (unless (and (list? init-depend-refs)
+                  (andmap (λ (i) (and (exact-nonnegative-integer? i) (< i import-length)))
+                          init-depend-refs))
+       (int-err "malformed syntax property attached to compound-unit/infer form"))
+     (define compound-init-depends
+       (map (lambda (i) (vector-ref import-vector i)) init-depend-refs))
+     (define resulting-unit-expr (last unit-exprs))
+     (define final-unit-invoke-type (tc-expr/t resulting-unit-expr))
+     ;; This type should always be a unit
+     (match-define (Unit: _ _ _ compound-invoke-type) final-unit-invoke-type)
+     (-unit compound-imports compound-exports compound-init-depends compound-invoke-type)]))
+
+(define (parse-and-check-invoke form expected-type)
+  (syntax-parse form 
+    [iu:invoke-unit-expansion
+     (define infer? (eq? 'infer (tr:unit:invoke-property form)))
+     (define invoked-unit (attribute iu.expr))
+     (define import-sigs (map lookup-signature/check (attribute iu.imports)))
+     (define linking-units (attribute iu.units))
+     (define unit-expr-type (tc-expr/t invoked-unit))
+     ;; TODO: Better error message/handling when the folling check-below "fails"
+     (unless infer?
+       (check-below unit-expr-type (-unit import-sigs null import-sigs ManyUniv)))
+     (for ([unit (in-list linking-units)]
+           [sig (in-list import-sigs)])
+       (define ids (extract-definitions unit))
+       (define types (map cdr (Signature-mapping sig)))
+       (for ([type (in-list types)]
+             [id (in-list ids)])
+         (define lexical-type (lookup-type/lexical id))
+         (unless (subtype lexical-type type)
+           (tc-error/fields "type mismatch in invoke-unit import"
+                            "expected" type
+                            "given" lexical-type
+                            "imported variable" (syntax-e id)
+                            "imported signature" (syntax-e (Signature-name sig))
+                            #:stx form
+                            #:delayed? #t))))
+     (cond
+       [(Unit? unit-expr-type)
+        (define result-type (Unit-result unit-expr-type))
+        (match result-type
+          [(Values: (list (Result: t _ _) ...)) t]
+          [(AnyValues: f) ManyUniv]
+          [(ValuesDots: (list (Result: t _ _) ...) _ _) t])]
+       [else -Bottom])]))
+
+;; Parse and check unit syntax
+(define (parse-and-check-unit form expected)
+  (syntax-parse form
+    [u:unit-expansion
+     ;; extract the unit body syntax
+     (define body-stx #'u.body-stx)
+     (define import-sigs (attribute u.import-sigs))
+     (define import-internal-ids (attribute u.import-internal-ids))
+     (define import-tags (attribute u.import-sig-tags))
+     (define export-sigs (attribute u.export-sigs))
+     (define export-temp-ids (attribute u.export-temp-ids))
+     (define init-depend-tags (attribute u.init-depend-tags))
+     (define export-temp-internal-map
+       (make-immutable-free-id-table
+        (trawl-for-property body-stx export-map-elem? extract-export-map-elem)))
+     (define-values (imports-info exports-info init-depends)
+       (process-unit-syntax import-sigs import-internal-ids import-tags
+                            export-sigs export-temp-ids export-temp-internal-map
+                            init-depend-tags))
+
+     ;; Get Signatures to build Unit type
+     (define import-signatures (map lookup-signature/check (map sig-info-name imports-info)))
+     (define export-signatures (map lookup-signature/check (map sig-info-name exports-info)))
+     (define init-depend-signatures (map lookup-signature/check init-depends))
+
+     (unless (distinct-signatures? import-signatures)
+       (tc-error/expr "unit expressions must import distinct signatures"))
+     ;; this check for exports may be unnecessary
+     ;; the unit macro seems to check it as well
+     (unless (distinct-signatures? export-signatures)
+       (tc-error/expr "unit expresssions must export distinct signatures"))
+     
+     (define local-sig-type-map
+       (apply append (map make-local-type-mapping imports-info)))
+     (define export-signature-type-map
+       (map (lambda (si)
+              (cons (sig-info-name si) (make-local-type-mapping si)))
+            exports-info))
+
+     ;; Thunk to pass to tc/letrec-values to check export subtyping
+     ;; These subtype checks can only be checked within the dynamic extent
+     ;; of the call to tc/letrec-values because they need to lookup
+     ;; variables in the type environment as modified by typechecking
+     (define (check-exports-thunk)
+       (for* ([sig-mapping (in-list export-signature-type-map)]
+              [sig (in-value (car sig-mapping))]
+              [mapping (in-value (cdr sig-mapping))]
+              [(id expected-type) (in-dict mapping)])
+         (define id-lexical-type (lookup-type/lexical id))
+         (unless (subtype id-lexical-type expected-type)
+           (tc-error/fields "type mismatch in unit export"
+                            "expected" expected-type
+                            "given" id-lexical-type
+                            "exported variable" (syntax-e id)
+                            "exported signature" (syntax-e sig)
+                            #:delayed? #t))))
+     
+     (define import-name-map
+       (append-map (lambda (si) (map cons (sig-info-externals si) (sig-info-internals si)))
+                   imports-info))
+     (define export-name-map
+       (append-map (lambda (si) (map cons (sig-info-externals si) (sig-info-internals si))) 
+                   exports-info))
+     
+     (define body-forms 
+       (trawl-for-property body-stx tr:unit:body-exp-def-type-property))
+     
+     (define last-form 
+       (or (and (not (empty? body-forms)) (last body-forms))))
+     
+     ;; get expression forms, if the body was empty or ended with
+     ;; a definition insert a `(void)` expression to be typechecked
+     ;; This is necessary because we defer to tc/letrec-values for typechecking
+     ;; unit bodies, but a unit body may contain only definitions whereas letrec bodies
+     ;; cannot, in this case we insert dummy syntax representing a call to the void 
+     ;; function in order to correctly type the body of the unit.
+     (define expression-forms
+       (let ([exprs 
+              (filter
+               (lambda (stx) (eq? (tr:unit:body-exp-def-type-property stx) 'expr))
+               body-forms)])
+         (cond
+           [(or (not last-form) (eq? (tr:unit:body-exp-def-type-property last-form) 'def/type))
+            (append exprs (list #'(#%plain-app void)))]
+           [else exprs])))
+
+     
+     
+     ;; Filter out the annotation and definition syntax from the unit body
+     ;; For the purposes of typechecking, annotations and definitions
+     ;; are essentially lifted to the top of the body and all expressions
+     ;; are placed at the end (possibly with the addition of a (void) expression
+     ;; as described above), since the types of definitions and annotations
+     ;; must scope over the entire body of the unit, this is valid for purposes
+     ;; of typechecking
+     (define annotation/definition-forms
+       (filter
+        (lambda (stx) (eq? (tr:unit:body-exp-def-type-property stx) 'def/type))
+        body-forms))
+     
+     (define-values (ann/def-names ann/def-exprs)
+       (process-ann/def-for-letrec annotation/definition-forms))
+
+     (define signature-annotations
+       (for/list ([(k v) (in-dict local-sig-type-map)])
+         (cons k (-> v))))
+     (define unit-type
+       (with-lexical-env/extend-types
+         (map car signature-annotations)
+         (map cdr signature-annotations)
+         ;; Typechecking a unit body is structurally similar to that of
+         ;; checking a let-body, so we resuse the machinary for checking
+         ;; let expressions
+         (define res (tc/letrec-values ann/def-names
+                                       ann/def-exprs
+                                       (quasisyntax/loc form (#,@expression-forms))
+                                       #f
+                                       check-exports-thunk))
+         (define invoke-type
+           (match res
+             [(tc-results: tps) (-values tps)]))
+         (-unit import-signatures
+                export-signatures
+                init-depend-signatures
+                invoke-type)))
+     unit-type]))
+
+;; Based on the function of the same name in check-class-unit.rkt
+;; trawl-for-property : Syntax (Syntax -> Any) [(Syntax -> A)] -> (Listof A)
+;; Search through the given syntax for pieces of syntax that satisfy
+;; the accessor predicate, then apply the extractor function to  all such syntaxes 
+(define (trawl-for-property form accessor [extractor values])
+  (define (recur-on-all stx-list)
+    (apply append (map (λ (stx) (trawl-for-property stx accessor extractor)) stx-list)))
+  (syntax-parse form
+    #:literal-sets (kernel-literals)
+    [stx
+     #:when (accessor #'stx)
+     (list (extractor form))]
+    [_
+     (define list? (syntax->list form))
+     (if list? (recur-on-all list?) '())]))

typed-racket-lib/typed-racket/typecheck/def-export.rkt

@@ -1,16 +0,0 @@
-#lang racket/base
-
-(require 
-  (for-syntax syntax/parse racket/base
-              "renamer.rkt"
-              "../utils/tc-utils.rkt"))
-(provide def-export)
-
-(define-syntax (def-export stx)
-  (syntax-parse stx
-    [(def-export export-id:identifier id:identifier cnt-id:identifier)
-     #'(define-syntax export-id
-         (let ([c #'cnt-id])
-           (if (unbox typed-context?)
-               (renamer #'id c)
-               (renamer c))))]))