From d24a116dcb2ad0dc191bca288e71aea23fd9a229 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 8 Dec 2008 18:24:33 +0000
Subject: [PATCH 1/3] Handle top-arr in infer.  Add convenience binding for
 function top.

svn: r12745

original commit: ea0873adb29728625be95474b79ff75dda6521fd
---
 collects/typed-scheme/infer/infer-unit.ss     | 301 +++++++++---------
 collects/typed-scheme/private/base-env.ss     |   4 +-
 collects/typed-scheme/private/base-types.ss   |   2 +-
 .../private/type-effect-convenience.ss        |   4 +-
 4 files changed, 158 insertions(+), 153 deletions(-)

diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss
index c83e0706..bcfc0e85 100644
--- a/collects/typed-scheme/infer/infer-unit.ss
+++ b/collects/typed-scheme/infer/infer-unit.ss
@@ -251,154 +251,157 @@
       (parameterize ([match-equality-test type-equal?]
                      [current-seen (remember S T (current-seen))])
         (match* 
-         (S T)
-         [(a a) empty]
-         [(_ (Univ:)) empty]
-         
-         [((F: (? (lambda (e) (memq e X)) v)) S)
-          (when (match S
-                  [(F: v*)
-                   (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
-                  [_ #f])
-            (fail! S T))
-          (singleton (Un) v (var-demote S V))]
-         [(S (F: (? (lambda (e) (memq e X)) v)))
-          (when (match S
-                  [(F: v*)
-                   (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
-                  [_ #f])
-            (fail! S T))
-          (singleton (var-promote S V) v Univ)]
-         
-         ;; two unions with the same number of elements, so we just try to unify them pairwise
-         #;[((Union: l1) (Union: l2))
-            (=> unmatch)
-            (unless (= (length l1) (length l2))
-              (unmatch))
-            (cgen-union V X l1 l2)]
-         
-         #;[((Poly: v1 b1) (Poly: v2 b2))
-          (unless (= (length v1) (length v2))
-            (fail! S T))
-          (let ([b2* (subst-all (map list v2 v1) b2)])
-            (cg b1 b2*))]
-         
-         #;[((PolyDots: (list v1 ... r1) b1) (PolyDots: (list v2 ... r2) b2))
-          (unless (= (length v1) (length v2))
-            (fail! S T))
-          (let ([b2* (substitute-dotted v1 v1 v2 (subst-all (map list v2 v1) b2))])
-            (cg b1 b2*))]
-         
-         [((Poly: v1 b1) T)
-          (cgen (append v1 V) X b1 T)]
-
-         #;[((PolyDots: (list v1 ... r1) b1) T)
-          (let ([b1* (var-demote b1 (cons r1 v1))])
-            (cg b1* T))]
-
-         #;
-         [((Poly-unsafe: n b) (Poly-unsafe: n* b*))
-          (unless (= n n*)
-            (fail! S T))
-          (cg b b*)]
-         
-         
-         [((Union: es) S) (cset-meet* (cons empty (for/list ([e es]) (cg e S))))]
-         ;; we might want to use multiple csets here, but I don't think it makes a difference
-         [(S (Union: es)) (or
-                           (for/or 
-                            ([e es]) 
-                            (with-handlers
-                                ([exn:infer? (lambda _ #f)])
-                              (cg S e)))
-                           (fail! S T))]
-         
-         [((Struct: nm p flds proc _ _ _) (Struct: nm p flds* proc* _ _ _))
-          (let-values ([(flds flds*)
-                        (cond [(and proc proc*)
-                               (values (cons proc flds) (cons proc* flds*))]
-                              [(or proc proc*)
-                               (fail! S T)]
-                              [else (values flds flds*)])])
-            (cgen/list V X flds flds*))]
-         [((Name: n) (Name: n*))
-          (if (free-identifier=? n n*)
-              null
-              (fail! S T))]
-         [((Pair: a b) (Pair: a* b*))
-          (cset-meet (cg a a*) (cg b b*))]
-         ;; if we have two mu's, we rename them to have the same variable
-         ;; and then compare the bodies
-         [((Mu-unsafe: s) (Mu-unsafe: t)) 
-          (cg s t)]
-         ;; other mu's just get unfolded
-         [(s (? Mu? t)) (cg s (unfold t))]
-         [((? Mu? s) t) (cg (unfold s) t)]
-         ;; type application          
-         [((App: (Name: n) args _)
-           (App: (Name: n*) args* _))
-          (unless (free-identifier=? n n*)
-            (fail! S T))
-          (let ([x (instantiate-poly (lookup-type-name n) args)]
-                [y (instantiate-poly (lookup-type-name n) args*)])
-            (cg x y))]
-         [((Values: ss) (Values: ts))
-          (unless (= (length ss) (length ts))
-            (fail! ss ts))
-          (cgen/list V X ss ts)]
-         [((Values: ss) (ValuesDots: ts t-dty dbound))
-          (unless (>= (length ss) (length ts))
-            (fail! ss ts))
-          (unless (memq dbound X)
-            (fail! S T))
-          (let* ([num-vars (- (length ss) (length ts))]
-                 [vars     (for/list ([n (in-range num-vars)])
-                                     (gensym dbound))]
-                 [new-tys  (for/list ([var vars])
-                                     (substitute (make-F var) dbound t-dty))]
-                 [new-cset (cgen/list V (append vars X) ss (append ts new-tys))])
-            (move-vars-to-dmap new-cset dbound vars))]
-         [((ValuesDots: ss s-dty dbound) (Values: ts))
-          (unless (>= (length ts) (length ss))
-            (fail! ss ts))
-          (unless (memq dbound X)
-            (fail! S T))
-          (let* ([num-vars (- (length ts) (length ss))]
-                 [vars     (for/list ([n (in-range num-vars)])
-                                     (gensym dbound))]
-                 [new-tys  (for/list ([var vars])
-                                     (substitute (make-F var) dbound s-dty))]
-                 [new-cset (cgen/list V (append vars X) (append ss new-tys) ts)])
-            (move-vars-to-dmap new-cset dbound vars))]
-         [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound))
-          (when (memq dbound X) (fail! ss ts))          
-          (cgen/list V X (cons s-dty ss) (cons t-dty ts))]
-         [((Vector: e) (Vector: e*))
-          (cset-meet (cg e e*) (cg e* e))]
-         [((Box: e) (Box: e*))
-          (cset-meet (cg e e*) (cg e* e))]
-         [((Hashtable: s1 s2) (Hashtable: t1 t2))
-          ;; the key is covariant, the value is invariant
-          (cset-meet* (list (cg s1 t1) (cg t2 s2) (cg s2 t2)))]
-         [((Syntax: s1) (Syntax: s2))
-          (cg s1 s2)]
-         ;; parameters are just like one-arg functions
-         [((Param: in1 out1) (Param: in2 out2))
-          (cset-meet (cg in2 in1) (cg out1 out2))]
-         [((Function: (list t-arr ...))
-           (Function: (list s-arr ...)))
-          (=> unmatch)
-          (cset-combine
-           (filter 
-            values ;; only generate the successful csets
-            (for*/list 
-             ([t-arr t-arr] [s-arr s-arr])
-             (with-handlers ([exn:infer? (lambda (_) #f)])
-               (cgen/arr V X t-arr s-arr)))))]
-         [(_ _)
-          (cond [(subtype S T) empty]
-                ;; or, nothing worked, and we fail
-                [else (fail! S T)])]))))
+            (S T)
+          [(a a) empty]
+          [(_ (Univ:)) empty]
+          
+          [((F: (? (lambda (e) (memq e X)) v)) S)
+           (when (match S
+                   [(F: v*)
+                    (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
+                   [_ #f])
+             (fail! S T))
+           (singleton (Un) v (var-demote S V))]
+          [(S (F: (? (lambda (e) (memq e X)) v)))
+           (when (match S
+                   [(F: v*)
+                    (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))]
+                   [_ #f])
+             (fail! S T))
+           (singleton (var-promote S V) v Univ)]
+          
+          ;; two unions with the same number of elements, so we just try to unify them pairwise
+          #;[((Union: l1) (Union: l2))
+             (=> unmatch)
+             (unless (= (length l1) (length l2))
+               (unmatch))
+             (cgen-union V X l1 l2)]
+          
+          #;[((Poly: v1 b1) (Poly: v2 b2))
+             (unless (= (length v1) (length v2))
+               (fail! S T))
+             (let ([b2* (subst-all (map list v2 v1) b2)])
+               (cg b1 b2*))]
+          
+          #;[((PolyDots: (list v1 ... r1) b1) (PolyDots: (list v2 ... r2) b2))
+             (unless (= (length v1) (length v2))
+               (fail! S T))
+             (let ([b2* (substitute-dotted v1 v1 v2 (subst-all (map list v2 v1) b2))])
+               (cg b1 b2*))]
+          
+          [((Poly: v1 b1) T)
+           (cgen (append v1 V) X b1 T)]
+          
+          #;[((PolyDots: (list v1 ... r1) b1) T)
+             (let ([b1* (var-demote b1 (cons r1 v1))])
+               (cg b1* T))]
+          
+          #;
+          [((Poly-unsafe: n b) (Poly-unsafe: n* b*))
+           (unless (= n n*)
+             (fail! S T))
+           (cg b b*)]
+          
+          
+          [((Union: es) S) (cset-meet* (cons empty (for/list ([e es]) (cg e S))))]
+          ;; we might want to use multiple csets here, but I don't think it makes a difference
+          [(S (Union: es)) (or
+                            (for/or 
+                             ([e es]) 
+                             (with-handlers
+                                 ([exn:infer? (lambda _ #f)])
+                               (cg S e)))
+                            (fail! S T))]
+          
+          [((Struct: nm p flds proc _ _ _) (Struct: nm p flds* proc* _ _ _))
+           (let-values ([(flds flds*)
+                         (cond [(and proc proc*)
+                                (values (cons proc flds) (cons proc* flds*))]
+                               [(or proc proc*)
+                                (fail! S T)]
+                               [else (values flds flds*)])])
+             (cgen/list V X flds flds*))]
+          [((Name: n) (Name: n*))
+           (if (free-identifier=? n n*)
+               null
+               (fail! S T))]
+          [((Pair: a b) (Pair: a* b*))
+           (cset-meet (cg a a*) (cg b b*))]
+          ;; if we have two mu's, we rename them to have the same variable
+          ;; and then compare the bodies
+          [((Mu-unsafe: s) (Mu-unsafe: t)) 
+           (cg s t)]
+          ;; other mu's just get unfolded
+          [(s (? Mu? t)) (cg s (unfold t))]
+          [((? Mu? s) t) (cg (unfold s) t)]
+          ;; type application          
+          [((App: (Name: n) args _)
+            (App: (Name: n*) args* _))
+           (unless (free-identifier=? n n*)
+             (fail! S T))
+           (let ([x (instantiate-poly (lookup-type-name n) args)]
+                 [y (instantiate-poly (lookup-type-name n) args*)])
+             (cg x y))]
+          [((Values: ss) (Values: ts))
+           (unless (= (length ss) (length ts))
+             (fail! ss ts))
+           (cgen/list V X ss ts)]
+          [((Values: ss) (ValuesDots: ts t-dty dbound))
+           (unless (>= (length ss) (length ts))
+             (fail! ss ts))
+           (unless (memq dbound X)
+             (fail! S T))
+           (let* ([num-vars (- (length ss) (length ts))]
+                  [vars     (for/list ([n (in-range num-vars)])
+                              (gensym dbound))]
+                  [new-tys  (for/list ([var vars])
+                              (substitute (make-F var) dbound t-dty))]
+                  [new-cset (cgen/list V (append vars X) ss (append ts new-tys))])
+             (move-vars-to-dmap new-cset dbound vars))]
+          [((ValuesDots: ss s-dty dbound) (Values: ts))
+           (unless (>= (length ts) (length ss))
+             (fail! ss ts))
+           (unless (memq dbound X)
+             (fail! S T))
+           (let* ([num-vars (- (length ts) (length ss))]
+                  [vars     (for/list ([n (in-range num-vars)])
+                              (gensym dbound))]
+                  [new-tys  (for/list ([var vars])
+                              (substitute (make-F var) dbound s-dty))]
+                  [new-cset (cgen/list V (append vars X) (append ss new-tys) ts)])
+             (move-vars-to-dmap new-cset dbound vars))]
+          [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound))
+           (when (memq dbound X) (fail! ss ts))          
+           (cgen/list V X (cons s-dty ss) (cons t-dty ts))]
+          [((Vector: e) (Vector: e*))
+           (cset-meet (cg e e*) (cg e* e))]
+          [((Box: e) (Box: e*))
+           (cset-meet (cg e e*) (cg e* e))]
+          [((Hashtable: s1 s2) (Hashtable: t1 t2))
+           ;; the key is covariant, the value is invariant
+           (cset-meet* (list (cg s1 t1) (cg t2 s2) (cg s2 t2)))]
+          [((Syntax: s1) (Syntax: s2))
+           (cg s1 s2)]
+          ;; parameters are just like one-arg functions
+          [((Param: in1 out1) (Param: in2 out2))
+           (cset-meet (cg in2 in1) (cg out1 out2))]
+          [((Function: _)
+            (Function: (list (top-arr:))))
+           empty]
+          [((Function: (list t-arr ...))
+            (Function: (list s-arr ...)))
+           (=> unmatch)
+           (cset-combine
+            (filter 
+             values ;; only generate the successful csets
+             (for*/list 
+              ([t-arr t-arr] [s-arr s-arr])
+              (with-handlers ([exn:infer? (lambda (_) #f)])
+                (cgen/arr V X t-arr s-arr)))))]
+          [(_ _)
+           (cond [(subtype S T) empty]
+                 ;; or, nothing worked, and we fail
+                 [else (fail! S T)])]))))
 
 (define (check-vars must-vars subst)
   (and (for/and ([v must-vars])
@@ -488,4 +491,4 @@
 (define (i s t r)
   (infer/simple (list s) (list t) r))
 
-;(trace cgen/arr #;cgen #;cgen/list)
+;(trace cgen)
diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index f09bfea2..aaad95ba 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -90,7 +90,7 @@
 [symbol? (make-pred-ty Sym)]
 [list? (make-pred-ty (-lst Univ))]
 [list (-poly (a) (->* '() a (-lst a)))]
-[procedure? (make-pred-ty (make-Function (list (make-top-arr))))]
+[procedure? (make-pred-ty top-func)]
 [map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a))
                          ((-lst b) b) . ->... .(-lst c)))]
 [for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a))
@@ -561,4 +561,4 @@
 ;; string.ss
 [real->decimal-string (N [-Nat] . ->opt .  -String)]
 
-[current-continuation-marks (-> -Cont-Mark-Set)]
\ No newline at end of file
+[current-continuation-marks (-> -Cont-Mark-Set)]
diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss
index 28c595e9..296bd88f 100644
--- a/collects/typed-scheme/private/base-types.ss
+++ b/collects/typed-scheme/private/base-types.ss
@@ -27,5 +27,5 @@
 [Boxof (-poly (a) (make-Box a))]
 [Syntax Any-Syntax]
 [Identifier Ident]
-[Procedure (make-Function (list (make-top-arr)))]
+[Procedure top-func]
 
diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss
index 699e966b..49f21dd8 100644
--- a/collects/typed-scheme/private/type-effect-convenience.ss
+++ b/collects/typed-scheme/private/type-effect-convenience.ss
@@ -17,11 +17,13 @@
 
 (provide (all-defined-out) 
          ;; these should all eventually go away
-         make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect)
+         make-Name make-ValuesDots make-Function make-Latent-Restrict-Effect make-Latent-Remove-Effect)
 
 (define (one-of/c . args)
   (apply Un (map -val args)))
 
+(define top-func (make-Function (list (make-top-arr))))
+
 (define (-vet id) (make-Var-True-Effect id))
 (define (-vef id) (make-Var-False-Effect id))
 

From 53a5f53d153dd1e39552a44e59e11ed151d6d7bc Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 8 Dec 2008 18:26:58 +0000
Subject: [PATCH 2/3] Make inference work in subtype tests. Add test for
 top-arr.

svn: r12746

original commit: 08fa300d14085b678a0d0fd357613649e2e459b9
---
 collects/tests/typed-scheme/unit-tests/subtype-tests.ss | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss
index adba6e63..9c3c7d34 100644
--- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss
+++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss
@@ -23,6 +23,8 @@
 			      (begin (test-suite "Tests for subtyping"
 						 new-cl ...))))]))
 
+(infer-param infer)
+
 (define (subtype-tests)
   (subtyping-tests
    ;; trivial examples
@@ -121,6 +123,8 @@
 
    (FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b)))
    
+   ;; polymorphic function types should be subtypes of the function top
+   [(-poly (a) (a . -> . a)) top-func]   
    ))
 
 (define-go 

From 59481295ef73ea5b893bf29bb756ceb68ea50b35 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 8 Dec 2008 20:48:25 +0000
Subject: [PATCH 3/3] Update typed collection to use struct inheritance.

svn: r12747

original commit: da7b6978eefdc1d476361cb56cbf577dbf32c825
---
 collects/typed/net/cgi.ss       |  8 +++--
 collects/typed/net/cookie.ss    |  2 +-
 collects/typed/net/mime.ss      | 55 +++++++++++++-----------------
 collects/typed/net/nntp.ss      | 34 +++++++++----------
 collects/typed/net/pop3.ss      | 60 ++++++++++++++++++---------------
 collects/typed/net/url.ss       | 27 +++++++--------
 collects/typed/private/utils.ss | 11 +++++-
 7 files changed, 102 insertions(+), 95 deletions(-)

diff --git a/collects/typed/net/cgi.ss b/collects/typed/net/cgi.ss
index 7287e6f0..65aac77c 100644
--- a/collects/typed/net/cgi.ss
+++ b/collects/typed/net/cgi.ss
@@ -3,13 +3,14 @@
 (require typed/private/utils)
 
 (require-typed-struct cgi-error () net/cgi)
-(require-typed-struct incomplete-%-suffix  ([chars : (Listof Char)]) net/cgi) 
-(require-typed-struct invalid-%-suffix  ([char : Char]) net/cgi)
+(require-typed-struct (incomplete-%-suffix cgi-error)  ([chars : (Listof Char)]) net/cgi) 
+(require-typed-struct (invalid-%-suffix cgi-error)  ([char : Char]) net/cgi)
   
+
 (require/typed/provide net/cgi
   [get-bindings (-> (Listof (cons (U Symbol String) String)))]
   [get-bindings/post (-> (Listof (Pair (U Symbol String) String)))]
-  [get-bindings/get (-> (Listof (Pair (U Symbol String) String)) )]
+  [get-bindings/get (-> (Listof (Pair (U Symbol String) String)))]
   [output-http-headers (-> Void)]
   [generate-html-output (case-lambda (String (Listof String) -> Void) 
 				     (String (Listof String) String String String String String -> Void))]
@@ -21,6 +22,7 @@
   [string->html (String -> String)]
   [generate-link-text (String String -> String)])
 
+
 (provide
  (struct-out cgi-error)
  (struct-out incomplete-%-suffix)
diff --git a/collects/typed/net/cookie.ss b/collects/typed/net/cookie.ss
index f2ff6022..391463b9 100644
--- a/collects/typed/net/cookie.ss
+++ b/collects/typed/net/cookie.ss
@@ -18,6 +18,6 @@
   [get-cookie (String String -> (Listof String))]
   [get-cookie/single (String String -> (Option String))])
 
-(require-typed-struct  cookie-error () net/cookie)
+(require-typed-struct (cookie-error exn:fail) () net/cookie)
 
 (provide Cookie cookie? (struct-out cookie-error))
\ No newline at end of file
diff --git a/collects/typed/net/mime.ss b/collects/typed/net/mime.ss
index 167f0003..5a9b3f7b 100644
--- a/collects/typed/net/mime.ss
+++ b/collects/typed/net/mime.ss
@@ -30,42 +30,35 @@
 
 
 ;; -- exceptions raised --
-(require/typed mime-error? (Any -> Boolean : (Opaque mime-error?)) net/mime)
-(require/typed unexpected-termination? (Any -> Boolean :(Opaque unexpected-termination?)) net/mime)
-(require/typed unexpected-termination-msg ((Opaque unexpected-termination?) -> message) net/mime)
-(require/typed missing-multipart-boundary-parameter? (Any -> Boolean : (Opaque missing-multipart-boundary-parameter?)) net/mime)
-(require/typed malformed-multipart-entity? (Any -> Boolean : (Opaque malformed-multipart-entity?)) net/mime)
-(require/typed malformed-multipart-entity-msg ((Opaque malformed-multipart-entity?)-> message) net/mime)
-(require/typed empty-mechanism? (Any -> Boolean : (Opaque empty-mechanism?)) net/mime)
-(require/typed empty-type? (Any -> Boolean : (Opaque empty-type?)) net/mime)
-(require/typed empty-subtype? (Any -> Boolean : (Opaque empty-subtype?)) net/mime)
-(require/typed empty-disposition-type? (Any -> Boolean : (Opaque empty-disposition-type?)) net/mime)
-
+#|
+(require-typed-struct mime-error () net/mime)
+(require-typed-struct (unexpected-termination mime-error) ([msg : String]) net/mime)
+(require-typed-struct (missing-multipart-boundary-parameter mime-error) () net/mime)
+(require-typed-struct (malformed-multipart-entity mime-error) ([msg : String]) net/mime)
+(require-typed-struct (empty-mechanism mime-error) () net/mime)
+(require-typed-struct (empty-type mime-error) () net/mime)
+(require-typed-struct (empty-subtype mime-error) () net/mime)
+(require-typed-struct (empty-disposition-type mime-error) () net/mime)
+|#
 
 ;; -- mime methods --
 (require/typed/provide net/mime
   [mime-analyze ((U Bytes Input-Port) Any -> message)])
 
 (provide
- ;; -- exceptions raised --
- mime-error? 
- unexpected-termination? 
- unexpected-termination-msg
- missing-multipart-boundary-parameter? 
- malformed-multipart-entity?
- malformed-multipart-entity-msg
- empty-mechanism? 
- empty-type? 
- empty-subtype?
- empty-disposition-type? 
- 
  ;; -- basic mime structures --
- message 
- entity
- 
- disposition
- 
- ;; -- mime methods --
- mime-analyze
-)
+ (struct-out message)
+ (struct-out entity) 
+ (struct-out disposition)
+ #|
+ (struct-out mime-error)
+ (struct-out unexpected-termination)
+ (struct-out missing-multipart-boundary)
+ (struct-out malformed-multipart-entity)
+ (struct-out empty-mechanism)
+ (struct-out empty-type)
+ (struct-out empty-subtype)
+ (struct-out empty-disposition-type)
+|#
+ )
 
diff --git a/collects/typed/net/nntp.ss b/collects/typed/net/nntp.ss
index 04468077..b66b7a53 100644
--- a/collects/typed/net/nntp.ss
+++ b/collects/typed/net/nntp.ss
@@ -2,8 +2,9 @@
   
 (require typed/private/utils)
 
-(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
-		      net/nntp)
+(require-typed-struct/provide
+ communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
+ net/nntp)
 
 (require/typed/provide net/nntp  
   [connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))]
