Make struct: form have the correct bindings in struct info.

Also fixes reexport of struct-type to typed modules.

Reexport issue.
Closes PR13160.

Constructor issue.
Closes PR13161.

Struct copy issues.
Closes PR 10765.
Closes PR 12513.
Closes PR 13149.

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

@@ -60,6 +60,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
           racket/lazy-require
           syntax/parse
           syntax/stx
+          racket/list
           racket/syntax
           unstable/sequence
           unstable/syntax
@@ -604,12 +605,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
      (syntax-parse stx
        [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...)
            opts:struct-options)
-        (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
+        (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
+              [cname (second (build-struct-names #'nm.name empty #t #t))])
           (with-syntax ([d-s (ignore-some-property
                                (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
                                #t)]
                         [dtsi (quasisyntax/loc stx
                                 (dtsi* (vars.vars ...) nm (fs ...)
+                                       #:maker #,cname
                                        #,@mutable?))])
             (if (eq? (syntax-local-context) 'top-level)
                 ;; Use `eval` at top-level to avoid an unbound id error
@@ -632,17 +635,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
      (syntax-parse stx
        [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
            opts:struct-options)
-        (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
+        (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
-              [cname (datum->syntax #f (format-symbol "make-~a" (syntax-e #'nm.name)))])
           (with-syntax ([d-s (ignore-property (quasisyntax/loc stx
                                                 (struct #,@(attribute nm.new-spec) (fs.fld ...)
-                                                        #:extra-constructor-name #,cname
                                                         . opts))
                                               #t)]
                         [dtsi (quasisyntax/loc stx
                                 (dtsi* (vars.vars ...)
                                        nm.old-spec (fs ...)
-                                       #:maker #,cname
                                        #,@mutable?))])
             ;; see comment above
             (if (eq? (syntax-local-context) 'top-level)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt

@@ -14,6 +14,7 @@
          (env type-env-structs global-env mvar-env)
          (utils tc-utils)
          (only-in (rep type-rep) Type/c)
+         (typecheck renamer)
          (except-in (types utils abbrev kw-types) -> ->* one-of/c))
 
 (provide lexical-env with-lexical-env with-lexical-env/extend
@@ -41,6 +42,12 @@
 (define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f])
   (lookup env i (λ (i) (lookup-type i (λ () 
                                         (cond 
+                                          [(syntax-property i 'constructor-for)
+                                           => (λ (prop)
+                                                (define orig (un-rename prop))
+                                                (define t (lookup-type/lexical orig env))
+                                                (register-type i t)
+                                                t)]
                                           [(syntax-procedure-alias-property i) 
                                            => (λ (prop)
                                                 (define orig (car (flatten prop)))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-binding.rkt

@@ -5,10 +5,12 @@
 (define-struct binding (name) #:transparent)
 (define-struct (def-binding binding) (ty) #:transparent)
 (define-struct (def-stx-binding binding) () #:transparent)
-(define-struct (def-struct-stx-binding def-stx-binding) (static-info) #:transparent)
+(define-struct (def-struct-stx-binding def-stx-binding) (static-info constructor-type) #:transparent)
 
 (provide/cond-contract
  (struct binding ([name identifier?]))
  (struct (def-binding binding) ([name identifier?] [ty any/c]))
  (struct (def-stx-binding binding) ([name identifier?]))
- (struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)])))
+ (struct (def-struct-stx-binding binding) ([name identifier?]
+                                           [static-info (or/c #f struct-info?)]
+                                           [constructor-type any/c])))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt

@@ -30,6 +30,12 @@
 ;; defs: defines in this module
 ;; provs: provides in this module
 ;; pos-blame-id: a #%variable-reference for the module
+
+;; The first returned value is a syntax object of definitions that defines the
+;; contracted versions of the provided identifiers, and the corresponding
+;; provides.
+;;
+;; The second value is a list of two element lists, which are type name aliases.
 (define (generate-prov defs provs pos-blame-id)
   ;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
   (define mapping (make-free-id-table))
@@ -59,17 +65,17 @@
       [(dict-ref defs internal-id #f)
        =>
        (match-lambda
-         [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f))) cnt))
+         [(def-binding _ ty)
-          (mk-value-triple internal-id new-id cnt)]
+          (mk-value-triple internal-id new-id ty)]
-         [(def-struct-stx-binding _ (? struct-info? si))
+         [(def-struct-stx-binding _ (? struct-info? si) constr-type)
-          (mk-struct-syntax-triple internal-id new-id si)]
+          (mk-struct-syntax-triple internal-id new-id si constr-type)]
          [(def-stx-binding _)
           (mk-syntax-triple internal-id new-id)])]
       ;; otherwise, not defined in this module, not our problem
       [else (values #'(begin) internal-id null)]))
 
-  ;; mk-struct-syntax-triple : identifier? identifier? struct-info? -> triple/c
+  ;; mk-struct-syntax-triple : identifier? identifier? struct-info? Type/c -> triple/c
-  (define (mk-struct-syntax-triple internal-id new-id si)
+  (define (mk-struct-syntax-triple internal-id new-id si constr-type)
     (define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
     (match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si))
     (define-values (defns new-ids aliases)
@@ -77,24 +83,37 @@
                   (lambda (e) (if (identifier? e)
                                   (mk e)
                                   (values #'(begin) e null)))
-                  (list* type-desc constr pred super accs)))
+                  (list* type-desc pred super accs)))
-    (define/with-syntax (type-desc* constr* pred* super* accs* ...) 
+    (define-values (constr-defn constr-new-id constr-aliases)
-      (for/list ([i (in-list new-ids)]) (if (identifier? i) #`(syntax #,i) i)))
+      (cond
+       [(not (identifier? constr))
+        (values #'(begin) #f null)]
+       [(free-identifier=? constr internal-id)
+        (mk-value-triple constr (generate-temporary constr) constr-type)]
+       [else
+        (mk constr)]))
+
+    (define/with-syntax (constr* type-desc* pred* super* accs* ...)
+      (for/list ([i (in-list (cons constr-new-id new-ids))])
+        (and (identifier? i) #`(quote-syntax #,i))))
+
     (with-syntax* ([id internal-id]
                    [export-id new-id]
-                   [untyped-id (freshen-id #'id)])
+                   [protected-id (freshen-id #'id)])
       (values
         #`(begin
+            #,constr-defn
             #,@defns
-            (define-syntax untyped-id
+            (define-syntax protected-id
-              (let ((info (list type-desc* constr* pred* (list accs* ...)
+              (let ((info (list type-desc* (syntax export-id) pred* (list accs* ...)
                                 (list #,@(map (lambda (x) #'#f) accs)) super*)))
                 #,(if type-is-constructor?
                       #'(make-struct-info-self-ctor constr* info)
                       #'info)))
-            (def-export export-id id untyped-id))
+            (def-export export-id protected-id protected-id))
         new-id
-        (cons (list #'export-id internal-id) (apply append aliases)))))
+        (cons (list #'export-id internal-id)
+              (apply append constr-aliases aliases)))))
 
 
   ;; mk-syntax-triple : identifier? identifier? -> triple/c
@@ -112,16 +131,18 @@
        (list (list #'export-id #'id)))))
 
   ;; mk-value-triple : identifier? identifier? (or/c syntax? #f) -> triple/c
-  (define (mk-value-triple internal-id new-id cnt)
+  (define (mk-value-triple internal-id new-id ty)
+    (define contract (type->contract ty (λ () #f)))
+
     (with-syntax* ([id internal-id]
                    [untyped-id (freshen-id #'id)]
                    [export-id new-id])
       (define/with-syntax definitions
-        (if cnt
+        (if contract
             (with-syntax* ([module-source pos-blame-id]
                            [the-contract (generate-temporary 'generated-contract)])
               #`(begin
-                  (define the-contract #,cnt)
+                  (define the-contract #,contract)
                   (define-syntax untyped-id
                     (make-provide/contract-transformer
                      (quote-syntax the-contract)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/renamer.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(provide renamer get-alternate)
+(provide renamer get-alternate un-rename)
 
 ;; target : identifier
 ;; alternate : identifier
@@ -21,3 +21,16 @@
   (if alt
       (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
       (make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
+
+;; Undo renaming for type lookup.
+;; Used because of macros that mark the identifier used as the binding such as
+;; kw-application or struct constructors
+;;
+;; The syntax-transforming check is for unit tests
+(define (un-rename id)
+  (if (syntax-transforming?)
+      (let-values (((binding new-id) (syntax-local-value/immediate id (lambda () (values #f #f)))))
+        (if (typed-renaming? binding)
+            new-id
+            id))
+      id))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt

@@ -95,10 +95,10 @@
       (if (null? l)
           (values (reverse getters) (reverse setters))
           (loop (cddr l) (cons (car l) getters) (cons (cadr l) setters)))))
-  (match (build-struct-names nm flds #f #f nm)
+  (match (build-struct-names nm flds #f #f nm #:constructor-name maker*)
     [(list sty maker pred getters/setters ...)
      (let-values ([(getters setters) (split getters/setters)])
-       (struct-names nm sty (or maker* maker) pred getters setters))]))
+       (struct-names nm sty maker pred getters setters))]))
 
 ;; gets the fields of the parent type, if they exist
 ;; Option[Struct-Ty] -> Listof[Type]
@@ -166,13 +166,12 @@
   (define bindings
     (list*
      ;; the list of names w/ types
-     (cons (struct-names-struct-type names) (make-StructType sty))
+     (make-def-binding (struct-names-struct-type names) (make-StructType sty))
-     (cons (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base)))
+     (make-def-binding (struct-names-predicate names)
-     (cons (struct-names-predicate names)
+                       (make-pred-ty (if (not covariant?)
-           (make-pred-ty (if (not covariant?)
+                                         (make-StructTop sty)
-                             (make-StructTop sty)
+                                         (subst-all (make-simple-substitution
-                             (subst-all (make-simple-substitution
+                                                     tvars (map (const Univ) tvars)) poly-base))))
-                                         tvars (map (const Univ) tvars)) poly-base))))
      (append
       (for/list ([g (in-list (struct-names-getters names))]
                  [t (in-list self-fields)]
@@ -183,28 +182,31 @@
                           (->* (list poly-base) t)
                           (->acc (list poly-base) t (list path))))])
           (add-struct-fn! g path #f)
-          (cons g func)))
+          (make-def-binding g func)))
       (if mutable
           (for/list ([s (in-list (struct-names-setters names))]
                      [t (in-list self-fields)]
                      [i (in-naturals parent-count)])
             (add-struct-fn! s (make-StructPE poly-base i) #t)
-            (cons s (poly-wrapper (->* (list poly-base t) -Void))))
+            (make-def-binding s (poly-wrapper (->* (list poly-base t) -Void))))
           null))))
 
   (add-struct-constructor! (struct-names-constructor names))
 
-  (define def-bindings
+  (define constructor-binding
-    (for/list ([b (in-list bindings)])
+     (make-def-binding (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base))))
-        (define id (car b))
+
-        (define t (cdr b))
+  (for ([b (cons constructor-binding bindings)])
-        (register-type id t)
+    (register-type (binding-name b) (def-binding-ty b)))
-        (make-def-binding id t)))
+
-  (if si
+  (append
-    (cons
+    (if (free-identifier=? (struct-names-type-name names)
-      (make-def-struct-stx-binding (struct-names-type-name names) si)
+                           (struct-names-constructor names))
-      def-bindings)
+      null
-    def-bindings))
+      (list constructor-binding))
+   (cons
+     (make-def-struct-stx-binding (struct-names-type-name names) si (def-binding-ty constructor-binding))
+     bindings)))
 
 (define (register-parsed-struct-sty! ps)
   (match ps

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

@@ -49,7 +49,7 @@
            #:attr name #'nm.nm
            #:attr mutable (attribute fields.mutable)
            #:attr type-only (attribute fields.type-only)
-           #:attr maker (attribute fields.maker)))
+           #:attr maker (or (attribute fields.maker) #'nm.nm)))
 
 (define (parse-define-struct-internal form)
   (parameterize ([current-orig-stx form])
@@ -331,7 +331,17 @@
   (define def-tbl
     (for/fold ([h (make-immutable-free-id-table)])
       ([def (in-list defs)])
-      (dict-set h (binding-name def) def)))
+      ;; TODO figure out why without these checks some tests break
+      (define (plain-stx-binding? def)
+        (and (def-stx-binding? def) (not (def-struct-stx-binding? def))))
+      (define (merge-def-bindings other-def)
+        (cond
+          [(not other-def) def]
+          [(plain-stx-binding? def) other-def]
+          [(plain-stx-binding? other-def) def]
+          [else
+            (int-err "Two conflicting definitions: ~a ~a" def other-def)]))
+      (dict-update h (binding-name def) merge-def-bindings #f)))
   ;; typecheck the expressions and the rhss of defintions
   ;(displayln "Starting pass2")
   (for-each tc-toplevel/pass2 forms)

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr10765.rkt

@@ -0,0 +1,17 @@
+#lang racket/load
+
+(module A typed/racket
+
+ (struct: Point ([x : Integer] [y : Integer]))
+
+ (provide (all-defined-out)))
+
+(module B typed/racket
+ (require 'A)
+
+ (: lift (Point -> Point))
+ (define (lift p)
+   (struct-copy Point p [x (add1 (Point-x p))]))
+ (lift (Point 3 4)))
+
+(require 'B)

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13160.rkt

@@ -0,0 +1,14 @@
+#lang racket/load
+
+(module a typed/racket/base
+  (provide (struct-out the-struct))
+  (struct: the-struct ((a : Number))))
+
+
+(module b typed/racket/base
+  (require 'a)
+  (provide (struct-out the-struct)))
+
+(require 'b)
+(the-struct 5)
+

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13161.rkt

@@ -0,0 +1,10 @@
+#lang typed/racket/base
+
+(provide (struct-out x)
+         make-x)
+
+(struct: x () #:transparent)
+
+(: make-x : -> x)
+(define (make-x)
+    (x))

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/structs-across-modules.rkt

@@ -0,0 +1,16 @@
+#lang racket/load
+
+(module t1 typed/racket
+  (provide node)
+  (struct: node ()))
+
+(module t2 typed/racket
+  (require 't1)
+  (: v node)
+  (define v (node)))
+(module u racket
+  (require 't1)
+  (node))
+
+(require 't2)
+(require 'u)