From 9821c485c03af01e6326d05a0df000115ac7197d Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 25 Jan 2010 14:48:11 +0000
Subject: [PATCH 1/7] new doc branch

svn: r17813

original commit: e071050f7f498fc4c23c33facbe5880e9124cbfc
---
 .../typed-scheme/private/base-special-env.ss     | 16 +++++++++-------
 collects/typed-scheme/utils/tc-utils.ss          | 16 ++++------------
 2 files changed, 13 insertions(+), 19 deletions(-)

diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss
index 2d430d8b..539bd140 100644
--- a/collects/typed-scheme/private/base-special-env.ss
+++ b/collects/typed-scheme/private/base-special-env.ss
@@ -12,13 +12,14 @@
  string-constants/string-constant
  ;(prefix-in ce: test-engine/scheme-tests)
  (for-syntax
-  scheme/base syntax/parse
+  scheme/base syntax/parse mzlib/etc
   (utils tc-utils)
   (env init-envs)          
   (except-in (rep filter-rep object-rep type-rep) make-arr)
   (types convenience union)
   (only-in (types convenience) [make-arr* make-arr])          
-  (typecheck tc-structs)))
+  (typecheck tc-structs))
+ (for-meta 2 scheme/base syntax/parse))
 
 
 (define-for-syntax (initialize-others)
@@ -78,11 +79,12 @@
           (-> (-lst a) (-val '()) (-lst a))
           (-> (-lst a) (-lst b) (-lst (*Un a b)))))
   ;; make-sequence
-  [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f)
-     #:context #'make-sequence
-     #:literals (let-values quote)
-     [(let-values ([_ (m-s '(_) '())]) . _)
-      #'m-s])
+  [(begin-lifted
+     (syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f)
+       #:context #'make-sequence
+       #:literals (let-values quote)
+       [(let-values ([_ (m-s '(_) '())]) . _)
+        #'m-s]))
    (-poly (a) 
           (let ([seq-vals 
                  (lambda ([a a])
diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss
index ce76d55e..60f996ec 100644
--- a/collects/typed-scheme/utils/tc-utils.ss
+++ b/collects/typed-scheme/utils/tc-utils.ss
@@ -6,7 +6,8 @@ don't depend on any other portion of the system
 |#
 
 (provide (all-defined-out))
-(require "syntax-traversal.ss" syntax/parse (for-syntax scheme/base syntax/parse) scheme/match)
+(require "syntax-traversal.ss" syntax/parse (for-syntax scheme/base syntax/parse) scheme/match
+         (for-syntax unstable/syntax))
 
 ;; a parameter representing the original location of the syntax being currently checked
 (define current-orig-stx (make-parameter #'here))
@@ -155,17 +156,8 @@ don't depend on any other portion of the system
     #:attributes (ty id)
     (pattern [nm:identifier ty]
              #:with id #'#'nm)
-    (pattern [e:expr ty extra-mods ...]
-             #:with id #'(let ([new-ns
-                                (let* ([ns (make-empty-namespace)])
-                                  (namespace-attach-module (current-namespace)
-                                                           'scheme/base
-                                                           ns)
-                                  ns)])
-                           (parameterize ([current-namespace new-ns])
-                             (namespace-require 'scheme/base)
-                             (namespace-require 'extra-mods) ...
-                             e))))
+    (pattern [e:expr ty]
+             #:with id #'e))
   (syntax-parse stx
     [(_ e:spec ...)
      #'(list (list e.id e.ty) ...)]))

From 0a8b1acb6f8c5a10249421e1d0b6755c3e93a61b Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 25 Jan 2010 15:36:56 +0000
Subject: [PATCH 2/7] work on new guide

svn: r17814

original commit: e65535c88037da8c21876c9c4a7fcd62efdbe9d4
---
 collects/typed-scheme/info.ss                 |   4 +-
 collects/typed-scheme/scribblings/begin.scrbl |  81 ++++++++++
 collects/typed-scheme/scribblings/more.scrbl  | 138 +++++++++++++++++
 collects/typed-scheme/scribblings/quick.scrbl |  48 ++++++
 .../{ => scribblings}/ts-guide.scrbl          | 144 +++---------------
 .../{ => scribblings}/ts-reference.scrbl      |  24 +--
 collects/typed-scheme/scribblings/utils.ss    |  23 +++
 .../typed-scheme/scribblings/varargs.scrbl    | 105 +++++++++++++
 8 files changed, 427 insertions(+), 140 deletions(-)
 create mode 100644 collects/typed-scheme/scribblings/begin.scrbl
 create mode 100644 collects/typed-scheme/scribblings/more.scrbl
 create mode 100644 collects/typed-scheme/scribblings/quick.scrbl
 rename collects/typed-scheme/{ => scribblings}/ts-guide.scrbl (65%)
 rename collects/typed-scheme/{ => scribblings}/ts-reference.scrbl (95%)
 create mode 100644 collects/typed-scheme/scribblings/utils.ss
 create mode 100644 collects/typed-scheme/scribblings/varargs.scrbl

diff --git a/collects/typed-scheme/info.ss b/collects/typed-scheme/info.ss
index e245bb52..c18cc35e 100644
--- a/collects/typed-scheme/info.ss
+++ b/collects/typed-scheme/info.ss
@@ -1,4 +1,4 @@
 #lang setup/infotab
 
-(define scribblings '(("ts-reference.scrbl" ())
-		      ("ts-guide.scrbl" ())))
+(define scribblings '(("scribblings/ts-reference.scrbl" ())
+		      ("scribblings/ts-guide.scrbl" (multi-page))))
diff --git a/collects/typed-scheme/scribblings/begin.scrbl b/collects/typed-scheme/scribblings/begin.scrbl
new file mode 100644
index 00000000..d20cd329
--- /dev/null
+++ b/collects/typed-scheme/scribblings/begin.scrbl
@@ -0,0 +1,81 @@
+#lang scribble/manual
+
+@begin[(require (for-label typed/scheme) scribble/eval
+		"utils.ss" (only-in "quick.scrbl" typed-mod))]
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require typed/scheme))
+
+@title[#:tag "beginning"]{Beginning Typed Scheme}
+
+Recall the typed module from @secref["quick"]:                 
+
+@|typed-mod|
+
+Let us consider each element of this program in turn.
+
+@schememod[typed/scheme]
+
+This specifies that the module is written in the
+@schememodname[typed/scheme] language, which is a typed version of the
+@schememodname[scheme] language.  Typed versions of other languages
+are provided as well; for example, the
+@schememodname[typed/scheme/base] language corresponds to
+@schememodname[scheme/base].   
+
+@schemeblock[(define-struct: pt ([x : Real] [y : Real]))]
+
+@margin-note{Many forms in Typed Scheme have the same name as the
+untyped forms, with a @scheme[:] suffix.}
+This defines a new structure, name @scheme[pt], with two fields,
+@scheme[x] and @scheme[y].  Both fields are specified to have the type
+@scheme[Real], which corresponds to the @rtech{real numbers}.
+ The
+@scheme[define-struct:] form corresponds to the @scheme[define-struct]
+form from @schememodname[scheme]---when porting a program from
+@schememodname[scheme] to @schememodname[typed/scheme], uses of
+@scheme[define-struct] should be changed to @scheme[define-struct:].
+
+@schemeblock[(: mag (pt -> Real))]
+
+This declares that @scheme[mag] has the type @scheme[(pt -> Real)].
+@;{@scheme[mag] must be defined at the top-level of the module containing
+the declaration.}
+
+The type @scheme[(pt -> Real)] is a function type, that is, the type
+of a procedure.  The input type, or domain, is a single argument of
+type @scheme[pt], which refers to an instance of the @scheme[pt]
+structure.  The @scheme[->] both indicates that this is a function
+type and separates the domain from  the range, or output type, in this
+case @scheme[Real].
+
+@schemeblock[
+(define (mag p)
+  (sqrt (sqr (pt-x p)) (sqr (pt-y p))))
+]
+
+This definition is unchanged from the untyped version of the code.
+The goal of Typed Scheme is to  allow almost all definitions to be
+typechecked without change.  The typechecker verifies that the body of
+the function has the type @scheme[Real], under the assumption that
+@scheme[p] has the type @scheme[pt], taking these types from the
+earlier type declaration.  Since the body does have this type, the
+program is accepted.
+
+
+@section{Type Errors}
+
+When Typed Scheme detects a type error in the module, it raises an
+error before running the program.  
+
+@examples[#:eval the-eval
+(add1 "not a number")
+]
+
+@;{
+Typed Scheme also attempts to detect more than one error in the module.
+
+@examples[#:eval the-eval
+(string-append "a string" (add1 "not a number"))
+]
+}
\ No newline at end of file
diff --git a/collects/typed-scheme/scribblings/more.scrbl b/collects/typed-scheme/scribblings/more.scrbl
new file mode 100644
index 00000000..154f9d32
--- /dev/null
+++ b/collects/typed-scheme/scribblings/more.scrbl
@@ -0,0 +1,138 @@
+#lang scribble/manual
+
+@begin[(require "utils.ss"
+		scribble/core scribble/eval
+		(for-label typed/scheme mzlib/etc))]
+
+@title[#:tag "more"]{More Features}
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require typed/scheme))
+
+
+The previous section introduced the basics of the Typed Scheme type
+system.  In this section, we will see several new features of the
+language and the type system.  The next
+subsequent section will explain these features in more detail.
+
+@section{Type Annotation and Binding Forms}
+
+In general, variables in Typed Scheme must be annotated with their
+type.  
+
+@subsection{Annotating Definitions}
+
+We have already seen the @scheme[:] type annotation form.  This is
+useful for definitions, at both the top level of a module
+
+@schemeblock[
+(: x Number)
+(define x 7)]
+
+and in an internal definition
+
+@schemeblock[
+(let ()
+  (: x Number)
+  (define x 7)
+  (add1 x))
+]
+
+In addition to the @scheme[:] form, almost all binding forms from
+@schememodname[scheme] have counterparts which allow the specification
+of types. The @scheme[define:] form allows the definition of variables
+in both top-level and internal contexts.
+
+@schemeblock[
+(define: x : Number 7)
+(define: (id [z : Number]) z)]
+
+Here, @scheme[x] has the type @scheme[Number], and @scheme[id] has the
+type @scheme[(Number -> Number)].  In the body of @scheme[id],
+@scheme[z] has the type @scheme[Number]. 
+
+@subsection{Annotating Local Binding}
+
+@schemeblock[
+(let: ([x : Number 7])
+  (add1 x))
+]
+
+The @scheme[let:] form is exactly like @scheme[let], but type
+annotations are provided for each variable bound.  Here, @scheme[x] is
+given the type @scheme[Number].  The @scheme[let*:] and
+@scheme[letrec:] are similar.
+
+@schemeblock[
+(let-values: ([([x : Number] [y : String]) (values 7 "hello")])
+  (+ x (string-length y)))
+]
+
+The @scheme[let*-values:] and @scheme[letrec-values:] forms are similar.
+
+@subsection{Annotating Functions}
+
+Function expressions also bind variables, which can be annotated with
+types. This function expects two arguments, a @scheme[Number] and a
+@scheme[String]: 
+
+@schemeblock[(lambda: ([x : Number] [y : String]) (+ x 5))]
+
+This function accepts at least one @scheme[String], followed by
+arbitrarily many @scheme[Number]s.  In the body, @scheme[y] is a list
+of @scheme[Number]s.
+
+@schemeblock[(lambda: ([x : String] (unsyntax @tt["."]) [y : Number #,**]) (apply + y))]
+
+This function has the type @scheme[(String Number #,** -> Number)].
+Functions defined by cases may also be annotated:
+
+@schemeblock[(case-lambda: [() 0]
+			   [([x : Number]) x])]
+
+This function has the type 
+@scheme[(case-lambda (-> Number) (Number -> Number))].   
+
+@subsection{Annotating Single Variables}
+
+When a single variable binding needs annotation, the annotation can be
+applied to a single variable using a reader extension:
+
+@schemeblock[
+(let ([#,(annvar x Number) 7]) (add1 x))]
+
+This is equivalent to the earlier use of @scheme[let:]. This is
+especially useful for binding forms which do not have counterparts
+provided by Typed Scheme, such as @scheme[let+]:
+
+@schemeblock[
+(let+ ([val #,(annvar x Number) (+ 6 1)]) 
+  (* x x))]
+
+@subsection{Annotating Expressions}
+
+It is also possible to provide an expected type for a particular
+expression.   
+
+@schemeblock[(ann (+ 7 1) Number)]
+
+This ensures that the expression, here @scheme[(+ 7 1)], has the
+desired type, here @scheme[Number].  Otherwise, the type checker
+signals an error.  For example:
+
+@interaction[#:eval the-eval
+(ann "not a number" Number)]
+
+@section{Type Inference}
+
+@section{Subtyping}
+
+@section{Occurrence Typing}
+
+@section{Recursive Types}
+
+@section{Polymorphism}
+
+@include-section["varargs.scrbl"]
+
+@section{Refinement Types}
diff --git a/collects/typed-scheme/scribblings/quick.scrbl b/collects/typed-scheme/scribblings/quick.scrbl
new file mode 100644
index 00000000..6486194b
--- /dev/null
+++ b/collects/typed-scheme/scribblings/quick.scrbl
@@ -0,0 +1,48 @@
+#lang scribble/manual
+
+@(require "utils.ss" (for-label typed/scheme))
+@(provide typed-mod)
+
+@title[#:tag "quick"]{Quick Start}
+
+Given a module written in the @schememodname[scheme] language, using
+Typed Scheme requires the following steps:
+
+@itemize[#:style 
+         'ordered
+         @item{Change the language to @schememodname[typed/scheme].}
+         @item{Change the uses of @scheme[(require mod)] to
+           @scheme[(require typed/mod)].} 
+         @item{Annotate structure definitions and top-level
+           definitions with their types.} ]
+
+Then, when the program is run, it will automatically be typechecked
+before any execution, and any type errors will be reported.  If there
+are any type errors, the program will not run.
+
+Here is an example program, written in the @schememodname[scheme]
+language:
+
+@(define typed-mod
+@schememod[
+typed/scheme
+(define-struct: pt ([x : Real] [y : Real]))
+
+(: mag (pt -> Real))
+(define (mag p)
+  (sqrt (sqr (pt-x p)) (sqr (pt-y p))))
+]
+)
+
+@schememod[
+scheme
+(define-struct pt (x y))
+
+(code:contract mag : pt -> number)
+(define (mag p)
+  (sqrt (sqr (pt-x p)) (sqr (pt-y p))))
+]
+
+Here is the same program, in @schememodname[typed/scheme]:
+
+@|typed-mod|
diff --git a/collects/typed-scheme/ts-guide.scrbl b/collects/typed-scheme/scribblings/ts-guide.scrbl
similarity index 65%
rename from collects/typed-scheme/ts-guide.scrbl
rename to collects/typed-scheme/scribblings/ts-guide.scrbl
index 75c0b713..dd604dde 100644
--- a/collects/typed-scheme/ts-guide.scrbl
+++ b/collects/typed-scheme/scribblings/ts-guide.scrbl
@@ -1,37 +1,29 @@
-#lang scribble/doc
+#lang scribble/manual
 
-@begin[(require scribble/manual)
-       (require (for-label typed-scheme))]
-
-@begin[
-(define (item* header . args) (apply item @bold[header]{: } args))
-(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...))
-(define (gtech . x)  (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl")))
-(define (rtech . x)  (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl")))
-]
+@begin[(require "utils.ss" (for-label typed/scheme))]
 
 @title[#:tag "top"]{@bold{Typed Scheme}: Scheme with Static Types}
 
 @author["Sam Tobin-Hochstadt"]
 
-@section-index["typechecking"]
+@section-index["typechecking" "typechecker" "typecheck"]
 
-Typed Scheme is a Scheme-like language, with a type system that
-supports common Scheme programming idioms.  Explicit type declarations
-are required --- that is, there is no type inference.  The language
-supports a number of features from previous work on type systems that
-make it easier to type Scheme programs, as well as a novel idea dubbed
-@italic{occurrence typing} for case discrimination.
+Typed Scheme is a family of languages, each of which enforce
+that programs written in the language obey a type system that ensures
+the absence of many common errors.  This guide is intended for programmers familiar 
+with PLT Scheme.  For an introduction to PLT Scheme, see the @(other-manual '(lib "scribblings/guide/guide.scrbl")).
 
-Typed Scheme is also designed to integrate with the rest of your PLT
-Scheme system.  It is possible to convert a single module to Typed
-Scheme, while leaving the rest of the program unchanged.  The typed
-module is protected from the untyped code base via
-automatically-synthesized contracts.
+@local-table-of-contents[]
 
-Further information on Typed Scheme is available from
-@link["http://www.ccs.neu.edu/home/samth/typed-scheme"]{the homepage}.
+@include-section["quick.scrbl"]
+@include-section["begin.scrbl"]
+@include-section["more.scrbl"]
 
+@section{How the Type System Works}
+
+@section{Integrating with Untyped Code}
+
+@;{
 @section{Starting with Typed Scheme}
 
 If you already know PLT Scheme, or even some other Scheme, it should be
@@ -191,7 +183,7 @@ process of elimination we can determine that @scheme[t] must be a
 @scheme[node].  Therefore, we can use accessors such as
 @scheme[node-left] and @scheme[node-right] with @scheme[t] as input.
 
-@section{Polymorphism}
+@section[#:tag "poly"]{Polymorphism}
 
 Typed Scheme offers abstraction over types as well as values.
 
@@ -303,104 +295,4 @@ The new type constructor @scheme[All] takes a list of type
 variables and a body type.  The type variables are allowed to
 appear free in the body of the @scheme[All] form.
 
-@section{Variable-Arity Functions: Programming with Rest Arguments}
-
-Typed Scheme can handle some uses of rest arguments.
-
-@subsection{Uniform Variable-Arity Functions}
-
-In Scheme, one can write a function that takes an arbitrary
-number of arguments as follows:
-
-@schememod[
-scheme
-(define (sum . xs)
-  (if (null? xs)
-      0
-      (+ (car xs) (apply sum (cdr xs)))))
-
-(sum)
-(sum 1 2 3 4)
-(sum 1 3)]
-
-The arguments to the function that are in excess to the
-non-rest arguments are converted to a list which is assigned
-to the rest parameter.  So the examples above evaluate to
-@schemeresult[0], @schemeresult[10], and @schemeresult[4].
-
-We can define such functions in Typed Scheme as well:
-
-@schememod[
-typed-scheme
-(: sum (Number * -> Number))
-(define (sum . xs)
-  (if (null? xs)
-      0
-      (+ (car xs) (apply sum (cdr xs)))))]
-
-This type can be assigned to the function when each element
-of the rest parameter is used at the same type.
-
-@subsection{Non-Uniform Variable-Arity Functions}
-
-However, the rest argument may be used as a heterogeneous list.
-Take this (simplified) definition of the Scheme function @scheme[map]:
-
-@schememod[
-scheme
-(define (map f as . bss)
-  (if (or (null? as)
-          (ormap null? bss))
-      null
-      (cons (apply f (car as) (map car bss))
-            (apply map f (cdr as) (map cdr bss)))))
-
-(map add1 (list 1 2 3 4))
-(map cons (list 1 2 3) (list (list 4) (list 5) (list 6)))
-(map + (list 1 2 3) (list 2 3 4) (list 3 4 5) (list 4 5 6))]
-
-Here the different lists that make up the rest argument @scheme[bss]
-can be of different types, but the type of each list in @scheme[bss]
-corresponds to the type of the corresponding argument of @scheme[f].
-We also know that, in order to avoid arity errors, the length of
-@scheme[bss] must be one less than the arity of @scheme[f] (as
-@scheme[as] corresponds to the first argument of @scheme[f]).
-                                                            
-The example uses of @scheme[map] evaluate to @schemeresult[(list 2 3 4 5)],
-@schemeresult[(list (list 1 4) (list 2 5) (list 3 6))], and
-@schemeresult[(list 10 14 18)].
-
-In Typed Scheme, we can define @scheme[map] as follows:
-
-@schememod[
-typed-scheme
-(: map 
-   (All (C A B ...)
-        ((A B ... B -> C) (Listof A) (Listof B) ... B
-         ->
-         (Listof C))))
-(define (map f as . bss)
-  (if (or (null? as)
-          (ormap null? bss))
-      null
-      (cons (apply f (car as) (map car bss))
-            (apply map f (cdr as) (map cdr bss)))))]
-
-Note that the type variable @scheme[B] is followed by an
-ellipsis.  This denotes that B is a dotted type variable
-which corresponds to a list of types, much as a rest
-argument corresponds to a list of values.  When the type
-of @scheme[map] is instantiated at a list of types, then
-each type @scheme[t] which is bound by @scheme[B] (notated by
-the dotted pre-type @scheme[t ... B]) is expanded to a number
-of copies of @scheme[t] equal to the length of the sequence
-assigned to @scheme[B].  Then @scheme[B] in each copy is
-replaced with the corresponding type from the sequence.
-
-So the type of @scheme[(inst map Integer Boolean String Number)]
-is
-
-@scheme[((Boolean String Number -> Integer)
-         (Listof Boolean) (Listof String) (Listof Number)
-         ->
-         (Listof Integer))].
+}
\ No newline at end of file
diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl
similarity index 95%
rename from collects/typed-scheme/ts-reference.scrbl
rename to collects/typed-scheme/scribblings/ts-reference.scrbl
index 3e7731dc..7b390e9a 100644
--- a/collects/typed-scheme/ts-reference.scrbl
+++ b/collects/typed-scheme/scribblings/ts-reference.scrbl
@@ -1,29 +1,24 @@
-#lang scribble/doc
+#lang scribble/manual
 
-@begin[(require scribble/manual scribble/eval
+@begin[(require "utils.ss" scribble/eval
                 scheme/sandbox)
-       (require (for-label typed-scheme
+       (require (for-label typed/scheme
                            scheme/list srfi/14
                            version/check))]
 
-@begin[
-(define (item* header . args) (apply item @bold[header]{: } args))
-(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...))
-(define (gtech . x)  (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl")))
-(define (rtech . x)  (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl")))
-]
 
 @title[#:tag "top"]{The Typed Scheme Reference} 
 
 @author["Sam Tobin-Hochstadt"]
 
-@(defmodulelang typed-scheme)
+@(defmodulelang* (typed/scheme typed/scheme/base typed-scheme))
 
 @section[#:tag "type-ref"]{Type Reference}
 
 @subsubsub*section{Base Types}
 @deftogether[(
 @defidform[Number]
+@defidform[Real]
 @defidform[Integer]
 @defidform[Boolean]
 @defidform[String]
@@ -126,8 +121,13 @@ result of @scheme[_loop] (and thus the result of the entire
 				expression in @scheme[body]).}
 @deftogether[[
 @defform[(letrec: ([v : t e] ...) . body)]
-@defform[(let*: ([v : t e] ...) . body)]]]{Type-annotated versions of
-@scheme[letrec] and @scheme[let*].}
+@defform[(let*: ([v : t e] ...) . body)]
+@defform[(let-values: ([([v : t] ...) e] ...) . body)]
+@defform[(letrec-values: ([([v : t] ...) e] ...) . body)]
+@defform[(let*-values: ([([v : t] ...) e] ...) . body)]]]{
+Type-annotated versions of
+@scheme[letrec], @scheme[let*], @scheme[let-values],
+  @scheme[letrec-values], and @scheme[let*-values].}  
 
 @deftogether[[
 @defform[(let/cc: v : t . body)]
diff --git a/collects/typed-scheme/scribblings/utils.ss b/collects/typed-scheme/scribblings/utils.ss
new file mode 100644
index 00000000..885f82c6
--- /dev/null
+++ b/collects/typed-scheme/scribblings/utils.ss
@@ -0,0 +1,23 @@
+#lang at-exp scheme
+
+(require scribble/manual scribble/core)
+(provide (all-defined-out))
+
+(define (item* header . args) (apply item @bold[header]{: } args))
+(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...))
+(define (gtech . x)
+  (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl")))
+(define (rtech . x)
+  (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl")))
+
+(define ** (let ([* #f]) @scheme[*]))
+
+(define-syntax-rule (annvar x t)
+  (make-element #f (list @schemeparenfont["#{"]
+			 @scheme[x : t]
+			 @schemeparenfont["}"])))
+
+(define-syntax-rule (annexpr x t)
+  (make-element #f (list @schemeparenfont["#{"]
+			 @scheme[x :: t]
+			 @schemeparenfont["}"])))
diff --git a/collects/typed-scheme/scribblings/varargs.scrbl b/collects/typed-scheme/scribblings/varargs.scrbl
new file mode 100644
index 00000000..2e8022c6
--- /dev/null
+++ b/collects/typed-scheme/scribblings/varargs.scrbl
@@ -0,0 +1,105 @@
+#lang scribble/manual
+
+@begin[(require "utils.ss" (for-label typed/scheme))]
+
+@title[#:tag "varargs"]{Variable-Arity Functions: Programming with Rest Arguments}
+
+Typed Scheme can handle some uses of rest arguments.
+
+@section{Uniform Variable-Arity Functions}
+
+In Scheme, one can write a function that takes an arbitrary
+number of arguments as follows:
+
+@schememod[
+scheme
+(define (sum . xs)
+  (if (null? xs)
+      0
+      (+ (car xs) (apply sum (cdr xs)))))
+
+(sum)
+(sum 1 2 3 4)
+(sum 1 3)]
+
+The arguments to the function that are in excess to the
+non-rest arguments are converted to a list which is assigned
+to the rest parameter.  So the examples above evaluate to
+@schemeresult[0], @schemeresult[10], and @schemeresult[4].
+
+We can define such functions in Typed Scheme as well:
+
+@schememod[
+typed-scheme
+(: sum (Number * -> Number))
+(define (sum . xs)
+  (if (null? xs)
+      0
+      (+ (car xs) (apply sum (cdr xs)))))]
+
+This type can be assigned to the function when each element
+of the rest parameter is used at the same type.
+
+@section{Non-Uniform Variable-Arity Functions}
+
+However, the rest argument may be used as a heterogeneous list.
+Take this (simplified) definition of the Scheme function @scheme[map]:
+
+@schememod[
+scheme
+(define (map f as . bss)
+  (if (or (null? as)
+          (ormap null? bss))
+      null
+      (cons (apply f (car as) (map car bss))
+            (apply map f (cdr as) (map cdr bss)))))
+
+(map add1 (list 1 2 3 4))
+(map cons (list 1 2 3) (list (list 4) (list 5) (list 6)))
+(map + (list 1 2 3) (list 2 3 4) (list 3 4 5) (list 4 5 6))]
+
+Here the different lists that make up the rest argument @scheme[bss]
+can be of different types, but the type of each list in @scheme[bss]
+corresponds to the type of the corresponding argument of @scheme[f].
+We also know that, in order to avoid arity errors, the length of
+@scheme[bss] must be one less than the arity of @scheme[f] (as
+@scheme[as] corresponds to the first argument of @scheme[f]).
+                                                            
+The example uses of @scheme[map] evaluate to @schemeresult[(list 2 3 4 5)],
+@schemeresult[(list (list 1 4) (list 2 5) (list 3 6))], and
+@schemeresult[(list 10 14 18)].
+
+In Typed Scheme, we can define @scheme[map] as follows:
+
+@schememod[
+typed-scheme
+(: map 
+   (All (C A B ...)
+        ((A B ... B -> C) (Listof A) (Listof B) ... B
+         ->
+         (Listof C))))
+(define (map f as . bss)
+  (if (or (null? as)
+          (ormap null? bss))
+      null
+      (cons (apply f (car as) (map car bss))
+            (apply map f (cdr as) (map cdr bss)))))]
+
+Note that the type variable @scheme[B] is followed by an
+ellipsis.  This denotes that B is a dotted type variable
+which corresponds to a list of types, much as a rest
+argument corresponds to a list of values.  When the type
+of @scheme[map] is instantiated at a list of types, then
+each type @scheme[t] which is bound by @scheme[B] (notated by
+the dotted pre-type @scheme[t ... B]) is expanded to a number
+of copies of @scheme[t] equal to the length of the sequence
+assigned to @scheme[B].  Then @scheme[B] in each copy is
+replaced with the corresponding type from the sequence.
+
+So the type of @scheme[(inst map Integer Boolean String Number)]
+is
+
+@scheme[((Boolean String Number -> Integer)
+         (Listof Boolean) (Listof String) (Listof Number)
+         ->
+         (Listof Integer))].

From d20ee9bf2be8aee706d7ccfc22ea86f5304b32ad Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 28 Jan 2010 21:47:05 +0000
Subject: [PATCH 3/7] progress on refactoring rep

svn: r17875

original commit: bbc195c0fb6d54bb645b163fe6540af342fbc004
---
 collects/typed-scheme/rep/filter-rep.ss       |   8 +-
 collects/typed-scheme/rep/interning.ss        |   8 +-
 collects/typed-scheme/rep/rep-utils.ss        | 290 ++++++++----------
 .../typed-scheme/typecheck/tc-expr-unit.ss    |   2 +-
 collects/typed-scheme/types/abbrev.ss         |   8 +-
 collects/typed-scheme/types/convenience.ss    |   2 +-
 collects/typed-scheme/utils/utils.ss          |   2 +-
 7 files changed, 143 insertions(+), 177 deletions(-)

diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss
index e3a95d30..4e60c8a8 100644
--- a/collects/typed-scheme/rep/filter-rep.ss
+++ b/collects/typed-scheme/rep/filter-rep.ss
@@ -43,12 +43,12 @@
      [#:contract (->d ([t (cond [(ormap Bot? t)
                                  (list/c Bot?)]
                                 [(ormap Bot? e)
-                                 (list/c)]
+                                 (flat-named-contract "e was Bot" (list/c))]
                                 [else (listof Filter/c)])]
                        [e (cond [(ormap Bot? e)
                                  (list/c Bot?)]
                                 [(ormap Bot? t)
-                                 (list/c)]
+                                 (flat-named-contract "t was Bot" (list/c))]
                                 [else (listof Filter/c)])])
                       ()
                       [result FilterSet?])])
@@ -82,12 +82,12 @@
      [#:contract (->d ([t (cond [(ormap LBot? t)
                                  (list/c LBot?)]
                                 [(ormap LBot? e)
-                                 (list/c)]
+                                 (flat-named-contract "e was LBot" (list/c))]
                                 [else (listof LatentFilter/c)])]
                        [e (cond [(ormap LBot? e)
                                  (list/c LBot?)]
                                 [(ormap LBot? t)
-                                 (list/c)]
+                                 (flat-named-contract "t was LBot" (list/c))]
                                 [else (listof LatentFilter/c)])])
                       ()
                       [result LFilterSet?])])
diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss
index 3dfd9aef..c09160e7 100644
--- a/collects/typed-scheme/rep/interning.ss
+++ b/collects/typed-scheme/rep/interning.ss
@@ -6,11 +6,9 @@
 
 (define-syntax (defintern stx)
   (syntax-parse stx
-    [(_ name+args make-name key (~optional (~seq #:extra-arg e:expr)) ...)
-     (if (attribute e)
-         #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)
-         #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))]
-    [(_ (*name:id arg:id ...) make-ht make-name key-expr (~seq #:extra-arg e:expr) ...)
+    [(_ name+args make-name key #:extra-args e:expr ...)
+     #'(defintern name+args (lambda () (make-hash)) make-name key #:extra-args e ...)]
+    [(_ (*name:id arg:id ...) make-ht make-name key-expr #:extra-args e:expr ...)
      #'(define *name
 	 (let ([table (make-ht)])
 	   (lambda (arg ...)
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index a0de7c5a..85a933e6 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -26,6 +26,7 @@
 (provide == defintern hash-id (for-syntax fold-target))
 
 (define-for-syntax fold-target #'fold-target)
+(define-for-syntax default-fields (list #'seq #;#;#'free-vars #'free-idxs))
 
 (define-for-syntax (mk par ht-stx key?)
   (define-syntax-class opt-cnt-id
@@ -60,89 +61,92 @@
              #:with def #'(define id e)
              #:with f1 #'(id free-vars*)
              #:with f2 #'(id free-idxs*)))
-  (define-syntax-class fold-pat
+  (define-syntax-class (fold-pat fold-name)
     #:transparent
-    #:attributes (e)
+    #:attributes (e proc)
     (pattern #:base
-             #:with e fold-target)
+             #:with e fold-target
+             #:with proc #`(procedure-rename
+                            (lambda () #,fold-target)
+                            '#,fold-name))
     (pattern ex:expr
-             #:with e #'#'ex))
+             #:with e #'#'ex
+             #:with proc #`(procedure-rename
+                            (lambda () #'ex)
+                            '#,fold-name)))
+  (define-syntax-class form-nm
+    (pattern nm:id
+             #:with ex (format-id #'nm "~a:" #'nm)
+             #:with fold (format-id #f "~a-fold" #'nm)
+             #:with kw (string->keyword (symbol->string (syntax-e #'nm)))
+             #:with *maker (format-id #'nm "*~a" #'nm)
+             #:with **maker (format-id #'nm "**~a" #'nm)))
   (lambda (stx)          
     (syntax-parse stx 
-      [(dform nm:id flds:idlist (~or 
-                                 (~optional [#:key key-expr:expr])
-                                 (~optional [#:intern intern?:expr])
-                                 (~optional [#:frees frees:frees-pat])
-                                 (~optional [#:fold-rhs fold-rhs:fold-pat])
-                                 (~optional [#:contract cnt:expr])
-                                 (~optional no-provide?:no-provide-kw)) ...)
+      [(dform nm:form-nm flds:idlist (~or 
+                                      (~optional (~and (~fail #:unless key? "#:key not allowed")
+                                                       [#:key key-expr:expr]))
+                                      (~optional [#:intern intern?:expr]
+                                                 #:defaults
+                                                 ([intern? (syntax-parse #'flds.fs
+                                                             [() #'#f]
+                                                             [(f) #'f]
+                                                             [(fs ...) #'(list fs ...)])]))
+                                      (~optional [#:frees frees:frees-pat]
+                                                 #:defaults 
+                                                 ([frees.def #'(begin)]
+                                                  [frees.f1 (combiner #'free-vars* #'flds.fs)]
+                                                  [frees.f2 (combiner #'free-idxs* #'flds.fs)]))
+                                      (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
+                                                 #:defaults
+                                                 ([fold-rhs.proc
+                                                   #'(procedure-rename
+                                                      (lambda () 
+                                                        #`(nm.*maker (#,type-rec-id flds.i) ...))
+                                                      'nm.fold)]))
+                                      (~optional [#:contract cnt:expr])
+                                      (~optional no-provide?:no-provide-kw)) ...)
        (with-syntax* 
-        ([ex (format-id #'nm "~a:" #'nm)]
-         [fold-name (format-id #f "~a-fold" #'nm)]
-         [kw-stx (string->keyword (symbol->string (attribute nm.datum)))]
-         [parent par]
-         [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
-         [*maker (format-id #'nm "*~a" #'nm)]
-         [**maker (format-id #'nm "**~a" #'nm)]
+        ([(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
          [*maker-cnt (if enable-contracts?
                          (or (attribute cnt) #'(flds.cnt ... . -> . pred))
                          #'any/c)]
-         [ht-stx ht-stx]
-         [bfs-fold-rhs (cond [(attribute fold-rhs)
-                              #`(procedure-rename
-                                 (lambda () #,#'fold-rhs.e)
-                                 'fold-name)]
-                             ;; otherwise we assume that everything is a type, 
-                             ;; and recur on all the arguments
-                             [else #'(procedure-rename
-                                      (lambda () 
-                                        #`(*maker (#,type-rec-id flds.i) ...))
-                                      'fold-name)])]
          [provides (if (attribute no-provide?)
                        #'(begin)                                 
                        #`(begin 
-                           (provide #;nm ex pred acc ...)
-                           (p/c (rename *maker maker *maker-cnt))))]
+                           (provide nm.ex pred acc ...)
+                           (p/c (rename nm.*maker maker *maker-cnt))))]
          [intern 
           (let ([mk (lambda (int) 
 		      (if key? 
-			  #`(defintern (**maker . flds.fs) maker #,int #:extra-arg #,(attribute key-expr))
-			  #`(defintern (**maker . flds.fs) maker #,int)))])
-         (syntax-parse #'flds.fs
-              [_  #:fail-unless (attribute intern?) #f
-                 (mk #'intern?)]
-              [() (mk #'#f)]
-              [(f) (mk #'f)]
-              [_ (mk #'(list . flds.fs))]))]
-         [(ign-pats ...) (if key? #'(_ _) #'(_))]
-         [frees-def (if (attribute frees) #'frees.def #'(begin))]
+			  #`(defintern (nm.**maker . flds.fs) maker #,int 
+                              #:extra-args #,(attribute key-expr))
+			  #`(defintern (nm.**maker . flds.fs) maker #,int
+                              #:extra-args)))])
+            (mk #'intern?))]
+         [(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))]
          [frees 
-          (with-syntax ([(f1 f2) (if (attribute frees)
-                                     #'(frees.f1 frees.f2)
-                                     (list (combiner #'free-vars* #'flds.fs)
-                                           (combiner #'free-idxs* #'flds.fs)))])
             (quasisyntax/loc stx
-		(w/c nm ([*maker *maker-cnt])
-                   (define (*maker . flds.fs)
-                     (define v (**maker . flds.fs))
-                     frees-def
-                     (unless-in-table 
-                      var-table v
-                      (define fvs f1)
-                      (define fis f2)
-                      (hash-set! var-table v fvs)
-                      (hash-set! index-table v fis))
-                     v))))])
+		(w/c nm ([nm.*maker *maker-cnt])
+                     #,(syntax/loc #'nm
+                         (define (nm.*maker . flds.fs)
+                           (define v (nm.**maker . flds.fs))
+                           frees.def
+                           (unless-in-table 
+                            var-table v
+                            (hash-set! var-table v frees.f1)
+                            (hash-set! index-table v frees.f2))
+                           v))))])
         #`(begin
-            (define-struct (nm parent) flds.fs #:inspector #f)
-            (define-match-expander ex
+            (define-struct (nm #,par) flds.fs #:inspector #f)
+            (define-match-expander nm.ex
               (lambda (s)
                 (syntax-parse s 
                   [(_ . fs) 
                    #:with pat (syntax/loc s (ign-pats ... . fs))
                    (syntax/loc s (struct nm pat))])))
             (begin-for-syntax
-              (hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx)))
+              (hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f)))
             (w/c nm ()
 		 intern
 		 frees)
@@ -150,28 +154,7 @@
 
 (define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
   (lambda (stx)
-    (define new-ht (hash-copy ht))
-    (define (mk-matcher kw) 
-      (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
-    (define/contract (put k lst)
-      (keyword? (list/c syntax?
-                        syntax?
-                        (-> syntax?)
-                        syntax?) 
-                . -> . void?)
-      (hash-set! new-ht k lst))
-    (define (add-clause cl)
-      (syntax-parse cl
-        [(kw:keyword #:matcher mtch pats ... expr)
-         (put (syntax-e #'kw) (list #'mtch 
-                                    (syntax/loc cl (pats ...))
-                                    (lambda () #'expr)
-                                    cl))]
-        [(kw:keyword pats ... expr) 
-         (put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw)) 
-                                    (syntax/loc cl (pats ...))
-                                    (lambda () #'expr)
-                                    cl))]))
+    (define new-ht (hash-copy ht))    
     (define-syntax-class clause
       (pattern  
        (k:keyword #:matcher mtch pats ... e:expr)
@@ -183,111 +166,98 @@
       (pattern
        (k:keyword pats ... e:expr) 
        #:attr kw (syntax-e #'k)
-       #:attr val (list (mk-matcher (attribute kw)) 
+       #:attr val (list (format-id stx "~a:" (attribute kw))
                         (syntax/loc this-syntax (pats ...))
                         (lambda () #'e)
                         this-syntax)))
     (define (gen-clause k v)
       (match v
         [(list match-ex pats body-f src)
-         (let ([pat (quasisyntax/loc src (#,match-ex  . #,pats))])
-           (quasisyntax/loc src (#,pat #,(body-f))))]))
+         (let ([pat (quasisyntax/loc (or stx stx) (#,match-ex  . #,pats))])
+           (quasisyntax/loc (or src stx) (#,pat #,(body-f))))]))
     (define-syntax-class (keyword-in kws)
       #:attributes (datum)
       (pattern k:keyword
-               #:fail-unless (memq (attribute k.datum) kws) #f
+               #:fail-unless (memq (attribute k.datum) kws) (format "expected keyword in ~a" kws)
                #:attr datum (attribute k.datum)))
     (define-syntax-class (sized-list kws)
       #:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
-      (pattern ((~or (~seq k e:expr)) ...)
-               #:declare k (keyword-in kws)
-               #:fail-unless (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum)))) #f
+      (pattern ((~or (~seq (~var k (keyword-in kws)) e:expr)) ...)
+               #:when (equal? (length (attribute k.datum)) 
+                              (length (remove-duplicates (attribute k.datum))))
                #:attr mapping (for/hash ([k* (attribute k.datum)]
                                          [e* (attribute e)])
-                                (values k* e*))
-               ))
+                                (values k* e*))))
     (syntax-parse stx
-      [(tc recs ty clauses:clause ...)
-       #:declare recs (sized-list kws)
-       (begin 
-         (for ([k (attribute clauses.kw)]
-               [v (attribute clauses.val)])
-           (put k v))
-         (with-syntax ([(let-clauses ...)
-                        (for/list ([rec-id rec-ids]
-                                   [k kws])
-                          #`[#,rec-id #,(hash-ref (attribute recs.mapping) k
-                                                  #'values)])])
-           #`(let (let-clauses ...
-                   [#,fold-target ty])
-               ;; then generate the fold
-               #,(quasisyntax/loc stx
-                   (match #,fold-target
-                     #,@(hash-map new-ht gen-clause))))))])))
+      [(tc (~var recs (sized-list kws)) ty clauses:clause ...)
+       (for ([k (attribute clauses.kw)]
+             [v (attribute clauses.val)])
+         (hash-set! new-ht k v))
+       (with-syntax ([(let-clauses ...)
+                      (for/list ([rec-id rec-ids]
+                                 [k kws])
+                        #`[#,rec-id #,(hash-ref (attribute recs.mapping) k
+                                                #'values)])]
+                     [(match-clauses ...)
+                      (hash-map new-ht gen-clause)])
+         #`(let (let-clauses ...
+                 [#,fold-target ty])
+             ;; then generate the fold
+             #,(quasisyntax/loc stx
+                 (match #,fold-target
+                   match-clauses ...))))])))
 
 
-(define-syntax (make-prim-type stx)
-  (define default-flds #'(seq))
+(define-syntax (make-prim-type stx)    
   (define-syntax-class type-name-base
-    #:attributes (i lower-s first-letter key? (fld-names 1))
+    #:attributes (i d-id key? (fld-names 1))
     #:transparent
-    (pattern i:id
-             #:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
-             #:with (fld-names ...) default-flds
-	     #:with key? #'#f
-             #:attr first-letter (string-ref (attribute lower-s) 0))
-    (pattern [i:id #:d d-name:id]
-             #:with (fld-names ...) default-flds
-             #:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
-	     #:with key? #'#f
-             #:attr first-letter (symbol->string (attribute d-name.datum)))
-    (pattern [i:id #:key]
-             #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) 
-                                                              (syntax->list #'(key))))
-             #:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
-	     #:with key? #'#t
-             #:attr first-letter (string-ref (attribute lower-s) 0)))
+    (pattern [i:id (~optional (~and #:key
+                                    (~bind [key? #'#t]
+                                           [(fld-names 1) (append default-fields (list #'key))]))
+                              #:defaults ([key? #'#f]
+                                          [(fld-names 1) default-fields]))
+                   #:d d-id:id]))
   (define-syntax-class type-name
     #:transparent
     #:auto-nested-attributes
     (pattern :type-name-base
+             #:with lower-s (string->symbol (string-downcase (symbol->string (syntax-e #'i))))
              #:with name #'i
-             #:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i))))
+             #:with keyword (string->keyword (symbol->string (syntax-e #'i)))
              #:with tmp-rec-id (generate-temporary)
-             #:with case (format-id #'i "~a-case" (attribute lower-s))
-             #:with printer (format-id #'i "print-~a*" (attribute lower-s))
-             #:with ht (format-id #'i "~a-name-ht" (attribute lower-s))
-             #:with rec-id (format-id #'i "~a-rec-id" (attribute lower-s))
-             #:with d-id (format-id #'i "d~a" (attribute first-letter))
+             #:with case (format-id #'i "~a-case" #'lower-s)
+             #:with printer (format-id #'i "print-~a*" #'lower-s)
+             #:with ht (format-id #'i "~a-name-ht" #'lower-s)
+             #:with rec-id (format-id #'i "~a-rec-id" #'lower-s)
              #:with (_ _ pred? accs ...)
-                    (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
+                    (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))
   (syntax-parse stx
     [(_ i:type-name ...)
-     (with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))]
-                    [(default-ids ...) (generate-temporaries #'(i.name ...))]
-                    [fresh-ids-list #'(fresh-ids ...)]
-                    [(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)])
-       #'(begin
-           (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
-                    (for-syntax i.ht ... i.rec-id ...))
-           (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
-           (define-for-syntax i.ht (make-hasheq)) ...
-           (define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
-           (define-for-syntax i.rec-id #'i.rec-id) ...   
-           (provide i.case ...)           
-           (define-syntaxes (i.case ...)
-             (let ()               
-               (apply values
-                      (map (lambda (ht) 
-                             (mk-fold ht 
-                                      (car (list #'i.rec-id ...))
-                                      (list #'i.rec-id ...)
-                                      '(i.keyword ...)))
-                           (list i.ht ...)))))))]))
+     #'(begin
+         (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
+                  (for-syntax i.ht ... i.rec-id ...))
+         (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
+         (define-for-syntax i.ht (make-hasheq)) ...
+         (define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
+         (define-for-syntax i.rec-id #'i.rec-id) ...   
+         (provide i.case ...)           
+         (define-syntaxes (i.case ...)
+           (let ()               
+             (apply values
+                    (map (lambda (ht) 
+                           (define rec-ids (list i.rec-id ...))
+                           (mk-fold ht 
+                                    (car rec-ids)
+                                    rec-ids
+                                    '(i.keyword ...)))
+                         (list i.ht ...))))))]))
 
-(make-prim-type [Type #:key]
-                Filter
-                [LatentFilter #:d lf]
-                Object 
-                [LatentObject #:d lo]
-                [PathElem #:d pe])
+(make-prim-type [Type #:key #:d dt]
+                [Filter #:d df]
+                [LatentFilter #:d dlf]
+                [Object #:d do] 
+                [LatentObject #:d dlo]
+                [PathElem #:d dpe])
+
+(provide PathElem?)
\ No newline at end of file
diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss
index 6121a49f..6b31b393 100644
--- a/collects/typed-scheme/typecheck/tc-expr-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss
@@ -259,7 +259,7 @@
                                              (with-lexical-env/extend 
                                               (list or-part) (list (restrict t1 (-val #f))) (single-value e2 expected)))]
                     [t1* (remove t1 (-val #f))]
-                    [f1* (-FS fs+ (list (make-Bot)))])
+                    [f1* (-FS null (list (make-Bot)))])
          ;; if we have the same number of values in both cases
          (let ([r (combine-filter f1 f1* f2 t1* t2 o1 o2)])
            (if expected 
diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss
index ca5ca183..24f3decc 100644
--- a/collects/typed-scheme/types/abbrev.ss
+++ b/collects/typed-scheme/types/abbrev.ss
@@ -2,7 +2,7 @@
 
 (require "../utils/utils.ss")
 
-(require (rep type-rep object-rep filter-rep)
+(require (rep type-rep object-rep filter-rep rep-utils)
 	 "printer.ss" "utils.ss"
          (utils tc-utils)
          scheme/list
@@ -26,7 +26,7 @@
 (define -box make-Box)
 (define -vec make-Vector)
 (define -LFS make-LFilterSet)
-(define -FS make-FilterSet)
+(define-syntax -FS (make-rename-transformer #'make-FilterSet))
 
 (define-syntax *Un
   (syntax-rules ()
@@ -36,9 +36,7 @@
 (define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
 
 (define (-lst* #:tail [tail (-val null)] . args)
-  (if (null? args)
-      tail
-      (-pair (car args) (apply -lst* #:tail tail (cdr args)))))
+  (for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl)))
 
 (define (-Tuple l)
   (foldr -pair (-val '()) l))
diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss
index 15d818f6..4bcc4540 100644
--- a/collects/typed-scheme/types/convenience.ss
+++ b/collects/typed-scheme/types/convenience.ss
@@ -14,6 +14,7 @@
          make-Name make-ValuesDots make-Function
          (rep-out filter-rep object-rep))
 
+
 (define (one-of/c . args)
   (apply Un (map -val args)))
 
@@ -53,7 +54,6 @@
                  (*Un (-val '())
                       (-pair (-Syntax e)
                              (*Un (-Syntax e) list)))))))
-
 (define Any-Syntax (-Syntax In-Syntax))
 
 (define (-Sexpof t)
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index 8e3d6f73..766ba3c2 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -160,7 +160,7 @@ at least theoretically.
 
 
 ;; turn contracts on and off - off by default for performance.
-(define-for-syntax enable-contracts? #f)
+(define-for-syntax enable-contracts? #t)
 (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
 
 ;; these are versions of the contract forms conditionalized by `enable-contracts?'

From 30e08424ec09a4a8c511d83519f20181d1744ef7 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 29 Jan 2010 00:08:15 +0000
Subject: [PATCH 4/7] merge to trunk

svn: r17877

original commit: 9789615ed9840f09a6708d27276cf892d334b653
---
 .../typecheck/check-subforms-unit.ss          | 44 +++++++++++--------
 .../typed-scheme/typecheck/internal-forms.ss  | 23 ++++++----
 collects/typed-scheme/typecheck/tc-structs.ss |  7 ++-
 .../typed-scheme/typecheck/tc-toplevel.ss     | 35 ++++++++++-----
 collects/typed-scheme/utils/tc-utils.ss       | 17 ++++---
 5 files changed, 80 insertions(+), 46 deletions(-)

diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss
index ea97a7f1..037822e2 100644
--- a/collects/typed-scheme/typecheck/check-subforms-unit.ss
+++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss
@@ -2,6 +2,7 @@
 
 (require "../utils/utils.ss"
 	 syntax/kerncase
+	 syntax/parse
          scheme/match
          "signatures.ss" "tc-metafunctions.ss"
          (types utils convenience union subtype)
@@ -18,33 +19,40 @@
   (define body-ty #f)    
   (define (get-result-ty t)
     (match t
-      [(Function: (list (arr: _ (Values: (list (Result: rngs _ _))) #f _ '()) ...)) (apply Un rngs)]
-      [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)]))
+      [(Function: 
+	(list 
+	 (arr: _ 
+	       (Values: (list (Result: rngs _ _) ...)) 
+	       _ _ (list (Keyword: _ _ #t) ...))))
+       (apply Un rngs)]
+      [_ (int-err "Internal error in get-result-ty: not a function type: ~n~a" t)]))
   (let loop ([form form])
     (parameterize ([current-orig-stx form])
-      (kernel-syntax-case* form #f (#%app)
+      (syntax-parse form
         [stx
          ;; if this needs to be checked
-         (syntax-property form 'typechecker:with-type)
+         #:when (syntax-property form 'typechecker:with-type)
          ;; the form should be already ascribed the relevant type
-         (void 
-          (tc-expr form))]
+	 (tc-expr form)]
         [stx
-         ;; this is a hander function
-         (syntax-property form 'typechecker:exn-handler)
-         (let ([t (tc-expr/t form)])
-           (unless (subtype t (-> (Un) Univ))
-             (tc-error "Exception handler must be a single-argument function, got ~n~a"))
-           (set! handler-tys (cons (get-result-ty t) handler-tys)))]
+         ;; this is a handler function
+         #:when (syntax-property form 'typechecker:exn-handler)
+         (let ([t (tc-expr form)])
+           (match t
+	     [(tc-result1: 
+	       (and t 
+		    (Function: (list (arr: (list _) _ _ _ (list (Keyword: _ _ #f) ...)) ...))))
+	      (set! handler-tys (cons (get-result-ty t) handler-tys))]
+	     [(tc-results: t)
+	      (tc-error "Exception handler must be a single-argument function, got ~n~a" t)]))]
         [stx
          ;; this is the body of the with-handlers
-         (syntax-property form 'typechecker:exn-body)
-         (let ([t (tc-expr/t form)])
-           (set! body-ty t))]
+         #:when (syntax-property form 'typechecker:exn-body)
+         (match-let ([(tc-results: ts) (tc-expr form)])
+           (set! body-ty (-values ts)))]
         [(a . b)
-         (begin
-           (loop #'a)
-           (loop #'b))]
+	 (loop #'a)
+	 (loop #'b)]
         [_ (void)])))
   (ret (apply Un body-ty handler-tys)))
 
diff --git a/collects/typed-scheme/typecheck/internal-forms.ss b/collects/typed-scheme/typecheck/internal-forms.ss
index a0ce6e9c..5c5b6387 100644
--- a/collects/typed-scheme/typecheck/internal-forms.ss
+++ b/collects/typed-scheme/typecheck/internal-forms.ss
@@ -1,16 +1,21 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
+	 syntax/parse)
 
-(define-syntax-rule (internal-forms nms ...)
+(define-syntax-rule (internal-forms set-name nms ...)
   (begin
-    (provide nms ...)
+    (provide nms ... set-name)
+    (define-literal-set set-name (nms ...))
     (define-syntax (nms stx) (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...))
 
-(internal-forms require/typed-internal define-type-alias-internal
-                define-typed-struct-internal
-                define-typed-struct/exec-internal
-                assert-predicate-internal
-                declare-refinement-internal
-                :-internal)
+(internal-forms internal-literals
+ require/typed-internal
+ define-type-alias-internal
+ define-type-internal
+ define-typed-struct-internal
+ define-typed-struct/exec-internal
+ assert-predicate-internal
+ declare-refinement-internal
+ :-internal)
 
diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss
index 99fd72e6..634d1dd9 100644
--- a/collects/typed-scheme/typecheck/tc-structs.ss
+++ b/collects/typed-scheme/typecheck/tc-structs.ss
@@ -90,6 +90,7 @@
                          #:mutable [setters? #f]
                          #:proc-ty [proc-ty #f]
                          #:maker [maker* #f]
+                         #:predicate [pred* #f]
                          #:constructor-return [cret #f]
                          #:poly? [poly? #f]
                          #:type-only [type-only #f])
@@ -107,6 +108,7 @@
                                #:type-wrapper type-wrapper
                                #:pred-wrapper pred-wrapper
                                #:maker (or maker* maker)
+                               #:predicate (or pred* pred)
                                #:constructor-return cret))))
 
 ;; generate names, and register the approriate types give field types and structure type
@@ -117,6 +119,7 @@
                                #:type-wrapper [type-wrapper values]
                                #:pred-wrapper [pred-wrapper values]
                                #:maker [maker* #f]
+                               #:predicate [pred* #f]
                                #:constructor-return [cret #f])
   ;; create the approriate names that define-struct will bind
   (define-values (maker pred getters setters) (struct-names nm flds setters?))
@@ -127,7 +130,7 @@
     (append 
      (list (cons (or maker* maker) 
                  (wrapper (->* external-fld-types (if cret cret name))))
-           (cons pred
+           (cons (or pred* pred)
                  (make-pred-ty (pred-wrapper name))))
      (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
        (let ([func (if setters? 
@@ -185,6 +188,7 @@
 ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
 (define (tc/struct nm/par flds tys [proc-ty #f] 
                    #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
+                   #:predicate [pred #f]
                    #:type-only [type-only #f])
   ;; get the parent info and create some types and type variables
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
@@ -200,6 +204,7 @@
                    ;; procedure
                    #:proc-ty proc-ty-parsed
                    #:maker maker
+                   #:predicate pred
 		   #:constructor-return (and cret (parse-type cret))
                    #:mutable mutable
                    #:type-only type-only))
diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss
index 328123f6..5d0a6532 100644
--- a/collects/typed-scheme/typecheck/tc-toplevel.ss
+++ b/collects/typed-scheme/typecheck/tc-toplevel.ss
@@ -3,11 +3,13 @@
 
 (require (rename-in "../utils/utils.ss" [infer r:infer]))
 (require syntax/kerncase
-	 unstable/list unstable/syntax
+	 unstable/list unstable/syntax syntax/parse
          mzlib/etc
          scheme/match
          "signatures.ss"
          "tc-structs.ss"
+         ;; to appease syntax-parse
+         "internal-forms.ss"
          (rep type-rep)
          (types utils convenience)
          (private parse-type type-annotation type-contract)
@@ -29,13 +31,17 @@
   ;; first, find the mutated variables:
   (find-mutated-vars form)
   (parameterize ([current-orig-stx form])
-    (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal define-type-internal 
-                                   define-typed-struct/exec-internal :-internal assert-predicate-internal
-                                   require/typed-internal values)
+    (syntax-parse form
+      #:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal 
+			 define-typed-struct/exec-internal :-internal assert-predicate-internal
+			 require/typed-internal declare-refinement-internal
+			 define-values quote-syntax #%plain-app begin)
+      ;#:literal-sets (kernel-literals)
+      
       ;; forms that are handled in other ways
       [stx 
-       (or (syntax-property form 'typechecker:ignore) 
-           (syntax-property form 'typechecker:ignore-some))
+       #:when (or (syntax-property form 'typechecker:ignore) 
+                  (syntax-property form 'typechecker:ignore-some))
        (list)]
       
       ;; type aliases have already been handled by an earlier pass
@@ -72,9 +78,16 @@
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]
-      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t)) 
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) 
+                                                #:maker m #:constructor-return t #:predicate p)) 
                                 (#%plain-app values)))
-       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
+		  #:maker #'m #:constructor-return #'t #:predicate #'p)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
+						#:maker m #:constructor-return t)) 
+                                (#%plain-app values)))
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) 
+		  #:maker #'m #:constructor-return #'t)]
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
@@ -91,8 +104,7 @@
        (register-type #'pred (make-pred-ty (parse-type #'ty)))]
       
       ;; top-level type annotation
-      [(define-values () (begin (quote-syntax (:-internal id ty)) (#%plain-app values)))
-       (identifier? #'id)
+      [(define-values () (begin (quote-syntax (:-internal id:identifier ty)) (#%plain-app values)))
        (register-type/undefined #'id (parse-type #'ty))]
             
       
@@ -128,8 +140,7 @@
        (apply append (filter list? (map tc-toplevel/pass1 (syntax->list #'rest))))]
       
       ;; define-syntaxes just get noted
-      [(define-syntaxes (var ...) . rest)
-       (andmap identifier? (syntax->list #'(var ...)))
+      [(define-syntaxes (var:id ...) . rest)
        (map make-def-stx-binding (syntax->list #'(var ...)))]
       
       ;; otherwise, do nothing in this pass
diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss
index 60f996ec..69c990e8 100644
--- a/collects/typed-scheme/utils/tc-utils.ss
+++ b/collects/typed-scheme/utils/tc-utils.ss
@@ -6,7 +6,9 @@ don't depend on any other portion of the system
 |#
 
 (provide (all-defined-out))
-(require "syntax-traversal.ss" syntax/parse (for-syntax scheme/base syntax/parse) scheme/match
+(require "syntax-traversal.ss"
+	 "utils.ss"
+	 syntax/parse (for-syntax scheme/base syntax/parse) scheme/match
          (for-syntax unstable/syntax))
 
 ;; a parameter representing the original location of the syntax being currently checked
@@ -127,11 +129,14 @@ don't depend on any other portion of the system
 (define-struct (exn:fail:tc exn:fail) ())
 
 ;; raise an internal error - typechecker bug!
-(define (int-err msg . args)  
-  (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: "
-                                          (apply format msg args)
-                                          (format "\nwhile typechecking\n~a" (syntax->datum (current-orig-stx))))
-                           (current-continuation-marks))))
+(define (int-err msg . args) 
+  (parameterize ([custom-printer #t])
+    (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: "
+					    (apply format msg args)
+					    (format "\nwhile typechecking\n~aoriginally\n~a"
+						    (syntax->datum (current-orig-stx))
+						    (syntax->datum (locate-stx (current-orig-stx)))))
+			     (current-continuation-marks)))))
 
 (define-syntax (nyi stx)
   (syntax-case stx ()

From 879e22a666af9f26c6f14d9f57ee140668e0e8f6 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 1 Feb 2010 15:51:32 +0000
Subject: [PATCH 5/7] Progress on Rep.

svn: r17924

original commit: 94029a06c9af5dce0e7712cc1cc38e96e8b9b7ca
---
 collects/typed-scheme/rep/free-variance.ss | 12 ++--
 collects/typed-scheme/rep/rep-utils.ss     | 76 ++++++++++------------
 collects/typed-scheme/rep/type-rep.ss      |  2 +-
 collects/typed-scheme/utils/utils.ss       | 15 +++--
 4 files changed, 49 insertions(+), 56 deletions(-)

diff --git a/collects/typed-scheme/rep/free-variance.ss b/collects/typed-scheme/rep/free-variance.ss
index 6b87ae63..7a210bc7 100644
--- a/collects/typed-scheme/rep/free-variance.ss
+++ b/collects/typed-scheme/rep/free-variance.ss
@@ -32,17 +32,17 @@
 
 (define ((input/c tbl) val) (hash-ref tbl val #f))
 
-(define (free-idxs* t)
+#;
+(define (free-idxs* t) #;(Type-free-idxs t)
+  
   (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t))))
-(define (free-vars* t)
+#;
+(define (free-vars* t) #;(Type-free-vars t)
   (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" t))))
 
 (define empty-hash-table (make-immutable-hasheq null))
 
-(p/c [free-vars* (-> (input/c var-table) (hash/c symbol? variance?))]
-     [free-idxs* (-> (input/c index-table) (hash/c exact-nonnegative-integer? variance?))])
-
-(provide empty-hash-table make-invariant)
+(provide empty-hash-table make-invariant input/c variance?)
 
 ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
 ;; (listof frees) -> frees
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index 85a933e6..cf203fc8 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -25,8 +25,12 @@
 
 (provide == defintern hash-id (for-syntax fold-target))
 
+(define-struct Rep (seq
+                    free-vars  
+                    free-idxs))
+
 (define-for-syntax fold-target #'fold-target)
-(define-for-syntax default-fields (list #'seq #;#;#'free-vars #'free-idxs))
+(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs))
 
 (define-for-syntax (mk par ht-stx key?)
   (define-syntax-class opt-cnt-id
@@ -57,10 +61,9 @@
              #:with f2 #'empty-hash-table
              #:with def #'(begin))
     (pattern e:expr
-             #:with id (generate-temporary)
-             #:with def #'(define id e)
-             #:with f1 #'(id free-vars*)
-             #:with f2 #'(id free-idxs*)))
+             #:with def #'(begin)
+             #:with f1 #'(e Rep-free-vars)
+             #:with f2 #'(e Rep-free-idxs)))
   (define-syntax-class (fold-pat fold-name)
     #:transparent
     #:attributes (e proc)
@@ -79,13 +82,13 @@
              #:with ex (format-id #'nm "~a:" #'nm)
              #:with fold (format-id #f "~a-fold" #'nm)
              #:with kw (string->keyword (symbol->string (syntax-e #'nm)))
-             #:with *maker (format-id #'nm "*~a" #'nm)
-             #:with **maker (format-id #'nm "**~a" #'nm)))
+             #:with *maker (format-id #'nm "*~a" #'nm)))
   (lambda (stx)          
     (syntax-parse stx 
       [(dform nm:form-nm flds:idlist (~or 
                                       (~optional (~and (~fail #:unless key? "#:key not allowed")
-                                                       [#:key key-expr:expr]))
+                                                       [#:key key-expr:expr])
+                                                 #:defaults ([key-expr #'#f]))
                                       (~optional [#:intern intern?:expr]
                                                  #:defaults
                                                  ([intern? (syntax-parse #'flds.fs
@@ -95,8 +98,8 @@
                                       (~optional [#:frees frees:frees-pat]
                                                  #:defaults 
                                                  ([frees.def #'(begin)]
-                                                  [frees.f1 (combiner #'free-vars* #'flds.fs)]
-                                                  [frees.f2 (combiner #'free-idxs* #'flds.fs)]))
+                                                  [frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
+                                                  [frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
                                       (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
                                                  #:defaults
                                                  ([fold-rhs.proc
@@ -108,35 +111,13 @@
                                       (~optional no-provide?:no-provide-kw)) ...)
        (with-syntax* 
         ([(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
-         [*maker-cnt (if enable-contracts?
-                         (or (attribute cnt) #'(flds.cnt ... . -> . pred))
-                         #'any/c)]
+         [*maker-cnt (or (attribute cnt) #'(flds.cnt ... . -> . pred))]
          [provides (if (attribute no-provide?)
                        #'(begin)                                 
                        #`(begin 
                            (provide nm.ex pred acc ...)
                            (p/c (rename nm.*maker maker *maker-cnt))))]
-         [intern 
-          (let ([mk (lambda (int) 
-		      (if key? 
-			  #`(defintern (nm.**maker . flds.fs) maker #,int 
-                              #:extra-args #,(attribute key-expr))
-			  #`(defintern (nm.**maker . flds.fs) maker #,int
-                              #:extra-args)))])
-            (mk #'intern?))]
-         [(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))]
-         [frees 
-            (quasisyntax/loc stx
-		(w/c nm ([nm.*maker *maker-cnt])
-                     #,(syntax/loc #'nm
-                         (define (nm.*maker . flds.fs)
-                           (define v (nm.**maker . flds.fs))
-                           frees.def
-                           (unless-in-table 
-                            var-table v
-                            (hash-set! var-table v frees.f1)
-                            (hash-set! index-table v frees.f2))
-                           v))))])
+         [(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))])
         #`(begin
             (define-struct (nm #,par) flds.fs #:inspector #f)
             (define-match-expander nm.ex
@@ -147,10 +128,15 @@
                    (syntax/loc s (struct nm pat))])))
             (begin-for-syntax
               (hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f)))
-            (w/c nm ()
-		 intern
-		 frees)
-	    provides))])))
+            #,(quasisyntax/loc stx
+                (w/c nm ([nm.*maker *maker-cnt])
+                     #,(quasisyntax/loc #'nm
+                         (defintern (nm.*maker . flds.fs) maker intern?
+                           #:extra-args
+                           frees.f1 frees.f2 
+                           #,@(begin                                 
+                                (if key? (list #'key-expr) null))))))
+            provides))])))
 
 (define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
   (lambda (stx)
@@ -214,9 +200,9 @@
     #:transparent
     (pattern [i:id (~optional (~and #:key
                                     (~bind [key? #'#t]
-                                           [(fld-names 1) (append default-fields (list #'key))]))
+                                           [(fld-names 1) (list #'key)]))
                               #:defaults ([key? #'#f]
-                                          [(fld-names 1) default-fields]))
+                                          [(fld-names 1) null]))
                    #:d d-id:id]))
   (define-syntax-class type-name
     #:transparent
@@ -239,7 +225,7 @@
                   (for-syntax i.ht ... i.rec-id ...))
          (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
          (define-for-syntax i.ht (make-hasheq)) ...
-         (define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
+         (define-struct/printer (i.name Rep) (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
          (define-for-syntax i.rec-id #'i.rec-id) ...   
          (provide i.case ...)           
          (define-syntaxes (i.case ...)
@@ -260,4 +246,10 @@
                 [LatentObject #:d dlo]
                 [PathElem #:d dpe])
 
-(provide PathElem?)
\ No newline at end of file
+(provide PathElem? (rename-out [Rep-seq Type-seq]
+                               [Rep-free-vars free-vars*]
+                               [Rep-free-idxs free-idxs*]))
+
+(p/c (struct Rep ([seq integer?] 
+                  [free-vars (hash/c symbol? variance?)] 
+                  [free-idxs (hash/c exact-nonnegative-integer? variance?)])))
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index 5db6f744..f260109e 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -234,7 +234,7 @@
                                          (for/fold ([sorted? #t]
                                                     [last -1])
                                            ([e es])
-                                           (let ([seq (Type-seq e)])
+                                           (let ([seq (Rep-seq e)])
                                              (values
                                               (and sorted?
                                                    (< last seq))
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index 766ba3c2..7706c327 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -150,13 +150,14 @@ at least theoretically.
 (define custom-printer (make-parameter #t))
   
 (define-syntax (define-struct/printer stx)
-  (syntax-case stx ()
-    [(form name (flds ...) printer)
-     #`(define-struct/properties name (flds ...) 
-         #,(if printing?
-               #'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))]) 
-               #'([prop:custom-write pseudo-printer]))
-         #f)]))
+  (syntax-parse stx
+    [(form name (flds ...) printer:expr)
+     #`(define-struct name (flds ...) 
+         #:property prop:custom-write 
+         #,(if printing? 
+               #'(lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))
+               #'pseudo-printer)
+         #:inspector #f)]))
 
 
 ;; turn contracts on and off - off by default for performance.

From cec76e7ad4a778e2f5f2e073fdbc379a8e643285 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 2 Feb 2010 01:24:06 +0000
Subject: [PATCH 6/7] most of the way to real printing

svn: r17935

original commit: 8b120675bc02d0ad4396cc3a5ece7b5b19613972
---
 .../typed-scheme/infer/constraint-structs.ss  |  10 +-
 collects/typed-scheme/infer/infer-unit.ss     |   6 +-
 collects/typed-scheme/rep/filter-rep.ss       |   4 +-
 collects/typed-scheme/rep/free-variance.ss    |  31 +-----
 collects/typed-scheme/rep/interning.ss        |  30 +++--
 collects/typed-scheme/rep/rep-utils.ss        | 105 +++++++++---------
 collects/typed-scheme/rep/type-rep.ss         |   4 +-
 collects/typed-scheme/typecheck/tc-app.ss     |  15 +--
 8 files changed, 98 insertions(+), 107 deletions(-)

diff --git a/collects/typed-scheme/infer/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss
index a676a8fb..1fbf9742 100644
--- a/collects/typed-scheme/infer/constraint-structs.ss
+++ b/collects/typed-scheme/infer/constraint-structs.ss
@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require "../utils/utils.ss" (rep type-rep) scheme/contract)
+(require "../utils/utils.ss" (rep type-rep) scheme/contract scheme/match (for-syntax scheme/base syntax/parse))
 
 ;; S, T types
 ;; X a var
@@ -29,7 +29,13 @@
 ;; don't want to rule them out too early
 (define-struct cset (maps) #:prefab)
 
-(p/c (struct c ([S Type?] [X symbol?] [T Type?]))
+(define-match-expander c:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ s x t)
+       #'(struct c ((app (lambda (v) (if (Type? v) v (Un))) s) x (app (lambda (v) (if (Type? v) v Univ)) t)))])))
+
+(p/c (struct c ([S (or/c boolean? Type?)] [X symbol?] [T (or/c boolean? Type?)]))
      (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
      (struct dcon-exact ([fixed (listof c?)] [rest c?]))
      (struct dcon-dotted ([type c?] [bound symbol?]))
diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss
index eb2ce093..fa4d5267 100644
--- a/collects/typed-scheme/infer/infer-unit.ss
+++ b/collects/typed-scheme/infer/infer-unit.ss
@@ -428,7 +428,7 @@
     (match v
       [(struct c (S X T))
        (let ([var (hash-ref (free-vars* R) (or variable X) Constant)])
-         ;(printf "variance was: ~a~nR was ~a~nX was ~a~n" var R (or variable X))
+         ;(printf "variance was: ~a~nR was ~a~nX was ~a~nS T ~a ~a~n" var R (or variable X) S T)
          (evcase var 
                  [Constant S]
                  [Covariant S]
@@ -440,7 +440,7 @@
      (check-vars
       must-vars
       (append 
-       (for/list ([(k dc) dm])
+       (for/list ([(k dc) (in-hash dm)])
          (match dc
            [(struct dcon (fixed rest))
             (list k
@@ -452,7 +452,7 @@
                   (for/list ([f fixed])
                     (constraint->type f #:variable k))
                   (constraint->type rest))]))
-       (for/list ([(k v) cmap])
+       (for/list ([(k v) (in-hash cmap)])
          (list k (constraint->type v)))))]))
 
 (define (cgen/list V X S T)
diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss
index 4e60c8a8..1ae4f5ab 100644
--- a/collects/typed-scheme/rep/filter-rep.ss
+++ b/collects/typed-scheme/rep/filter-rep.ss
@@ -50,7 +50,7 @@
                                 [(ormap Bot? t)
                                  (flat-named-contract "t was Bot" (list/c))]
                                 [else (listof Filter/c)])])
-                      ()
+                      (#:syntax [stx #f])
                       [result FilterSet?])])
 
 ;; represents no info about the filters of this expression
@@ -89,7 +89,7 @@
                                 [(ormap LBot? t)
                                  (flat-named-contract "t was LBot" (list/c))]
                                 [else (listof LatentFilter/c)])])
-                      ()
+                      (#:syntax [stx #f])
                       [result LFilterSet?])])
 
 (define FilterSet/c
diff --git a/collects/typed-scheme/rep/free-variance.ss b/collects/typed-scheme/rep/free-variance.ss
index 7a210bc7..c42f9c6b 100644
--- a/collects/typed-scheme/rep/free-variance.ss
+++ b/collects/typed-scheme/rep/free-variance.ss
@@ -4,9 +4,12 @@
          (utils tc-utils) scheme/list
          mzlib/etc scheme/contract)
 
+(provide Covariant Contravariant Invariant Constant Dotted
+         combine-frees flip-variances without-below unless-in-table empty-hash-table
+         fix-bound make-invariant variance?)
+
 ;; this file contains support for calculating the free variables/indexes of types
 ;; actual computation is done in rep-utils.ss  and type-rep.ss
-
 (define-values (Covariant Contravariant Invariant Constant Dotted)
   (let ()
     (define-struct Variance () #:inspector #f)
@@ -19,31 +22,11 @@
     (values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
 
 
-(provide Covariant Contravariant Invariant Constant Dotted)
-
 (define (variance? e)
   (memq e (list Covariant Contravariant Invariant Constant Dotted)))
 
-;; hashtables for keeping track of free variables and indexes
-(define index-table (make-weak-hash))
-;; maps Type to List[Cons[Number,Variance]]
-(define var-table (make-weak-hash))
-;; maps Type to List[Cons[Symbol,Variance]]
-
-(define ((input/c tbl) val) (hash-ref tbl val #f))
-
-#;
-(define (free-idxs* t) #;(Type-free-idxs t)
-  
-  (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t))))
-#;
-(define (free-vars* t) #;(Type-free-vars t)
-  (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" t))))
-
 (define empty-hash-table (make-immutable-hasheq null))
 
-(provide empty-hash-table make-invariant input/c variance?)
-
 ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
 ;; (listof frees) -> frees
 (define (combine-frees freess)    
@@ -78,8 +61,7 @@
 (define (flip-variances vs)
   (hash-map* 
    (lambda (k v) 
-     (evcase 
-         v
+     (evcase v
        [Covariant Contravariant]
        [Contravariant Covariant]
        [v v]))
@@ -102,9 +84,6 @@
        (when (>= k n) (hash-set! new-ht k v)))
   new-ht)
 
-(provide combine-frees flip-variances without-below unless-in-table var-table index-table empty-hash-table
-         fix-bound)
-
 (define-syntax (unless-in-table stx) 
   (syntax-case stx ()
     [(_ table val . body)
diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss
index c09160e7..4a44449d 100644
--- a/collects/typed-scheme/rep/interning.ss
+++ b/collects/typed-scheme/rep/interning.ss
@@ -5,19 +5,27 @@
 (provide defintern hash-id)
 
 (define-syntax (defintern stx)
+  (define-splicing-syntax-class extra-kw-spec
+    (pattern (~seq kw:keyword [name:id default:expr])
+             #:with formal #'(kw [name default])))
+  (define-splicing-syntax-class extra-spec
+    (pattern ek:extra-kw-spec
+             #:with e #'ek.name)
+    (pattern e:expr))
   (syntax-parse stx
-    [(_ name+args make-name key #:extra-args e:expr ...)
+    [(_ name+args make-name key #:extra-args e ...)
      #'(defintern name+args (lambda () (make-hash)) make-name key #:extra-args e ...)]
-    [(_ (*name:id arg:id ...) make-ht make-name key-expr #:extra-args e:expr ...)
-     #'(define *name
-	 (let ([table (make-ht)])
-	   (lambda (arg ...)
-	     (let ([key key-expr])
-	       (hash-ref table key
-			 (lambda ()
-			   (let ([new (make-name (count!) e ... arg ...)])
-			     (hash-set! table key new)
-			     new)))))))]))
+    [(_ (*name:id arg:id ...) make-ht make-name key-expr #:extra-args . (~and ((~seq es:extra-spec) ...) ((~or (~seq ek:extra-kw-spec) e:expr) ...)))
+     (with-syntax ([((extra-formals ...) ...) #'(ek.formal ...)])
+       #'(define *name
+           (let ([table (make-ht)])
+             (lambda (arg ... extra-formals ... ...)
+               (let ([key key-expr])
+                 (hash-ref table key
+                           (lambda ()
+                             (let ([new (make-name (count!) es.e ... arg ...)])
+                               (hash-set! table key new)
+                               new))))))))]))
 
 (define (make-count!)  
   (let ([state 0])
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index cf203fc8..c320d49e 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -25,27 +25,26 @@
 
 (provide == defintern hash-id (for-syntax fold-target))
 
-(define-struct Rep (seq
-                    free-vars  
-                    free-idxs))
+(define-struct Rep (seq free-vars free-idxs stx))
 
 (define-for-syntax fold-target #'fold-target)
-(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs))
+(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs #'stx))
 
 (define-for-syntax (mk par ht-stx key?)
   (define-syntax-class opt-cnt-id
     #:attributes (i cnt)
     (pattern i:id
              #:with cnt #'any/c)
-    (pattern [i:id cnt]))
-  (define-syntax-class no-provide-kw
-    (pattern #:no-provide))
-  (define-syntax-class idlist
-    #:attributes ((i 1) (cnt 1) fs)
+    (pattern [i:id cnt]))  
+  ;; fields
+  (define-syntax-class (idlist name)
+    #:attributes ((i 1) (cnt 1) fs maker pred (acc 1))
     (pattern (oci:opt-cnt-id ...)               
              #:with (i ...) #'(oci.i ...)
              #:with (cnt ...) #'(oci.cnt ...)
-             #:with fs #'(i ...)))
+             #:with fs #'(i ...)
+             #:with (_ maker pred acc ...) (build-struct-names name (syntax->list #'fs) #f #t name)))
+  
   (define (combiner f flds)
     (syntax-parse flds
       [() #'empty-hash-table]
@@ -53,15 +52,12 @@
       [(e ...) #`(combine-frees (list (#,f e) ...))]))
   (define-splicing-syntax-class frees-pat
     #:transparent
-    #:attributes (f1 f2 def)
-    (pattern (~seq f1:expr f2:expr)
-             #:with def #'(begin))
+    #:attributes (f1 f2)
+    (pattern (~seq f1:expr f2:expr))
     (pattern #f
              #:with f1 #'empty-hash-table
-             #:with f2 #'empty-hash-table
-             #:with def #'(begin))
+             #:with f2 #'empty-hash-table)
     (pattern e:expr
-             #:with def #'(begin)
              #:with f1 #'(e Rep-free-vars)
              #:with f2 #'(e Rep-free-idxs)))
   (define-syntax-class (fold-pat fold-name)
@@ -85,39 +81,40 @@
              #:with *maker (format-id #'nm "*~a" #'nm)))
   (lambda (stx)          
     (syntax-parse stx 
-      [(dform nm:form-nm flds:idlist (~or 
-                                      (~optional (~and (~fail #:unless key? "#:key not allowed")
-                                                       [#:key key-expr:expr])
-                                                 #:defaults ([key-expr #'#f]))
-                                      (~optional [#:intern intern?:expr]
-                                                 #:defaults
-                                                 ([intern? (syntax-parse #'flds.fs
-                                                             [() #'#f]
-                                                             [(f) #'f]
-                                                             [(fs ...) #'(list fs ...)])]))
-                                      (~optional [#:frees frees:frees-pat]
-                                                 #:defaults 
-                                                 ([frees.def #'(begin)]
-                                                  [frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
-                                                  [frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
-                                      (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
-                                                 #:defaults
-                                                 ([fold-rhs.proc
-                                                   #'(procedure-rename
-                                                      (lambda () 
-                                                        #`(nm.*maker (#,type-rec-id flds.i) ...))
-                                                      'nm.fold)]))
-                                      (~optional [#:contract cnt:expr])
-                                      (~optional no-provide?:no-provide-kw)) ...)
-       (with-syntax* 
-        ([(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
-         [*maker-cnt (or (attribute cnt) #'(flds.cnt ... . -> . pred))]
+      [(dform nm:form-nm
+              (~var flds (idlist #'nm))
+              (~or 
+               (~optional (~and (~fail #:unless key? "#:key not allowed")
+                                [#:key key-expr:expr])
+                          #:defaults ([key-expr #'#f]))
+               (~optional [#:intern intern?:expr]
+                          #:defaults
+                          ([intern? (syntax-parse #'flds.fs
+                                      [() #'#f]
+                                      [(f) #'f]
+                                      [(fs ...) #'(list fs ...)])]))
+               (~optional [#:frees frees:frees-pat]
+                          #:defaults 
+                          ([frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
+                           [frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
+               (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
+                          #:defaults
+                          ([fold-rhs.proc
+                            #'(procedure-rename
+                               (lambda () 
+                                 #`(nm.*maker (#,type-rec-id flds.i) ...))
+                               'nm.fold)]))
+               (~optional [#:contract cnt:expr]
+                          #:defaults ([cnt #'((flds.cnt ...) (#:syntax (or/c syntax? #f)) . ->* . flds.pred)]))
+               (~optional (~and #:no-provide no-provide?))) ...)
+       (with-syntax
+        ([(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))]
+         ;; has to be down here to refer to #'cnt
          [provides (if (attribute no-provide?)
-                       #'(begin)                                 
-                       #`(begin 
-                           (provide nm.ex pred acc ...)
-                           (p/c (rename nm.*maker maker *maker-cnt))))]
-         [(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))])
+                       #'(begin)
+                       #'(begin 
+                           (provide nm.ex flds.pred flds.acc ...)
+                           (p/c (rename nm.*maker flds.maker cnt))))])
         #`(begin
             (define-struct (nm #,par) flds.fs #:inspector #f)
             (define-match-expander nm.ex
@@ -129,13 +126,12 @@
             (begin-for-syntax
               (hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f)))
             #,(quasisyntax/loc stx
-                (w/c nm ([nm.*maker *maker-cnt])
+                (w/c nm ([nm.*maker cnt])
                      #,(quasisyntax/loc #'nm
-                         (defintern (nm.*maker . flds.fs) maker intern?
+                         (defintern (nm.*maker . flds.fs) flds.maker intern?
                            #:extra-args
-                           frees.f1 frees.f2 
-                           #,@(begin                                 
-                                (if key? (list #'key-expr) null))))))
+                           frees.f1 frees.f2 #:syntax [orig-stx #f] 
+                           #,@(if key? (list #'key-expr) null)))))
             provides))])))
 
 (define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
@@ -252,4 +248,5 @@
 
 (p/c (struct Rep ([seq integer?] 
                   [free-vars (hash/c symbol? variance?)] 
-                  [free-idxs (hash/c exact-nonnegative-integer? variance?)])))
+                  [free-idxs (hash/c exact-nonnegative-integer? variance?)]
+                  [stx (or/c #f syntax?)])))
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index f260109e..a664f847 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -100,7 +100,7 @@
 (dt Poly (n body) #:no-provide 
     [#:contract (->d ([n natural-number/c]
                       [body (scope-depth n)])
-                     ()
+                     (#:syntax [stx (or/c #f syntax?)])
                      [result Poly?])]
     [#:frees (free-vars* body) (without-below n (free-idxs* body))]
     [#:fold-rhs (let ([body* (remove-scopes n body)])
@@ -113,7 +113,7 @@
 (dt PolyDots (n body) #:no-provide
     [#:contract (->d ([n natural-number/c]
                       [body (scope-depth n)])
-                     ()
+                     (#:syntax [stx (or/c #f syntax?)])
                      [result PolyDots?])]
     [#:key (Type-key body)]
     [#:frees (free-vars* body) (without-below n (free-idxs* body))]
diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss
index 6dcd92ac..3822b55a 100644
--- a/collects/typed-scheme/typecheck/tc-app.ss
+++ b/collects/typed-scheme/typecheck/tc-app.ss
@@ -511,13 +511,13 @@
     [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...))
      (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
     ;; ormap/andmap of ... argument
-    [(#%plain-app or/andmap:id f arg)
-     #:fail-unless (or (free-identifier=? #'or/andmap #'ormap)
-                       (free-identifier=? #'or/andmap #'andmap)) #f
-     #:fail-unless (with-handlers ([exn:fail? (lambda _ #f)])
-                     (tc/dots #'arg)
-                     #t) #f
-     (let-values ([(ty bound) (tc/dots #'arg)])
+    [(#%plain-app (~or (~literal andmap) (~literal ormap)) f arg)
+     #:attr ty+bound
+     (with-handlers ([exn:fail? (lambda _ #f)])
+       (let-values ([(ty bound) (tc/dots #'arg)])
+         (list ty bound)))
+     #:when (attribute ty+bound)
+     (match-let ([(list ty bound) (attribute ty+bound)])
        (parameterize ([current-tvars (extend-env (list bound)
                                                  (list (make-DottedBoth (make-F bound)))
                                                  (current-tvars))])
@@ -677,6 +677,7 @@
                            (and vars (list fixed-vars ... dotted-var))
                            (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))))
       (list (tc-result1: argtys-t) ...))
+     (printf "poly clause 1~n")
      (handle-clauses (doms rngs rests drests arrs) f-stx args-stx
                      ;; only try inference if the argument lengths are appropriate
                      (lambda (dom _ rest drest a) 

From b1a442d1f0b9fef97cc68336086c5b43689300eb Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 2 Feb 2010 18:09:25 +0000
Subject: [PATCH 7/7] Stop using eq? for types. More contracts. Fix some
 contract errors.

svn: r17943

original commit: 9939f4b6194f61ff1bbed48ef3b36c7dba41363d
---
 collects/typed-scheme/infer/constraints.ss    |  2 +-
 collects/typed-scheme/infer/infer-unit.ss     |  4 +-
 collects/typed-scheme/rep/rep-utils.ss        |  2 +-
 collects/typed-scheme/rep/type-rep.ss         | 49 ++++++++++---------
 .../typecheck/check-subforms-unit.ss          |  4 +-
 collects/typed-scheme/typecheck/tc-app.ss     |  1 -
 .../typecheck/tc-metafunctions.ss             | 13 +++--
 collects/typed-scheme/types/abbrev.ss         |  6 ++-
 collects/typed-scheme/types/subtype.ss        |  2 +-
 collects/typed-scheme/types/union.ss          |  6 ++-
 10 files changed, 49 insertions(+), 40 deletions(-)

diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/infer/constraints.ss
index 54d0495d..b08341d4 100644
--- a/collects/typed-scheme/infer/constraints.ss
+++ b/collects/typed-scheme/infer/constraints.ss
@@ -13,7 +13,7 @@
 
 
 (define-values (fail-sym exn:infer?)
-  (let ([sym (gensym)])
+  (let ([sym (gensym 'infer-fail)])
     (values sym (lambda (s) (eq? s sym)))))
 
 ;; why does this have to be duplicated?
diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss
index fa4d5267..fb1fb4d7 100644
--- a/collects/typed-scheme/infer/infer-unit.ss
+++ b/collects/typed-scheme/infer/infer-unit.ss
@@ -12,7 +12,7 @@
          scheme/match
          mzlib/etc
          mzlib/trace
-	 unstable/sequence unstable/list
+	 unstable/sequence unstable/list unstable/debug
          scheme/list)
 
 (import dmap^ constraints^ promote-demote^)
@@ -254,7 +254,7 @@
     (insert empty X S T))
   (if (seen? S T)
       empty
-      (parameterize ([match-equality-test type-equal?]
+      (parameterize ([match-equality-test (lambda (a b) (if (and (Rep? a) (Rep? b)) (type-equal? a b) (equal? a b)))]
                      [current-seen (remember S T (current-seen))])
         (match* 
             (S T)
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index c320d49e..8721b913 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -246,7 +246,7 @@
                                [Rep-free-vars free-vars*]
                                [Rep-free-idxs free-idxs*]))
 
-(p/c (struct Rep ([seq integer?] 
+(p/c (struct Rep ([seq exact-nonnegative-integer?] 
                   [free-vars (hash/c symbol? variance?)] 
                   [free-idxs (hash/c exact-nonnegative-integer? variance?)]
                   [stx (or/c #f syntax?)])))
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index a664f847..f6d0f86f 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -230,25 +230,24 @@
 ;; elems : Listof[Type]
 (dt Union ([elems (and/c (listof Type/c)                         
                          (lambda (es)
-                           (let-values ([(sorted? k)
-                                         (for/fold ([sorted? #t]
-                                                    [last -1])
-                                           ([e es])
-                                           (let ([seq (Rep-seq e)])
-                                             (values
-                                              (and sorted?
-                                                   (< last seq))
-                                              seq)))])
-                             sorted?)))]) 
+                           (or (null? es)
+                               (let-values ([(sorted? k)
+                                             (for/fold ([sorted? #t]
+                                                        [last (car es)])
+                                               ([e (cdr es)])
+                                               (values
+                                                (and sorted? (type<? last e))
+                                                e))])
+                                 sorted?))))]) 
     [#:frees (combine-frees (map free-vars* elems))
              (combine-frees (map free-idxs* elems))]
     [#:fold-rhs ((get-union-maker) (map type-rec-id elems))]
     [#:key (let loop ([res null] [ts elems])
-	     (if (null? ts) res
-		 (let ([k (Type-key (car ts))])
-		   (cond [(pair? k) (loop (append k res) (cdr ts))]
-			 [k (loop (cons k res) (cdr ts))]
-			 [else #f]))))])
+             (if (null? ts) res
+                 (let ([k (Type-key (car ts))])
+                   (cond [(pair? k) (loop (append k res) (cdr ts))]
+                         [k (loop (cons k res) (cdr ts))]
+                         [else #f]))))])
     
 (dt Univ () [#:frees #f] [#:fold-rhs #:base])
 
@@ -319,7 +318,8 @@
 
 ;; remove-dups: List[Type] -> List[Type]
 ;; removes duplicate types from a SORTED list
-(define (remove-dups types)
+(d/c (remove-dups types)
+  ((listof Rep?) . -> . (listof Rep?))
   (cond [(null? types) types]
         [(null? (cdr types)) types]
         [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))]
@@ -341,15 +341,16 @@
         [_ (int-err "Tried to remove too many scopes: ~a" sc)])))
 
 ;; type equality
-(define type-equal? eq?)
+(d/c (type-equal? s t) (Rep? Rep? . -> . boolean?) (eq? (Rep-seq s) (Rep-seq t)))
 
 ;; inequality - good
+(d/c (type<? s t)
+  (Rep? Rep? . -> . boolean?)
+  (< (Rep-seq s) (Rep-seq t)))
 
-(define (type<? s t)
-  (< (Type-seq s) (Type-seq t)))
-
-(define (type-compare s t)
-  (cond [(eq? s t) 0]
+(d/c (type-compare s t)
+  (Rep? Rep? . -> . (or/c -1 0 1))
+  (cond [(type-equal? s t) 0]
         [(type<? s t) 1]
         [else -1]))
 
@@ -606,7 +607,7 @@
  Poly-n
  PolyDots-n
  free-vars*
- type-equal? type-compare type<?
+ type-compare type<?
  remove-dups
  sub-lf sub-lo sub-pe
  Values: Values? Values-rs
@@ -620,4 +621,6 @@
              [Poly-body* Poly-body]
              [PolyDots-body* PolyDots-body]))
 
+(p/c [type-equal? (Rep? Rep? . -> . boolean?)])
+
 ;(trace unfold)
diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss
index 037822e2..945df04d 100644
--- a/collects/typed-scheme/typecheck/check-subforms-unit.ss
+++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss
@@ -3,7 +3,7 @@
 (require "../utils/utils.ss"
 	 syntax/kerncase
 	 syntax/parse
-         scheme/match
+         scheme/match unstable/debug
          "signatures.ss" "tc-metafunctions.ss"
          (types utils convenience union subtype)
 	 (utils tc-utils)
@@ -14,7 +14,7 @@
 
 ;; find the subexpressions that need to be typechecked in an ignored form
 ;; syntax -> any
-(define (check-subforms/with-handlers form)
+(define (check-subforms/with-handlers form [expected #f])
   (define handler-tys '())
   (define body-ty #f)    
   (define (get-result-ty t)
diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss
index 3822b55a..1548c959 100644
--- a/collects/typed-scheme/typecheck/tc-app.ss
+++ b/collects/typed-scheme/typecheck/tc-app.ss
@@ -677,7 +677,6 @@
                            (and vars (list fixed-vars ... dotted-var))
                            (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))))
       (list (tc-result1: argtys-t) ...))
-     (printf "poly clause 1~n")
      (handle-clauses (doms rngs rests drests arrs) f-stx args-stx
                      ;; only try inference if the argument lengths are appropriate
                      (lambda (dom _ rest drest a) 
diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss
index 2e790129..186c3250 100644
--- a/collects/typed-scheme/typecheck/tc-metafunctions.ss
+++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss
@@ -79,9 +79,12 @@
     [(ImpFilter: as cs)
      (let ([a* (apply append (for/list ([f as]) (abo xs idxs f)))]
            [c* (apply append (for/list ([f cs]) (abo xs idxs f)))])
-       (if (< (length a*) (length as)) ;; if we removed some things, we can't be sure
-           null
-           (list (make-LImpFilter a* c*))))]
+       (cond [(< (length a*) (length as)) ;; if we removed some things, we can't be sure
+              null]
+             [(null? c*) ;; this clause is now useless
+              null]
+             [else
+              (list (make-LImpFilter a* c*))]))]
     [_ null]))
 
 (define (merge-filter-sets fs)
@@ -118,8 +121,8 @@
   (define (idx= lf)
     (match lf
       [(LBot:) #t]
-      [(LNotTypeFilter: _ _ idx*) (type-equal? idx* idx)]
-      [(LTypeFilter: _ _ idx*) (type-equal? idx* idx)]))
+      [(LNotTypeFilter: _ _ idx*) (= idx* idx)]
+      [(LTypeFilter: _ _ idx*) (= idx* idx)]))
   (match lf
     [(LFilterSet: lf+ lf-)
      (make-LFilterSet (filter idx= lf+) (filter idx= lf-))]))
diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss
index 24f3decc..17d64825 100644
--- a/collects/typed-scheme/types/abbrev.ss
+++ b/collects/typed-scheme/types/abbrev.ss
@@ -66,8 +66,10 @@
   (make-Result t f o))
 
 (d/c (-values args)
-     (c:-> (listof Type/c) Values?)
-     (make-Values (for/list ([i args]) (-result i))))
+     (c:-> (listof Type/c) (or/c Type/c Values?))
+     (match args
+       ;[(list t) t]
+       [_ (make-Values (for/list ([i args]) (-result i)))]))
 
 ;; basic types
 
diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss
index 9c53bcb1..bfe2be19 100644
--- a/collects/typed-scheme/types/subtype.ss
+++ b/collects/typed-scheme/types/subtype.ss
@@ -200,7 +200,7 @@
 ;; potentially raises exn:subtype, when the algorithm fails
 ;; is s a subtype of t, taking into account constraints A
 (define (subtype* A s t)
-  (parameterize ([match-equality-test type-equal?]
+  (parameterize ([match-equality-test (lambda (a b) (if (and (Rep? a) (Rep? b)) (type-equal? a b) (equal? a b)))]
                  [current-seen A])
     (let ([ks (Type-key s)] [kt (Type-key t)])
       (cond 
diff --git a/collects/typed-scheme/types/union.ss b/collects/typed-scheme/types/union.ss
index 5019cada..488d715f 100644
--- a/collects/typed-scheme/types/union.ss
+++ b/collects/typed-scheme/types/union.ss
@@ -19,7 +19,9 @@
 (define (flat t)
   (match t
     [(Union: es) es]
-    [_ (list t)]))    
+    [(Values: (list (Result: (Union: es) _ _))) es]
+    [(Values: (list (Result: t _ _))) (list t)]
+    [_ (list t)]))
 
 (define (remove-subtypes ts)
   (let loop ([ts* ts] [result '()])
@@ -44,7 +46,7 @@
        (cond
          [(null? types) (make-union* null)]
          [(null? (cdr types)) (car types)]           
-         [else (make-union* (foldr union2 '() (remove-subtypes types)))]))]))
+         [else (make-union* (sort (foldr union2 '() (remove-subtypes types)) type<?))]))]))
 
 (define (u-maker args) (apply Un args))