@@ -14,18 +15,17 @@
   [body-of-message (communicator Number -> (Listof String))]
   [newnews-since  (communicator Number -> (Listof String))]
   [generic-message-command (communicator Number -> (Listof String))]
-  [make-desired-header  (String -> String)] ;;-> Regexp
-  [extract-desired-headers ((Listof String) (Listof String) -> (Listof String))]) ;;2nd: Of Regexp
-#|
-;; requires structure inheritance
-(require-typed-struct nntp ()]
-(require-typed-struct unexpected-response ([code : Number] [text : String])]
-(require-typed-struct bad-status-line ([line : String])]
-(require-typed-struct premature-close ([communicator : communicator])]
-(require-typed-struct bad-newsgroup-line ([line : String])]
-(require-typed-struct non-existent-group ([group : String])]
-(require-typed-struct article-not-in-group ([article : Number])]
-(require-typed-struct no-group-selected ()]
-(require-typed-struct article-not-found ([article : Number])]
-(require-typed-struct authentication-rejected ()]
-|#
+  [make-desired-header  (String -> String)]
+  [extract-desired-headers ((Listof String) (Listof String) -> (Listof String))])
+
+(require-typed-struct/provide (nntp exn:fail) () net/nntp)
+(require-typed-struct/provide (unexpected-response nntp) ([code : Number] [text : String]) net/nntp)
+(require-typed-struct/provide (bad-status-line nntp) ([line : String]) net/nntp)
+(require-typed-struct/provide (premature-close nntp) ([communicator : communicator]) net/nntp)
+(require-typed-struct/provide (bad-newsgroup-line nntp) ([line : String]) net/nntp)
+(require-typed-struct/provide (non-existent-group nntp) ([group : String]) net/nntp)
+(require-typed-struct/provide (article-not-in-group nntp) ([article : Number]) net/nntp)
+(require-typed-struct/provide (no-group-selected nntp) () net/nntp)
+(require-typed-struct/provide (article-not-found nntp) ([article : Number]) net/nntp)
+(require-typed-struct/provide (authentication-rejected nntp) () net/nntp)
+
diff --git a/collects/typed/net/pop3.ss b/collects/typed/net/pop3.ss
index 8ecaa8f5..ddc23237 100644
--- a/collects/typed/net/pop3.ss
+++ b/collects/typed/net/pop3.ss
@@ -2,37 +2,43 @@
 
 (require typed/private/utils)
 
