Make Typed Racket implementation structs authentic.

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

@@ -619,6 +619,7 @@
             #'(constr-provide nonconstr-provide)])]
         [struct-def #'(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/static-contracts/combinators/any.rkt

@@ -27,6 +27,7 @@
 
 (struct any-combinator combinator ()
         #:transparent
+        #:authentic
         #:methods gen:sc
           [(define (sc-map v f) v)
            (define (sc-traverse v f) (void))

typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt

@@ -24,6 +24,7 @@
 
 (struct case-combinator combinator ()
   #:transparent
+  #:authentic
   #:property prop:combinator-name "case->/sc"
   #:methods gen:sc
     [(define (sc-map v f)
@@ -38,6 +39,7 @@
 (struct arr-combinator combinator ()
   #:transparent
   #:property prop:combinator-name "arr/sc"
+  #:authentic
   #:methods gen:sc
     [(define (sc-map v f)
        (arr-combinator (arr-seq-sc-map f (combinator-args v))))
@@ -83,6 +85,7 @@
 
 
 (struct arr-seq (args rest range)
+   #:authentic
    #:transparent
    #:property prop:sequence
      (match-lambda

typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt

@@ -15,6 +15,7 @@
  [prompt-tag/sc ((listof static-contract?) (or/c (listof static-contract?) #f) . -> . static-contract?)])
 
 (struct prompt-tag-combinator combinator ()
+  #:authentic
   #:transparent
   #:property prop:combinator-name "prompt-tag/sc"
   #:methods gen:sc
@@ -36,6 +37,7 @@
        (merge-restricts* 'chaperone (map f (pt-seq->list (combinator-args v)))))])
 
 (struct pt-seq (vals call-cc)
+  #:authentic
   #:transparent
   #:property prop:sequence
   (lambda (s)

typed-racket-lib/typed-racket/static-contracts/combinators/dep-function.rkt

@@ -21,6 +21,7 @@
                                 pre-deps
                                 rng
                                 rng-deps)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "dep->/sc"
   #:methods gen:sc

typed-racket-lib/typed-racket/static-contracts/combinators/exist.rkt

@@ -16,6 +16,7 @@
 
 
 (struct exist-combinator combinator ()
+  #:authentic
   #:transparent
   #:methods gen:sc
   [(define (sc-map v f)

typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt

@@ -23,6 +23,7 @@
                   static-contract?)])
 
 (struct function-combinator combinator (indices mand-kws opt-kws typed-side?)
+        #:authentic
         #:property prop:combinator-name "->/sc"
         #:methods gen:equal+hash [(define (equal-proc a b recur) (function-sc-equal? a b recur))
                                   (define (hash-proc v recur) (function-sc-hash v recur))

typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt

@@ -92,6 +92,7 @@
              (list typed-sc untyped-sc both-sc)))
 
 (struct name-combinator combinator (gen-name)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "name/sc"
   #:methods gen:sc

typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt

@@ -23,6 +23,7 @@
       (display "#<none/sc>" port)))
 
 (struct none-combinator combinator ()
+        #:authentic
         #:transparent
         #:methods gen:sc
           [(define (sc-map v f) v)

typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt

@@ -13,12 +13,13 @@
                        typed-racket/utils/opaque-object)
          (for-syntax racket/base syntax/parse))
 
-(struct member-spec (modifier id sc) #:transparent)
+(struct member-spec (modifier id sc) #:authentic #:transparent)
 
 (define field-modifiers '(field init init-field inherit-field))
 (define method-modifiers '(method inherit super inner override augment augride))
 
 (struct object-combinator combinator (opaque?)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "object/sc"
   #:methods gen:sc
@@ -34,6 +35,7 @@
        (merge-restricts* 'impersonator (map f (member-seq->list (combinator-args v)))))])
 
 (struct class-combinator combinator (opaque absents)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "class/sc"
   #:methods gen:sc
@@ -52,6 +54,7 @@
        (merge-restricts* 'impersonator (map f (member-seq->list (combinator-args v)))))])
 
 (struct instanceof-combinator combinator ()
+  #:authentic
   #:transparent
   #:property prop:combinator-name "instanceof/sc"
   #:methods gen:sc
@@ -78,8 +81,9 @@
      (filter-map member-spec-sc vals)]))
 
 (struct member-seq (vals)
-   #:transparent
-   #:property prop:sequence member-seq->list)
+  #:authentic
+  #:transparent
+  #:property prop:sequence member-seq->list)
 
 (define (member-seq-sc-map f seq)
   (match seq

typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt

@@ -31,6 +31,7 @@
  [sealing-var/sc (identifier? . -> . static-contract?)])
 
 (struct parametric-combinator combinator (vars)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "parametric->/sc"
   #:methods gen:sc
@@ -66,6 +67,7 @@
 
 ;; combinator for sealing-> contracts for row polymorphism
 (struct sealing-combinator combinator (vars members)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "sealing->/sc"
   #:methods gen:sc

typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt

@@ -20,6 +20,7 @@
 
 (struct prefab-combinator combinator (key field-mutability)
   #:transparent
+  #:authentic
   #:property prop:combinator-name "prefab/sc"
   #:methods gen:sc
     [(define (sc-map v f)

typed-racket-lib/typed-racket/static-contracts/combinators/proposition.rkt

@@ -13,7 +13,7 @@
 
 (provide-for-cond-contract proposition-contract?)
 
-(struct proposition-contract static-contract () #:transparent)
+(struct proposition-contract static-contract () #:transparent #:authentic)
 
 
 (define/match (flat-lambda-write v port mode)
@@ -54,6 +54,7 @@
 ;; in the contract syntax they generate.
 (struct flat-named-lambda/sc static-contract (name arg body)
   #:transparent
+  #:authentic
   #:methods gen:sc
   [(define/match (sc-map v f)
      [((flat-named-lambda/sc name arg body) f)
@@ -88,6 +89,7 @@
 ;; so we can use it directly as a predicate.
 (struct is-flat-type/sc proposition-contract (obj type)
   #:transparent
+  #:authentic
   #:methods gen:sc
   [(define/match (sc-map v f)
      [((is-flat-type/sc obj type) f)
@@ -112,6 +114,7 @@
 ;; See is-flat-type/sc for more details.
 (struct not-flat-type/sc proposition-contract (obj type)
   #:transparent
+  #:authentic
   #:methods gen:sc
   [(define/match (sc-map v f)
      [((not-flat-type/sc obj type) f)
@@ -135,6 +138,7 @@
 ;; flat-named-lambda/sc.
 (struct leq/sc proposition-contract (lhs rhs)
   #:transparent
+  #:authentic
   #:methods gen:sc
   [(define/match (sc-map v f)
      [((leq/sc lhs rhs) f)
@@ -152,6 +156,7 @@
 
 (struct and-prop/sc proposition-contract (args)
   #:transparent
+  #:authentic
   #:methods gen:sc
   [(define/match (sc-map v f)
      [((and-prop/sc args) f)
@@ -172,6 +177,7 @@
 
 (struct or-prop/sc proposition-contract (args)
   #:transparent
+  #:authentic
   #:methods gen:sc
   [(define/match (sc-map v f)
      [((or-prop/sc args) f)

typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt

@@ -43,6 +43,7 @@
              (equal?/recur s1 s2 stx-equal?))]))
 
 (struct simple-contract static-contract (syntax kind name)
+        #:authentic
         #:transparent
         #:methods gen:equal+hash
          [(define (equal-proc s1 s2 recur)

typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt

@@ -22,6 +22,7 @@
  [struct-type/sc (any/c . -> . static-contract?)])
 
 (struct struct-combinator combinator (name mut?)
+  #:authentic
   #:transparent
   #:property prop:combinator-name "struct/sc"
   #:methods gen:sc
@@ -61,6 +62,7 @@
 ;; reflective use.  
 (struct struct-type/sc combinator ()
   #:transparent
+  #:authentic
   #:property prop:combinator-name "struct-type/sc"
   #:methods gen:sc
     [(define (sc-map v f)

typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt

@@ -113,6 +113,7 @@
     [(_ sc:static-combinator-form c:expr kind:contract-category-keyword)
      #'(begin
          (struct sc.struct-name combinator ()
+           #:authentic
            #:transparent
            #:methods gen:sc
            [(define sc-map sc.map)

typed-racket-lib/typed-racket/static-contracts/combinators/symbolic-object.rkt

@@ -13,10 +13,11 @@
 
 (provide-for-cond-contract symbolic-object-contract?)
 
-(struct symbolic-object-contract static-contract () #:transparent)
+(struct symbolic-object-contract static-contract () #:transparent #:authentic)
 
 ;; an identifier symbolic object e.g. x
 (struct id/sc symbolic-object-contract (syntax)
+  #:authentic
   #:transparent
   #:methods gen:equal+hash
   [(define/match (equal-proc a b rec)
@@ -35,6 +36,7 @@
 
 ;; a path element access into a symbolic object e.g. (car o)
 (struct acc-obj/sc symbolic-object-contract (acc-stx obj)
+  #:authentic
   #:transparent
   #:methods gen:equal+hash
   [(define/match (equal-proc a b recur)
@@ -58,6 +60,7 @@
 
 ;; a linear expression symbolic obj, e.g. 42, or x, or (+ 1 (* 2 y)), etc...
 (struct linear-exp/sc symbolic-object-contract (const terms)
+  #:authentic
   #:transparent
   #:methods gen:sc
   [(define/match (sc-map v f)

typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt

@@ -10,9 +10,10 @@
          (for-template racket/base racket/unit)
          (for-syntax racket/base syntax/parse))
 
-(struct signature-spec (name members scs) #:transparent)
+(struct signature-spec (name members scs) #:transparent #:authentic)
 
 (struct unit-combinator combinator ()
+        #:authentic
         #:transparent
         #:property prop:combinator-name "unit/sc"
         #:methods gen:sc
@@ -40,6 +41,7 @@
                      (filter-map (lambda (x) x) invoke)))]))
 
 (struct unit-spec (imports exports init-depends invoke) 
+        #:authentic
         #:transparent
         #:property prop:sequence unit-spec->list)
 

typed-racket-lib/typed-racket/static-contracts/equations.rkt

@@ -23,7 +23,7 @@
 
 ; equations: (hash/c var? (-> value?))
 ; initial-values: (hash/c var? (-> value?))
-(struct equation-set (equations initial-values))
+(struct equation-set (equations initial-values) #:transparent #:authentic)
 
 (define (make-equation-set)
   (equation-set (make-hasheq) (make-hasheq)))

typed-racket-lib/typed-racket/static-contracts/structures.rkt

@@ -111,8 +111,9 @@
 
 ;; Super struct of static contracts
 (struct static-contract ()
-        #:transparent
-        #:property prop:custom-print-quotable 'never)
+  #:transparent
+  #:property prop:custom-print-quotable 'never
+  #:authentic)
 
 ;; Represents a recursive contract.
 ;; In each value and the body, each name is bound to a the corresponding value contract.
@@ -121,6 +122,7 @@
 ;; - body : static-contract?
 ;; names and value must have the same length.
 (struct recursive-sc static-contract (names values body)
+        #:authentic
         #:transparent
         #:methods gen:sc
           [(define (sc-map v f)
@@ -140,6 +142,7 @@
 ;; A use of a contract bound by recursive-sc
 ;; - name : identifier?
 (struct recursive-sc-use static-contract (name)
+        #:authentic
         #:transparent
         #:methods gen:sc
           [(define (sc-map v f) v)
@@ -152,6 +155,7 @@
 ;; Provides printing functionality.
 ;; - args : (sequenceof static-contract?)
 (struct combinator static-contract (args)
+        #:authentic
         #:transparent
         #:property prop:combinator-name "combinator/sc"
         #:methods gen:custom-write [(define write-proc combinator-write-proc)])

typed-racket-lib/typed-racket/static-contracts/terminal.rkt

@@ -34,6 +34,7 @@
     [(_ name:id (args:id ...) kind:kind-keyword p:printer body:expr)
      #'(struct name static-contract (args ...)
          #:transparent
+         #:authentic
          p.methods ...
          #:methods gen:sc
           [(define (sc-map v f) v)