fix a bug where re-exported struct names via require/typed/provide don't have struct infomation (#1078)

* struct: repair reexported struct info via require/typed/provide

Author: capfredf

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

@@ -39,11 +39,11 @@
          #'(begin (provide (rename-out [names id] ...))
                   (define-syntax (names stx) (id stx)) ...))]))
   (def require/opaque-type
-        require-typed-signature
-        require-typed-struct-legacy
-        require-typed-struct
-        require/typed-legacy require/typed require/typed/provide
-        require-typed-struct/provide make-predicate define-predicate)
+       require-typed-signature
+       require-typed-struct-legacy
+       require-typed-struct
+       require/typed-legacy require/typed require/typed/provide
+       require-typed-struct/provide make-predicate define-predicate)
 
   ;; Expand `cast` to a `core-cast` with an extra `#%expression` in order
   ;; to prevent the contract generation pass from executing too early
@@ -448,7 +448,7 @@
                       ;The actual identifier bound to the constructor
                       [real-maker (if (syntax-e #'id-is-ctor?) #'internal-maker #'maker-name)]
                       [extra-maker (and (attribute input-maker.extra)
-                                        (not (bound-identifier=? #'make-name #'nm))
+                                        (not (bound-identifier=? #'maker-name #'nm))
                                         #'maker-name)]
                       [type (if (stx-null? #'(tvar ...))
                                 #'type
@@ -524,7 +524,7 @@
                                   (make-struct-info-wrapper* #'internal-maker si #'type)
                                   si))
 
-                         (dtsi* (tvar ...) spec type (body ...) #:maker maker-name #:type-only)
+                         (dtsi* (tvar ...) spec type (body ...) #:maker maker-name)
                          #,(ignore #'(require/contract pred hidden (or/c struct-predicate-procedure?/c (c-> any-wrap/c boolean?)) lib))
                          #,(internal #`(require/typed-internal hidden (Any -> Boolean :
                                                                            #,(if (stx-null? #'(tvar ...))

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

@@ -42,25 +42,25 @@
            identifier? identifier?
            (values syntax? syntax? identifier? (listof (list/c identifier? identifier?))))
      (match-define (def-binding internal-id ty) me)
-      (with-syntax* ([id internal-id]
-                     [untyped-id (freshen-id #'id)]
-                     [local-untyped-id (freshen-id #'id)]
-                     [export-id new-id])
-        (define/with-syntax ctc (generate-temporary 'generated-contract))
-        ;; Create the definitions of the contract and the contracted export.
-        (define/with-syntax definitions
-          (contract-def/provide-property
-           #'(define-values (ctc) #f)
-           (list ty #'untyped-id #'id pos-blame-id)))
-        (values
-         ;; For the submodule
-         #`(begin definitions (provide untyped-id))
-         ;; For the main module
-         #`(begin (define-syntax local-untyped-id (#,mk-redirect-id (quote-syntax untyped-id)))
-                  (define-syntax export-id
-                    (make-typed-renaming #'id #'local-untyped-id)))
-         new-id
-         null)))])
+     (with-syntax* ([id internal-id]
+                    [untyped-id (freshen-id #'id)]
+                    [local-untyped-id (freshen-id #'id)]
+                    [export-id new-id])
+       (define/with-syntax ctc (generate-temporary 'generated-contract))
+       ;; Create the definitions of the contract and the contracted export.
+       (define/with-syntax definitions
+         (contract-def/provide-property
+          #'(define-values (ctc) #f)
+          (list ty #'untyped-id #'id pos-blame-id)))
+       (values
+        ;; For the submodule
+        #`(begin definitions (provide untyped-id))
+        ;; For the main module
+        #`(begin (define-syntax local-untyped-id (#,mk-redirect-id (quote-syntax untyped-id)))
+                 (define-syntax export-id
+                   (make-typed-renaming #'id #'local-untyped-id)))
+        new-id
+        null)))])
 
 (define-struct (def-stx-binding binding) () #:transparent
   #:methods gen:providable
@@ -107,8 +107,9 @@
              (mk-ignored-quad e))))
 
      (define sname-is-constructor? (and (or extra-constr-name (free-identifier=? sname constructor-name)) #t))
-     (define constr (or extra-constr-name constr^))
+     (define constr (or extra-constr-name constructor-name))
      (define type-is-sname? (free-identifier=? tname internal-id))
+
      ;; Here, we recursively handle all of the identifiers referenced
      ;; in this static struct info.
      (define-values (constr-defn constr-export-defn constr-new-id constr-aliases)
@@ -118,7 +119,9 @@
          ;; avoid generating the quad for constr twice.
          ;; skip it when the binding is for the type name
          [(and (free-identifier=? internal-id sname) (free-identifier=? constr internal-id))
-          (super-mk-quad (make-def-binding constr constr-type) (freshen-id constr) def-tbl pos-blame-id mk-redirect-id)]
+          (super-mk-quad (make-def-binding constr constr-type)
+                         (freshen-id constr) def-tbl pos-blame-id
+                         mk-redirect-id)]
          [else
           (make-quad constr def-tbl pos-blame-id mk-redirect-id)]))
 
@@ -181,7 +184,7 @@
 ;; def-tbl, pos-blame-id, and mk-redirect-id
 (define/cond-contract (make-quad internal-id def-tbl pos-blame-id mk-redirect-id)
   (-> identifier? (free-id-table/c identifier? binding? #:immutable #t) identifier? identifier?
-        (values syntax? syntax? identifier? (listof (list/c identifier? identifier?))))
+      (values syntax? syntax? identifier? (listof (list/c identifier? identifier?))))
   (define new-id (freshen-id internal-id))
   (cond
     ;; if it's already done, do nothing

typed-racket-lib/typed-racket/typecheck/internal-forms.rkt

@@ -73,12 +73,11 @@
 ;;; Helpers
 
 (define-splicing-syntax-class dtsi-fields
-  #:attributes (mutable prefab type-only maker extra-maker [proc-ty 1] [prop 1])
- (pattern
-  (~seq
+  #:attributes (mutable prefab maker extra-maker [proc-ty 1] [prop 1])
+  (pattern
+   (~seq
     (~or (~optional (~and #:mutable (~bind (mutable #t))))
          (~optional (~and #:prefab (~bind (prefab #t))))
-         (~optional (~and #:type-only (~bind (type-only #t))))
          (~optional (~seq #:extra-maker extra-maker))
          (~optional (~seq #:maker maker))
          (~optional (~seq #:proc-ty (proc-ty ...)))
@@ -91,14 +90,13 @@
 
 
 (define-syntax-class define-typed-struct-body
-  #:attributes (name type-name mutable prefab type-only maker extra-maker nm
+  #:attributes (name type-name mutable prefab maker extra-maker nm
                      (tvars 1) (fields 1) (types 1) proc-ty properties)
   (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
             nm:struct-name type-name:id ([fields:id : types:expr] ...) options:dtsi-fields)
            #:attr name #'nm.nm
            #:attr mutable (attribute options.mutable)
            #:attr prefab (attribute options.prefab)
-           #:attr type-only (attribute options.type-only)
            #:with maker^ (or (attribute options.maker) #'nm.nm)
            #:attr maker #'maker^
            #:attr proc-ty (attribute options.proc-ty)

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

@@ -59,7 +59,7 @@
 ;; desc : struct-desc
 ;; struct-info : struct-info?
 ;; type-only : Boolean
-(struct parsed-struct (sty names desc struct-info type-only) #:transparent)
+(struct parsed-struct (sty names desc struct-info) #:transparent)
 
 ;; struct-name : Id  (the identifier for the static struct info,
 ;;                    usually the same as the type-name)
@@ -443,15 +443,13 @@
 
 (define (register-parsed-struct-sty! ps)
   (match ps
-    ((parsed-struct sty names desc si type-only)
+    ((parsed-struct sty names desc si)
      (register-sty! sty names desc))))
 
 (define (register-parsed-struct-bindings! ps)
   (match ps
-    ((parsed-struct sty names desc si type-only)
-     (if type-only
-         null
-         (register-struct-bindings! sty names desc si)))))
+    ((parsed-struct sty names desc si)
+     (register-struct-bindings! sty names desc si))))
 
 ;; Listof<Parsed-Struct> -> Void
 ;; Refines the variance of struct types in the name environment
@@ -550,7 +548,6 @@
                    #:maker [maker #f]
                    #:extra-maker [extra-maker #f]
                    #:mutable [mutable #f]
-                   #:type-only [type-only #f]
                    #:prefab? [prefab? #f]
                    #:proc-ty-stx [proc-ty-stx #f]
                    #:properties [properties empty])
@@ -616,7 +613,7 @@
          (define desc
            (struct-desc parent-fields types tvars mutable parent-mutable))
          (parsed-struct (make-Prefab key (append parent-fields types))
-                        names desc (struct-info-property nm/par) #f)]
+                        names desc (struct-info-property nm/par))]
         [else
          (define parent-mutable
            ;; Only valid as long as typed structs must be
@@ -634,7 +631,7 @@
                                                 (extend-tvars tvars
                                                               (extract-proc-ty proc-ty-stx desc fld-names type-name)))))
 
-         (parsed-struct sty names desc (struct-info-property nm/par) type-only)]))
+         (parsed-struct sty names desc (struct-info-property nm/par))]))
 
 ;; register a struct type
 ;; convenience function for built-in structs

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

@@ -72,7 +72,6 @@
                   #:mutable (attribute t.mutable)
                   #:maker (attribute t.maker)
                   #:extra-maker (attribute t.extra-maker)
-                  #:type-only (attribute t.type-only)
                   #:prefab? (attribute t.prefab)
                   #:proc-ty-stx (attribute t.proc-ty)
                   #:properties (attribute t.properties))])))

typed-racket-test/fail/reexported-require-typed-struct-has-contracts.rkt

@@ -0,0 +1,29 @@
+#;
+(exn-pred "3 contract violation")
+#lang racket/base
+
+(module u racket/base
+  (struct apple (a))
+  (struct pear (a) #:constructor-name make-pear)
+  (provide (struct-out apple)
+           (struct-out pear)))
+
+(module t typed/racket
+  (require/typed/provide (submod ".." u)
+    (#:struct apple ((a : Symbol)))
+    (#:struct pear ((a : Number)) #:constructor-name make-pear)))
+
+(define counter 0)
+(require 't)
+
+(define-syntax-rule (verify-contract expr ...)
+  (begin (with-handlers ([exn:fail:contract? (lambda _
+                                               (set! counter (add1 counter)))])
+           expr)
+         ...
+         (error (format "~a contract violation(s)" counter))))
+
+(verify-contract (apple 42)
+                 (apple-a 20)
+                 (make-pear 'xxx))
+

typed-racket-test/succeed/gh-issue-837.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+(module a racket/base
+  (struct foo ())
+  (provide (struct-out foo)))
+
+(module b typed/racket/base
+  (require/typed (submod ".." a) [#:struct foo ()])
+  (provide (struct-out foo)))
+
+(module c racket/base
+  (require (submod ".." b))
+  (provide (struct-out foo)))

typed-racket-test/succeed/require-typed-struct-info.rkt

@@ -0,0 +1,17 @@
+#lang racket/base
+
+(module u racket/base
+  (struct foo (a))
+  (provide (struct-out foo)))
+
+(module t typed/racket
+  (require/typed/provide (submod ".." u)
+    (#:struct foo ((a : Symbol))))
+  (define ins : foo (foo 'hello))
+  (if (foo? ins)
+      (foo-a ins)
+      (error 'test "not going to happen")))
+
+(require 't racket/match)
+(match (foo 'a)
+  [(foo a) a])