-(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])net/pop3)
+(require-typed-struct/provide communicator
+			      ([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])
+			      net/pop3)
 
 (require/typed/provide net/pop3
-  [connect-to-server ( case-lambda (String -> (Opaque communicator?)) (String Number -> (Opaque communicator?)) )] 
+  [connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))] 
 
-  [disconnect-from-server ( (Opaque communicator?) -> Void )]
-  [authenticate/plain-text ( String String (Opaque communicator?) -> Void )]
-  [get-mailbox-status ( (Opaque communicator?) -> (values Number Number) )]
-  [get-message/complete  ( (Opaque communicator?) Number -> (values (Listof String)(Listof String)) )]
-  [get-message/headers  ( (Opaque communicator?) Number -> (Listof String) )]
-  [get-message/body ( (Opaque communicator?) Number -> (Listof String) )]
-  [delete-message ( (Opaque communicator?) Number -> Void )]
-  [get-unique-id/single  ( (Opaque communicator?) Number -> String )]
-  [get-unique-id/all ( (Opaque communicator?) -> (Listof (cons Number String)) )]
+  [disconnect-from-server (communicator -> Void)]
+  [authenticate/plain-text (String String communicator -> Void)]
+  [get-mailbox-status (communicator -> (values Number Number))]
+  [get-message/complete  (communicator Number -> (values (Listof String)(Listof String)))]
+  [get-message/headers  (communicator Number -> (Listof String))]
+  [get-message/body (communicator Number -> (Listof String))]
+  [delete-message (communicator Number -> Void)]
+  [get-unique-id/single  (communicator Number -> String)]
+  [get-unique-id/all (communicator -> (Listof (cons Number String)))]
   
