xml: make structs serializable, but enforce contracts

Related to: racket/scribble#498
Related to: racket#5282

Author: LiberalArtist

racket/collects/xml/private/core.rkt

@@ -1,28 +1,90 @@
 #lang racket/base
-(require racket/contract/base)
+(require racket/runtime-path
+         (for-syntax racket/base))
 
 ;; Core structures needed for `xml/xexpr'
 
-(provide (all-defined-out))
+(provide permissive-xexprs
+         (struct-out source)
+         (struct-out comment)
+         (struct-out p-i)
+         (struct-out pcdata)
+         (struct-out cdata)
+         valid-char?)
 
 ; permissive-xexprs : parameter bool
 (define permissive-xexprs (make-parameter #f))
 
+; support for serialization with contracts enforced on deserialization
+(module serialization-support racket/base
+  (require racket/serialize-structs
+           (for-syntax racket/syntax
+                       racket/struct-info
+                       racket/base))
+  (define ((cycles-not-allowed name))
+    (error name "invalid serialization;\n cycles not allowed"))
+  (define-for-syntax ((make-define-serializable-struct deserialize-info-mpi
+                                                       get-checked-constructor)
+                      stx)
+    (syntax-case stx ()
+      [(_ name-maybe-super (fld ...))
+       (with-syntax* ([(name super-fld-ref ...)
+                       (syntax-case #'name-maybe-super ()
+                         [name
+                          (identifier? #'name)
+                          #'(name)]
+                         [(name super)
+                          #`(name
+                             #,@(reverse (list-ref (extract-struct-info (syntax-local-value #'super))
+                                                   3)))])]
+                      [(name-fld-ref ...)
+                       (for/list ([id (in-list (syntax->list #'(fld ...)))])
+                         (format-id id "~a-~a" #'name id))]
+                      [deserialize-info:name-v0
+                       (format-id #'name "deserialize-info:~a-v0" #'name)])
+         #`(begin
+             (define-struct name-maybe-super (fld ...)
+               #:property prop:serializable
+               (make-serialize-info (λ (this)
+                                      (vector (super-fld-ref this) ...
+                                              (name-fld-ref this) ...))
+                                    (cons 'deserialize-info:name-v0 #,deserialize-info-mpi)
+                                    #f
+                                    (or (current-load-relative-directory) (current-directory)))
+               #:transparent)
+             (module+ deserialize-info
+               (provide deserialize-info:name-v0)
+               (define deserialize-info:name-v0
+                 (make-deserialize-info (#,get-checked-constructor name)
+                                        (cycles-not-allowed 'name))))))]))
+  (provide (for-syntax make-define-serializable-struct)))
+(require 'serialization-support)
+(define-runtime-module-path-index deserialize-info-mpi '(submod "." deserialize-info))
+(module+ deserialize-info
+  (define-runtime-module-path-index mpi-for-contracts "structures.rkt")
+  (define-syntax-rule (get-checked-constructor name)
+    (dynamic-require mpi-for-contracts 'name)))
+(define-syntax define-xexpr-struct
+  (make-define-serializable-struct #'deserialize-info-mpi #'get-checked-constructor))
+
 ; Source = (make-source Location Location)
-(define-struct source (start stop) #:transparent)
+(define-struct source (start stop)
+  ; NOT define-xexpr-struct (and not serializable) because this is used as an abstract base type:
+  ; if a subtype is not intended to be serializable, it shouldn't be serialized by inheritance
+  #:transparent)
 
 ; Comment = (make-comment String)
-(define-struct comment (text) #:transparent)
+(define-xexpr-struct comment (text))
 
 ; Processing-instruction = (make-p-i Location Location String String)
 ; also represents XMLDecl
-(define-struct (p-i source) (target-name instruction) #:transparent)
+(define-xexpr-struct (p-i source) (target-name instruction))
 
 ; Pcdata = (make-pcdata Location Location String)
-(define-struct (pcdata source) (string) #:transparent)
+(define-xexpr-struct (pcdata source) (string))
 
 ; Cdata = (make-cdata Location Location String)
-(define-struct (cdata source) (string) #:transparent)
+(define-xexpr-struct (cdata source) (string))
 
 ; Section 2.2 of XML 1.1
 ; (XML 1.0 is slightly different and more restrictive)

racket/collects/xml/private/structures.rkt

@@ -1,32 +1,45 @@
 #lang racket/base
 (require "core.rkt"
-         racket/contract)
+         (submod "core.rkt" serialization-support)
+         racket/runtime-path
+         racket/contract
+         (for-syntax racket/base))
+
+(define-runtime-module-path-index deserialize-info-mpi '(submod "." deserialize-info))
+(module+ deserialize-info
+  (define-syntax-rule (get-checked-constructor name)
+    (let ()
+      (local-require (only-in (submod "..") name))
+      name)))
+(define-syntax define-xml-struct
+  (make-define-serializable-struct #'deserialize-info-mpi #'get-checked-constructor))
 
 ; Location = (make-location Nat Nat Nat) | Symbol
-(define-struct location (line char offset) #:transparent)
+(define-xml-struct location (line char offset))
 
 ; Document = (make-document Prolog Element (listof Misc))
-(define-struct document (prolog element misc) #:transparent)
+(define-xml-struct document (prolog element misc))
 
 ; Prolog = (make-prolog (listof Misc) Document-type (listof Misc))
-(define-struct prolog (misc dtd misc2) #:transparent)
+(define-xml-struct prolog (misc dtd misc2))
 
 ; Document-type = (make-document-type sym External-dtd #f)
 ;               | #f
-(define-struct document-type (name external inlined) #:transparent)
+(define-xml-struct document-type (name external inlined))
 
 ; External-dtd = (make-external-dtd/public str str)
 ;              | (make-external-dtd/system str)
 ;              | #f
-(define-struct external-dtd (system) #:transparent)
-(define-struct (external-dtd/public external-dtd) (public) #:transparent)
-(define-struct (external-dtd/system external-dtd) () #:transparent)
+; NOTE, however, that the contract on `document-type` allows any `external-dtd?`
+(define-xml-struct external-dtd (system))
+(define-xml-struct (external-dtd/public external-dtd) (public))
+(define-xml-struct (external-dtd/system external-dtd) ())
 
 ; Element = (make-element Location Location Symbol (listof Attribute) (listof Content))
-(define-struct (element source) (name attributes content) #:transparent)
+(define-xml-struct (element source) (name attributes content))
 
 ; Attribute = (make-attribute Location Location Symbol String)
-(define-struct (attribute source) (name value) #:transparent)
+(define-xml-struct (attribute source) (name value))
 
 ; Content = Pcdata
 ;         |  Element
@@ -38,7 +51,7 @@
 ;      |  Processing-instruction
 
 ; Entity = (make-entity Location Location (U Nat Symbol))
-(define-struct (entity source) (text) #:transparent)
+(define-xml-struct (entity source) (text))
 
 (define permissive/c
   (make-contract