From 90142edc5b4649e058ccf66970c119076ac5e864 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Nov 2013 15:44:26 -0700 Subject: [PATCH] serializable-struct, etc.: export deserialization info in submodule This change is slightly incompatible, because `serializable-struct`, `define-serializable-struct`, and `define-serializable-class` no longer `provide` and identifier that they used to. Instead, the identifier is provided by a `deserialize-info` submodule. The deserializer looks for a `deserialize-info` submodule, and then falls back to using a module if the submodule is not available. --- .../compatibility-lib/mzlib/serialize.rkt | 10 +++-- .../scribblings/reference/class.scrbl | 2 +- .../scribblings/reference/serialization.scrbl | 8 +++- .../racket-test/tests/racket/serialize.rktl | 41 +++++++++++++++++++ .../scribblings/scribble/struct.scrbl | 1 - .../scribble-lib/scribble/core.rkt | 18 +++++--- .../scribble-lib/scribble/struct.rkt | 3 +- .../ffi/serialize-cstruct.rkt | 8 +++- racket/collects/racket/HISTORY.txt | 2 + .../racket/private/class-internal.rkt | 4 +- racket/collects/racket/private/serialize.rkt | 17 +++++++- racket/collects/racket/serialize.rkt | 32 ++++++++++----- 12 files changed, 115 insertions(+), 31 deletions(-) diff --git a/pkgs/compatibility-pkgs/compatibility-lib/mzlib/serialize.rkt b/pkgs/compatibility-pkgs/compatibility-lib/mzlib/serialize.rkt index 8513cb695e..ecde5b4275 100644 --- a/pkgs/compatibility-pkgs/compatibility-lib/mzlib/serialize.rkt +++ b/pkgs/compatibility-pkgs/compatibility-lib/mzlib/serialize.rkt @@ -1,7 +1,8 @@ (module serialize mzscheme (require-for-syntax syntax/struct) (require ;; core [de]serializer: - racket/private/serialize) + racket/private/serialize + (only racket/base module+)) (provide define-serializable-struct define-serializable-struct/versions @@ -361,7 +362,7 @@ #`(begin (define deserializer-id (make-deserialize-info #,(cadr other-version) #,(caddr other-version))) - #,@(make-deserialize-provide stx #'deserializer-id)))) + #,@(make-deserialize-provide stx #'deserializer-id)))) (define (make-deserialize-name id version-num) (datum->syntax-object @@ -379,9 +380,10 @@ (list (quasisyntax/loc stx (namespace-set-variable-value! '#,deserializer-id-stx #,deserializer-id-stx ))) - ;; In a module; provide: + ;; In a module; provide via submodule: (list (quasisyntax/loc stx - (provide #,deserializer-id-stx))))) + (module+ deserialize-info + (provide #,deserializer-id-stx)))))) ;; ------------------------------ ;; The transformers diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/class.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/class.scrbl index 0893babfbc..80a1869397 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/class.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/class.scrbl @@ -2249,7 +2249,7 @@ This form can only be used at the top level, either within a module or outside. The @racket[class-id] identifier is bound to the new class, and @racketidfont{deserialize-info:}@racket[class-id] is also defined; if the definition is within a module, then the latter is -provided from the module. +provided from a @racket[deserialize-info] submodule via @racket[module+]. Serialization for the class works in one of two ways: diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/serialization.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/serialization.scrbl index 1eff521851..12bdb29860 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/serialization.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/serialization.scrbl @@ -392,7 +392,8 @@ In addition to the bindings generated by @racket[struct], @racket[serializable-struct] binds @racketidfont{deserialize-info:}@racket[_id]@racketidfont{-v0} to deserialization information. Furthermore, in a module context, it -automatically @racket[provide]s this binding. +automatically @racket[provide]s this binding in a @racket[deserialize-info] +submodule using @racket[module+]. The @racket[serializable-struct] form enables the construction of structure instances from places where @racket[id] is not accessible, @@ -550,7 +551,10 @@ must be one of the following: @item{If @racket[deserialize-id] is an identifier, and if @racket[(identifier-binding deserialize-id)] produces a list, then the third element is used for the exporting module, otherwise the - top-level is assumed. In either case, @racket[syntax-e] is used to + top-level is assumed. Before trying an exporting module directly, + its @racket[deserialize-info] submodule is tried; the module + itself is tried if no @racket[deserialize-info] + submodule is available. In either case, @racket[syntax-e] is used to obtain the name of an exported identifier or top-level definition.} @item{If @racket[deserialize-id] is a symbol, it indicates a diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl index 803c4eed7b..d9cead9f50 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl @@ -478,6 +478,47 @@ ;; ---------------------------------------- +;; Custom deserialize: +(module my-own-deserialize racket/base + (require racket/serialize) + (provide a + deserialize-info) + (struct a () + #:property prop:serializable + (make-serialize-info (lambda (v) #()) + #'deserialize-info + #f + (or (current-load-relative-directory) + (current-directory)))) + (define deserialize-info + (make-deserialize-info (lambda () 'a) + (lambda () (values 'a void))))) + +(require 'my-own-deserialize) +(test 'a deserialize (serialize (a))) + +;; Same thing, but with submodule: +(module my-own-deserialize/sub racket/base + (require racket/serialize) + (provide b) + (module+ deserialize-info + (provide deserialize-info)) + (struct b () + #:property prop:serializable + (make-serialize-info (lambda (v) #()) + #'deserialize-info + #f + (or (current-load-relative-directory) + (current-directory)))) + (define deserialize-info + (make-deserialize-info (lambda () 'b) + (lambda () (values 'b void))))) + +(require 'my-own-deserialize/sub) +(test 'b deserialize (serialize (b))) + +;; ---------------------------------------- + (let ([fn (make-temporary-file)]) (with-output-to-file fn #:exists 'truncate diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/struct.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/struct.scrbl index ff070f567c..fab2bb69a9 100644 --- a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/struct.scrbl +++ b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/struct.scrbl @@ -5,7 +5,6 @@ make-page-target-element make-redirect-target-element make-link-element make-index-element make-target-url target-url struct:target-url target-url? target-url-addr - deserialize-info:target-url-v0 toc-element-toc-content part-title-content paragraph-content element? element-content element-style) (for-label scribble/manual-struct diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/core.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/core.rkt index e49641f92d..965244c11b 100644 --- a/pkgs/scribble-pkgs/scribble-lib/scribble/core.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/scribble/core.rkt @@ -352,7 +352,8 @@ [sizer (-> any)] [plain (-> any)]))) -(provide deserialize-delayed-element) +(module+ deserialize-info + (provide deserialize-delayed-element)) (define deserialize-delayed-element (make-deserialize-info values values)) @@ -396,7 +397,8 @@ [sizer (-> any)] [plain (-> any)]))) -(provide deserialize-part-relative-element) +(module+ deserialize-info + (provide deserialize-part-relative-element)) (define deserialize-part-relative-element (make-deserialize-info values values)) @@ -437,7 +439,8 @@ (provide/contract (struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)]))) -(provide deserialize-delayed-index-desc) +(module+ deserialize-info + (provide deserialize-delayed-index-desc)) (define deserialize-delayed-index-desc (make-deserialize-info values values)) @@ -457,7 +460,8 @@ (or (current-load-relative-directory) (current-directory))) #:transparent) -(provide deserialize-collect-element) +(module+ deserialize-info + (provide deserialize-collect-element)) (define deserialize-collect-element (make-deserialize-info values values)) @@ -481,7 +485,8 @@ (or (current-load-relative-directory) (current-directory))) #:transparent) -(provide deserialize-render-element) +(module+ deserialize-info + (provide deserialize-render-element)) (define deserialize-render-element (make-deserialize-info values values)) @@ -513,7 +518,8 @@ (provide (struct-out generated-tag)) -(provide deserialize-generated-tag) +(module+ deserialize-info + (provide deserialize-generated-tag)) (define deserialize-generated-tag (make-deserialize-info values values)) diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/struct.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/struct.rkt index c9fa8cb6d4..630717b9e9 100644 --- a/pkgs/scribble-pkgs/scribble-lib/scribble/struct.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/scribble/struct.rkt @@ -1,7 +1,6 @@ #lang scheme/base (require (rename-in (except-in "core.rkt" - target-url struct:target-url target-url? target-url-addr - deserialize-info:target-url-v0) + target-url struct:target-url target-url? target-url-addr) [make-target-url core:make-target-url]) "private/provide-structs.rkt" "html-properties.rkt" diff --git a/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt b/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt index 7c1e915b85..d78402980f 100644 --- a/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt +++ b/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt @@ -7,6 +7,7 @@ syntax/stx) racket/promise racket/serialize + racket/runtime-path ffi/unsafe (only-in '#%foreign ctype-c->scheme)) @@ -67,7 +68,7 @@ [serialize-inplace (and (attribute serialize-inplace-kw) #t)] [deserialize-inplace (and (attribute deserialize-inplace-kw) #t)]) - (syntax/loc stx + (quasisyntax/loc stx (begin ;; the wrapped cstruct (define-cstruct _ID ([field-id type-expr] ...) @@ -99,7 +100,10 @@ (malloc _ID malloc-mode))) ;; deserialization proc - (provide deser-ID) + #,@(if (eq? (syntax-local-context) 'module) + #`((runtime-require (submod "." deserialize-info)) + (module+ deserialize-info (provide deser-ID))) + null) (define deser-ID (id->deserialize-info _ID _ID-pointer deserialize-inplace malloc-ID)) ;; mode-aware make-ID diff --git a/racket/collects/racket/HISTORY.txt b/racket/collects/racket/HISTORY.txt index b71f9c3e2e..a6dbef14b6 100644 --- a/racket/collects/racket/HISTORY.txt +++ b/racket/collects/racket/HISTORY.txt @@ -1,4 +1,6 @@ Version 5.90.0.10 +Changed serializable-struct, etc. to provide deserialized-info:... + through a derialized-info submodule Added chaperone-channel and impersonate-channel Change string->path-element and bytes->path-element to raise an exception for an empty [byte-]string argument diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index 9d8fc30536..3d02a15a80 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -8,6 +8,7 @@ racket/stxparam racket/unsafe/ops "serialize-structs.rkt" + racket/runtime-path (for-syntax racket/stxparam syntax/kerncase syntax/stx @@ -1711,7 +1712,8 @@ #'orig-stx)) (with-syntax ([deserialize-name-info deserialize-name-info] [(provision ...) (if (eq? (syntax-local-context) 'module) - #`((provide #,deserialize-name-info)) + #`((runtime-require (submod "." deserialize-info)) + (module+ deserialize-info (provide #,deserialize-name-info))) #'())]) #'(begin (define-values (name deserialize-name-info) diff --git a/racket/collects/racket/private/serialize.rkt b/racket/collects/racket/private/serialize.rkt index 3052922e2e..8003cc13ee 100644 --- a/racket/collects/racket/private/serialize.rkt +++ b/racket/collects/racket/private/serialize.rkt @@ -73,6 +73,16 @@ `(submod ,(unprotect-path (cadr p)) . ,(cddr p))] [else p])) + ;; A deserialization function is provided from a `deserialize-info` + ;; module: + (define (add-submodule p) + (module-path-index-join '(submod "." deserialize-info) + (if (resolved-module-path? p) + p + (module-path-index-join + p + #f)))) + (define (revive-symbol s) (if (string? s) (string->unreadable-symbol s) @@ -648,7 +658,12 @@ (let ([p (unprotect-path (car path+name))] [sym (revive-symbol (cdr path+name))]) ((deserialize-module-guard) p sym) - (dynamic-require p sym)) + (let ([sub (add-submodule p)]) + (if (module-declared? sub #t) + (dynamic-require sub sym) + ;; On failure, for backward compatibility, + ;; try module instead of submodule: + (dynamic-require p sym)))) (namespace-variable-value (cdr path+name)))]) ;; Register maker and struct type: (vector-set! mod-map n des)) diff --git a/racket/collects/racket/serialize.rkt b/racket/collects/racket/serialize.rkt index c68f38e1c8..64f4658b65 100644 --- a/racket/collects/racket/serialize.rkt +++ b/racket/collects/racket/serialize.rkt @@ -2,7 +2,8 @@ (module serialize racket/base (require "private/serialize.rkt" (for-syntax racket/base - racket/struct-info)) + racket/struct-info) + racket/runtime-path) (provide (all-from-out "private/serialize.rkt") serializable-struct @@ -191,16 +192,25 @@ (syntax->list #'(make-proc-expr ...)) (syntax->list #'(cycle-make-proc-expr ...))) ;; =============== provide =============== - #,@(map (lambda (deserialize-id) - (if (eq? 'top-level (syntax-local-context)) - ;; Top level; in case deserializer-id-stx is macro-introduced, - ;; explicitly use namespace-set-variable-value! - #`(namespace-set-variable-value! '#,deserialize-id - #,deserialize-id) - ;; In a module; provide: - #`(provide #,deserialize-id))) - (cons deserialize-id - other-deserialize-ids))))] + ;; If we're in a module context, then provide through + ;; a submodule: + (#,@(if (eq? 'top-level (syntax-local-context)) + #'(begin) + #'(module+ deserialize-info)) + #,@(map (lambda (deserialize-id) + (if (eq? 'top-level (syntax-local-context)) + ;; Top level; in case deserializer-id-stx is macro-introduced, + ;; explicitly use namespace-set-variable-value! + #`(namespace-set-variable-value! '#,deserialize-id + #,deserialize-id) + ;; In a module; provide: + #`(provide #,deserialize-id))) + (cons deserialize-id + other-deserialize-ids))) + ;; Make sure submodule is pulled along for run time: + #,@(if (eq? 'top-level (syntax-local-context)) + null + #'((runtime-require (submod "." deserialize-info))))))] ;; -- More error cases --- ;; Check fields [(_ orig-stx id/sup vers fields . _rest)