-  [make-desired-header  ( String -> String )];-> Regexp
-  [extract-desired-headers ( (Listof String)(Listof String)-> (Listof String) )];2nd:of Regexp
-  )
-(provide (struct-out communicator))
+  [make-desired-header  (String -> String)]
+  [extract-desired-headers ((Listof String)(Listof String)-> (Listof String))])
+ 
+
+(require-typed-struct/provide (pop3 exn) () net/pop3)
+(require-typed-struct/provide (cannot-connect pop3) () net/pop3)
+(require-typed-struct/provide (username-rejected pop3) () net/pop3)
+(require-typed-struct/provide (password-rejected pop3) () net/pop3)
+(require-typed-struct/provide (not-ready-for-transaction pop3) 
+			      ([communicator : communicator]) net/pop3) 
+(require-typed-struct/provide (not-given-headers pop3)
+			      ([communicator : communicator] [message : Integer]) net/pop3)
+(require-typed-struct/provide (illegal-message-number pop3)
+			      ([communicator : communicator] [message : Integer]) net/pop3)
+(require-typed-struct/provide (cannot-delete-message pop3)
+			      ([communicator : communicator] [message : Integer]) net/pop3) 
+(require-typed-struct/provide (disconnect-not-quiet pop3)
+			      ([communicator : communicator]) net/pop3)
+(require-typed-struct/provide (malformed-server-response pop3) 
+			      ([communicator : communicator]) net/pop3) 
 
