Enable require-typed-struct with substructures.

Fixes PR 9053.
Move test to succeed.
Add some new bindings.

svn: r12709

collects/typed-scheme/private/base-env.ss

@@ -289,6 +289,57 @@
          [(-Pattern -InpBts N ?N      ) (optlist -Bytes)]
          [(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))]
 
+[regexp-match*
+ (let ([?N      (-opt N)]
+       [-StrRx  (*Un -String -Regexp -PRegexp)]
+       [-BtsRx  (*Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
+       [-InpBts (*Un -Input-Port -Bytes)])
+   (cl->*
+    (-StrRx   -String [N ?N] . ->opt . (-lst -String))
+    (-BtsRx   -String [N ?N] . ->opt . (-lst -Bytes))
+    (-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))]
+[regexp-try-match
+ (let ([?outp   (-opt -Output-Port)]
+       [?N      (-opt N)]
+       [optlist (lambda (t) (-opt (-lst (-opt t))))])
+   (->opt -Pattern -Input-Port [N ?N ?outp] (optlist -Bytes)))]
+
+[regexp-match-exact?
+ (-Pattern (Un -String -Bytes -Input-Port) . -> . B)]
+
+
+[regexp-match-positions
+ (let ([?outp   (-opt -Output-Port)]
+       [?N      (-opt N)]
+       [optlist (lambda (t) (-opt (-lst (-opt t))))]
+       [-StrRx  (*Un -String -Regexp -PRegexp)]
+       [-BtsRx  (*Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
+       [-InpBts (*Un -Input-Port -Bytes)])
+   (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))]
+[regexp-match-positions*
+ (let ([?outp   (-opt -Output-Port)]
+       [?N      (-opt N)]
+       [optlist (lambda (t) (-opt (-lst (-opt t))))]
+       [-StrRx  (*Un -String -Regexp -PRegexp)]
+       [-BtsRx  (*Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
+       [-InpBts (*Un -Input-Port -Bytes)])
+   (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))]
+#;
+[regexp-match-peek-positions*]
+#;
+[regexp-split]
+
+[regexp-quote (cl->*
+               (->opt -String [Univ] -String)
+               (->opt -Bytes [Univ] -Bytes))]
+[regexp-replace-quote
+ (cl->*
+  [-> -String -String]
+  [-> -Bytes -Bytes])]
+
+
+
+
 [number->string (N . -> . -String)]
 
 [current-milliseconds (-> -Integer)]
@@ -500,3 +551,10 @@
 [boolean=? (B B . -> . B)]
 [symbol=? (Sym Sym . -> . B)]
 [false? (make-pred-ty (-val #f))]
+
+;; with-stx.ss
+[generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))]
+[check-duplicate-identifier ((-lst (-Syntax Sym)) . -> . (-opt (-Syntax Sym)))]
+
+;; string.ss
+[real->decimal-string (N [-Nat] . ->opt .  -String)]

collects/typed-scheme/private/parse-type.ss

@@ -27,6 +27,9 @@
   (parameterize ([current-orig-stx stx])
     (syntax-case* stx ()
       symbolic-identifier=?  
+      [t
+       (Type? (syntax-e #'t))
+       (syntax-e #'t)]
       [(fst . rst)
        (not (syntax->list #'rst))
        (-pair (parse-type #'fst) (parse-type #'rst))]

collects/typed-scheme/private/prims.ss

@@ -57,6 +57,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
     [(_ lib [nm ty] ...)
      #'(begin (require/typed nm ty lib) ...)]
+    [(_ nm ty lib #:struct-maker parent)
+     (with-syntax ([(cnt*) (generate-temporaries #'(nm))])
+       (quasisyntax/loc stx (begin 
+                              #,(syntax-property (syntax-property #'(define cnt* #f)
+                                                                  'typechecker:contract-def/maker #'ty)
+                                                 'typechecker:ignore #t)
+                              #,(internal #'(require/typed-internal nm ty #:struct-maker parent))
+                              #,(syntax-property #'(require/contract nm cnt* lib)
+                                                 'typechecker:ignore #t))))]
     [(_ nm ty lib)
      (identifier? #'nm)
      (with-syntax ([(cnt*) (generate-temporaries #'(nm))])
@@ -346,9 +355,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ nm ([fld : ty] ...) lib)
      (identifier? #'nm)
      (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
-                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
-                    [oty #'(Opaque pred)])
+                   #`(begin
-                   #'(begin
                        (require (only-in lib struct-info))
                        (define-syntax nm (make-struct-info 
                                           (lambda ()
@@ -358,9 +366,33 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                                   (list #'sel ...)
                                                   (list mut ...)
                                                   #f))))
-                       (require/opaque-type nm pred lib #:name-exists)
+                       #,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
-                       (require/typed maker (ty ... -> oty) lib)
+                       #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
-                       (require/typed sel (oty -> ty) lib) ...))]))
+                       #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
+                       (require/typed maker nm lib #:struct-maker #f)
+                       (require/typed lib 
+                         [sel (nm -> ty)]) ...))]
+    [(_ (nm parent) ([fld : ty] ...) lib)
+     (and (identifier? #'nm) (identifier? #'parent))
+     (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
+                    #;[(parent-tys ...) (Struct-flds (parse-type #'parent))])
+                   #`(begin
+                       (require (only-in lib struct-info))
+                       (define-syntax nm (make-struct-info 
+                                          (lambda ()
+                                            (list #'struct-info
+                                                  #'maker
+                                                  #'pred
+                                                  (list #'sel ...)
+                                                  (list mut ...)
+                                                  #f))))
+                       #,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
+                       #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
+                       #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
+                       (require/typed maker nm lib #:struct-maker parent)
+                       (require/typed lib                          
+                         [sel (nm -> ty)]) ...))]))
 
 (define-syntax (do: stx)
   (syntax-case stx (:)

collects/typed-scheme/private/type-contract.ss

@@ -23,15 +23,21 @@
  (for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c)))
 
 (define (define/fixup-contract? stx)
-  (syntax-property stx 'typechecker:contract-def))
+  (or (syntax-property stx 'typechecker:contract-def)
+      (syntax-property stx 'typechecker:contract-def/maker)))
 
 (define (generate-contract-def stx)
-  (define prop (syntax-property stx 'typechecker:contract-def))
+  (define prop (or (syntax-property stx 'typechecker:contract-def)
+                   (syntax-property stx 'typechecker:contract-def/maker)))
+  (define maker? (syntax-property stx 'typechecker:contract-def/maker))
   (define typ (parse-type prop))
   (syntax-case stx (define-values)
     [(_ (n) __)
+     (let ([typ (if maker?
+                    ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
+                    typ)])
        (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
-       (syntax/loc stx (define-values (n) cnt)))]
+         (syntax/loc stx (define-values (n) cnt))))]
     [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
 
 (define (change-contract-fixups forms)

collects/typed-scheme/private/type-effect-convenience.ss

@@ -3,6 +3,7 @@
 
 (require (rep type-rep effect-rep)
          (utils tc-utils)
+         scheme/list
          scheme/match
          "type-comparison.ss"
          "type-effect-printer.ss"
@@ -84,7 +85,7 @@
   (define (funty-arities f)
     (match f
       [(Function: as) as]))
-  (make-Function (map car (map funty-arities args))))
+  (make-Function (apply append (map funty-arities args))))
 
 (define-syntax (->key stx)
   (syntax-parse stx
@@ -143,6 +144,8 @@
 (define Univ (make-Univ))
 (define Err (make-Error))
 
+(define -Nat -Integer)
+
 (define-syntax -v 
   (syntax-rules ()
     [(_ x) (make-F 'x)]))
@@ -277,3 +280,9 @@
 
 
 
+(define (opt-fn args opt-args result)
+  (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])                         
+                 (make-Function (list (make-arr* (append args (take opt-args i)) result))))))
+
+(define-syntax-rule (->opt args ... [opt ...] res)
+  (opt-fn (list args ...) (list opt ...) res))

collects/typed-scheme/typecheck/tc-structs.ss

@@ -91,7 +91,8 @@
                          #:proc-ty [proc-ty #f]
                          #:maker [maker* #f]
                          #:constructor-return [cret #f]
-                         #:poly? [poly? #f])
+                         #:poly? [poly? #f]
+                         #:type-only [type-only #f])
   ;; create the approriate names that define-struct will bind
   (define-values (maker pred getters setters) (struct-names nm flds setters?))
   (let* ([name (syntax-e nm)]
@@ -99,17 +100,19 @@
          [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier))]
          [external-fld-types/no-parent types]
          [external-fld-types fld-types])
+    (if type-only
+        (register-type-name nm (wrapper sty))
         (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? 
                                #:wrapper wrapper
                                #:type-wrapper type-wrapper
                                #:maker (or maker* maker)
-                           #:constructor-return cret)))
+                               #:constructor-return cret))))
 
 ;; generate names, and register the approriate types give field types and structure type
 ;; optionally wrap things
 ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
 (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
-                               #:wrapper [wrapper (lambda (x) x)]
+                               #:wrapper [wrapper values]
                                #:type-wrapper [type-wrapper values]
                                #:maker [maker* #f]
                                #:constructor-return [cret #f])
@@ -168,7 +171,9 @@
 
 ;; typecheck a non-polymophic struct and register the approriate types
 ;; 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])
+(define (tc/struct nm/par flds tys [proc-ty #f] 
+                   #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #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))
   ;; parse the field types, and determine if the type is recursive
@@ -184,7 +189,8 @@
                    #:proc-ty proc-ty-parsed
                    #:maker maker
 		   #:constructor-return (and cret (parse-type cret))
-                   #:mutable mutable))
+                   #:mutable mutable
+                   #:type-only type-only))
 
 ;; register a struct type
 ;; convenience function for built-in structs

collects/typed-scheme/typecheck/tc-toplevel.ss

@@ -7,6 +7,7 @@
          scheme/match
          "signatures.ss"
          "tc-structs.ss"
+         (rep type-rep)
          (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract)
 	 (env type-env init-envs type-name-env type-alias-env)
 	 (utils tc-utils)
@@ -44,6 +45,13 @@
          (register-type #'nm t)
          (list (make-def-binding #'nm t)))]
       
+      [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
+       (let* ([t (parse-type #'ty)]
+              [flds (Struct-flds (lookup-type-name (Name-id t)))]
+              [mk-ty (flds #f . ->* . t)])
+         (register-type #'nm mk-ty)
+         (list (make-def-binding #'nm mk-ty)))]
+      
       ;; define-typed-struct
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
@@ -52,6 +60,9 @@
       [(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)]
       ;; define-typed-struct w/ polymorphism
       [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values)))
        (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]