Make Typed Racket implementation structs authentic.

typed-racket-lib/typed-racket/env/type-env-structs.rkt

@@ -21,6 +21,7 @@
                                   [obj-types (hash/c Object? Type? #:immutable #t)]
                                   [props (listof Prop?)]
                                   [aliases immutable-free-id-table?])
+  #:authentic
   #:transparent
   #:property prop:custom-write
   (lambda (e prt mode)

typed-racket-lib/typed-racket/infer/infer-unit.rkt

@@ -182,15 +182,15 @@
 ;; This is a unification of all of the dotted types that exist ListDots, ->..., and ValuesDots.
 ;; This allows for one implementation of the cgen algorithm for dotted types to be shared across all
 ;; of them.
-(struct seq (types end) #:transparent)
-(struct null-end () #:transparent)
+(struct seq (types end) #:transparent #:authentic)
+(struct null-end () #:transparent #:authentic)
 (define -null-end (null-end))
 ;; ts is the pattern of the rest of the seq that can
 ;; occur 0 or more times
 ;; e.g. a rest argument of Num would just be (list Num)
 ;;      a rest arg of (Num Str) would be (list Num Str)
-(struct star-end (ts) #:transparent)
-(struct dotted-end (type bound) #:transparent)
+(struct star-end (ts) #:transparent #:authentic)
+(struct dotted-end (type bound) #:transparent #:authentic)
 
 (define (Values->seq v)
   (match v

typed-racket-lib/typed-racket/private/parse-type.rkt

@@ -608,8 +608,8 @@
     [t
      (-val (syntax->datum #'t))]))
 
-(struct parsing-mode () #:transparent)
-(struct synth-mode parsing-mode (name args same-component-pred) #:transparent)
+(struct parsing-mode () #:transparent #:authentic)
+(struct synth-mode parsing-mode (name args same-component-pred) #:transparent #:authentic)
 
 ;; This mode is used to build up info about how types depend on each other --
 ;; during this parsing, we can't check certain invariant successfully (i.e. when
@@ -636,7 +636,7 @@
    ;;
    ;; interp. same as referenced-aliases
    referenced-class-parents)
-  #:transparent)
+  #:transparent #:authentic)
 
 (define INIT-LEVEL 0)
 (define ALWAYS-PRODUCTIVE-LEVEL -1)

typed-racket-lib/typed-racket/rep/core-rep.rkt

@@ -73,6 +73,7 @@
          (begin (struct name ()
                   #:constructor-name mk
                   #:transparent
+                  #:authentic
                   #:property prop:custom-print-quotable 'never
                   extra ...
                   #:methods gen:custom-write

typed-racket-lib/typed-racket/rep/free-variance.rkt

@@ -42,13 +42,13 @@
                           variance:const
                           variance:dotted)
   (let ()
-    (define-struct Variance () #:transparent)
-    (define-struct (Covariant Variance) () #:transparent)
-    (define-struct (Contravariant Variance) () #:transparent)
-    (define-struct (Invariant Variance) () #:transparent)
-    (define-struct (Constant Variance) () #:transparent)
+    (define-struct Variance () #:transparent #:authentic)
+    (define-struct (Covariant Variance) () #:transparent #:authentic)
+    (define-struct (Contravariant Variance) () #:transparent #:authentic)
+    (define-struct (Invariant Variance) () #:transparent #:authentic)
+    (define-struct (Constant Variance) () #:transparent #:authentic)
     ;; not really a variance, but is disjoint with the others
-    (define-struct (Dotted Variance) () #:transparent)
+    (define-struct (Dotted Variance) () #:transparent #:authentic)
     (values Variance? (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
 
 (define (variance:co? x) (eq? x variance:co))
@@ -74,9 +74,9 @@
 
 ;;All of these are used internally
 ;;Only combined-frees is used externally
-(struct combined-frees (table computed) #:transparent)
-(struct app-frees (name args) #:transparent)
-(struct remove-frees (inner name) #:transparent)
+(struct combined-frees (table computed) #:transparent #:authentic)
+(struct app-frees (name args) #:transparent #:authentic)
+(struct remove-frees (inner name) #:transparent #:authentic)
 
 
 ;; Base constructors

typed-racket-lib/typed-racket/rep/rep-utils.rkt

@@ -614,6 +614,7 @@
         [struct-def (syntax/loc #'var.name
 		      (struct var.name parent ... (flds.ids ...)
                         maybe-transparent ...
+                        #:authentic
                         #:constructor-name constructor-name
                         #:property prop:uid uid-id
                         #:property prop:mask rep-mask-body

typed-racket-lib/typed-racket/rep/type-constr.rkt

@@ -37,7 +37,7 @@
 ;; kind*: whether this type constructor can take an arbitrary number of arguments
 ;; productive?: whether this type constructor is productive.
 (struct TypeConstructor (real-trep-constr arity kind*? productive? [variances #:mutable])
-  #:transparent
+  #:transparent #:authentic
   #:property prop:kind #t
   #:property prop:procedure
   (lambda (me . args)

typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt

@@ -47,7 +47,7 @@
 ;;
 ;; interp. Represents the by-position and by-name initialization
 ;;         arguments respectively provided by the class
-(struct super-init-stxs (by-position by-name) #:transparent)
+(struct super-init-stxs (by-position by-name) #:transparent #:authentic)
 
 ;; time debugging
 (define-syntax do-timing #f)

typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt

@@ -162,7 +162,7 @@
 ;; - internal names are the internal renamings of those variables in fully expanded
 ;;   unit syntax, this renaming is performed by the untyped unit macro
 ;; - All references within a unit body use the internal names
-(struct sig-info (name externals internals) #:transparent)
+(struct sig-info (name externals internals) #:transparent #:authentic)
 
 ;; Process the various pieces of the fully expanded unit syntax to produce
 ;; sig-info structures for the unit's imports and exports, and a list of the
@@ -410,7 +410,7 @@
 ;; - export-links : the symbols corresponding to the link-bindings exported
 ;;                  by this unit
 (struct cu-expr-info (expr import-sigs import-links export-sigs export-links)
-  #:transparent)
+  #:transparent #:authentic)
 
 ;; parse-compound-unit : Syntax -> (Values (Listof (Cons Symbol Id))
 ;;                                         (Listof Symbol)

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

@@ -18,6 +18,7 @@
 ;; shallow-id : identifier
 ;; optional-id : identifier
 (struct typed-renaming (deep-id untyped-id shallow-id optional-id)
+  #:authentic
   ;; prevent the rename transformer from expanding in
   ;; module-begin context because the typed context flag
   ;; will not be set until the module-begin

typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt

@@ -52,7 +52,7 @@
 ;; rest: id or #f
 ;; syntax: syntax? - the improper syntax list of identifiers
 ;; (i.e. (append positional (or id '())) but syntax)
-(struct formals (positional rest syntax) #:transparent)
+(struct formals (positional rest syntax) #:transparent #:authentic)
 
 
 ;; When expanding a keyword or optional lambda, Racket adds into the expanded
@@ -427,7 +427,7 @@
 ;;  [(x y z) ...]      ; ==> (case-arities '(1 2 3) +inf.0)
 ;;  [(x y . rst) ...]  ; ==> (case-arities '(1 2)   2)
 ;;  [l ...])           ; ==> (case-arities '()      0)
-(struct case-arities (fixed-arities rest-pos) #:transparent)
+(struct case-arities (fixed-arities rest-pos) #:transparent #:authentic)
 
 ;; initially, we have seen no fixed arities and it is impossible for
 ;; an argument to be in a rest argument from a previous clause

typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt

@@ -267,7 +267,7 @@
 ;;   (lr-clause (Listof Identifier) Syntax)
 ;;
 ;; interp. represents a letrec binding
-(struct lr-clause (names expr) #:transparent)
+(struct lr-clause (names expr) #:transparent #:authentic)
 
 ;; get-non-recursive-clauses : (Listof lr-clause) (Listof Identifier) ->
 ;;                             (Listof lr-clause) (Listof lr-clause) (Listof Syntax)

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

@@ -60,7 +60,7 @@
 ;; desc : struct-desc
 ;; struct-info : struct-info?
 ;; type-only : Boolean
-(struct parsed-struct (sty names desc struct-info) #:transparent)
+(struct parsed-struct (sty names desc struct-info) #:transparent #:authentic)
 
 ;; struct-name : Id  (the identifier for the static struct info,
 ;;                    usually the same as the type-name)
@@ -71,7 +71,7 @@
 ;; predicate : Id
 ;; getters : Listof[Id]
 ;; setters : Listof[Id] or #f
-(struct struct-names (struct-name type-name struct-type constructor extra-constructor predicate getters setters) #:transparent)
+(struct struct-names (struct-name type-name struct-type constructor extra-constructor predicate getters setters) #:transparent #:authentic)
 
 ;; struct-desc holds all the relevant information about a struct type's types
 ;; parent-fields : (Listof Type)
@@ -81,7 +81,7 @@
 ;; parent-mutable: Any
 (struct struct-desc (parent-fields self-fields tvars
                      mutable parent-mutable)
-        #:transparent)
+        #:transparent #:authentic)
 
 (define (struct-desc-all-fields fields)
   (append (struct-desc-parent-fields fields) (struct-desc-self-fields fields)))

typed-racket-lib/typed-racket/utils/utils.rkt

@@ -217,10 +217,22 @@ at least theoretically.
         (syntax-parse stx
           [(_ head cnt . body)
            (syntax/loc stx (define head . body))]))))
-
 (define-syntax define-struct/cond-contract
   (if enable-contracts?
-      (make-rename-transformer #'define-struct/contract)
+      ;; When contracts are enabled, filter out #:authentic since
+      ;; define-struct/contract doesn't support it
+      (lambda (stx)
+        (syntax-parse stx
+          [(_ hd ([i c] ...) . opts)
+           (define filtered-opts
+             (let loop ([opts (syntax->list #'opts)])
+               (cond
+                 [(null? opts) '()]
+                 [(eq? (syntax-e (car opts)) '#:authentic)
+                  (loop (cdr opts))]
+                 [else (cons (car opts) (loop (cdr opts)))])))
+           (with-syntax ([(opt ...) filtered-opts])
+             #'(define-struct/contract hd ([i c] ...) opt ...))]))
       (syntax-rules ()
         [(_ hd ([i c] ...) . opts)
          (define-struct hd (i ...) . opts)])))