-#|
-(require-typed-struct pop3 ()]
-(require-typed-struct cannot-connect ()]
-(require-typed-struct username-rejected ()]
-(require-typed-struct password-rejected ()]
-(require-typed-struct not-ready-for-transaction ([ communicator : (Opaque communicator?) ])net/pop3) 
-(require-typed-struct not-given-headers ([ communicator : (Opaque communicator?) ] [message : String])]
-(require-typed-struct illegal-message-number ([communicator : (Opaque communicator?)] [message : String])]
-(require-typed-struct cannot-delete-message ([communicator : (Opaque communicator?)] [message : String])] 
-(require-typed-struct disconnect-not-quiet ([communicator : (Opaque communicator?)])]
-(require-typed-struct malformed-server-response ([communicator : (Opaque communicator?)])net/pop3) 
-|#
 
   
\ No newline at end of file
diff --git a/collects/typed/net/url.ss b/collects/typed/net/url.ss
index 86add4fe..b9623196 100644
--- a/collects/typed/net/url.ss
+++ b/collects/typed/net/url.ss
@@ -2,19 +2,21 @@
 
 (require typed/private/utils)
 
-(require-typed-struct path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url)
+(require-typed-struct/provide path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url)
 
-(require-typed-struct url ([scheme : (Option String)]
-                           [user : (Option String)]
-                           [host : (Option String)]
-                           [port : (Option Integer)]
-                           [path-absolute? : Boolean]
-                           [path : (Listof path/param)] 
-                           [query : (Listof (Pair Symbol (Option String)))]
-                           [fragment : (Option String)])
-                      net/url)
+(require-typed-struct/provide
+ url ([scheme : (Option String)]
+      [user : (Option String)]
+      [host : (Option String)]
+      [port : (Option Integer)]
+      [path-absolute? : Boolean]
+      [path : (Listof path/param)] 
+      [query : (Listof (Pair Symbol (Option String)))]
+      [fragment : (Option String)])
+ net/url)
 
 (require/opaque-type URL-Exception url-exception? net/url)
+(provide URL-Exception url-exception?)   
 
 (define-type-alias PortT (case-lambda (url -> Input-Port) (url (Listof String)-> Input-Port)))
 (define-type-alias PortT/String (case-lambda (url String -> Input-Port) (url String (Listof String)-> Input-Port)))
@@ -52,8 +54,3 @@
   [url->string (url -> String)]
   [combine-url/relative (url String -> url)])
 
-(provide
- URL-Exception
- url-exception?
- (struct-out url)
- (struct-out path/param))   
diff --git a/collects/typed/private/utils.ss b/collects/typed/private/utils.ss
index c1fdbea7..5abf5a87 100644
--- a/collects/typed/private/utils.ss
+++ b/collects/typed/private/utils.ss
@@ -8,4 +8,13 @@
     (require/typed lib [nm t] ...)
     (provide nm ...)))
 
-(provide dt require/typed/provide)
+(define-syntax require-typed-struct/provide
+  (syntax-rules ()
+    [(_ (nm par) . rest)
+     (begin (require-typed-struct (nm par) . rest)
+            (provide (struct-out nm)))]
+    [(_ nm . rest)
+     (begin (require-typed-struct nm . rest)
+            (provide (struct-out nm)))]))
+
+(provide dt require/typed/provide require-typed-struct/provide)