new-style define-serializable-struct
svn: r7871
This commit is contained in:
Matthew Flatt
parent
73bc0e2d52
commit
f520abb24c
|
|
@ -1,4 +1,216 @@
|
||||||
|
|
||||||
(module serialize scheme/base
|
(module serialize scheme/base
|
||||||
(require mzlib/serialize)
|
(require mzlib/private/serialize
|
||||||
(provide (all-from-out mzlib/serialize)))
|
(for-syntax scheme/base
|
||||||
|
scheme/struct-info))
|
||||||
|
|
||||||
|
(provide (all-from-out mzlib/private/serialize)
|
||||||
|
define-serializable-struct
|
||||||
|
define-serializable-struct/versions)
|
||||||
|
|
||||||
|
(define-syntax (define-serializable-struct/versions/derived stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
;; First check `id/sup':
|
||||||
|
[(_ orig-stx id/sup . _)
|
||||||
|
(not (or (identifier? #'id/sup)
|
||||||
|
(syntax-case #'id/sup ()
|
||||||
|
[(id sup) (and (identifier? #'id)
|
||||||
|
(identifier? #'sup)
|
||||||
|
(let ([v (syntax-local-value #'sup (lambda () #f))])
|
||||||
|
(struct-info? v)))]
|
||||||
|
[_ #f])))
|
||||||
|
;; Not valid, so let `define-struct/derived' complain:
|
||||||
|
#'(define-struct/derived orig-stx id/sup ())]
|
||||||
|
;; Check version:
|
||||||
|
[(_ orig-stx id/sup vers . _)
|
||||||
|
(not (exact-nonnegative-integer? (syntax-e #'vers)))
|
||||||
|
(raise-syntax-error #f "expected a nonnegative exact integer for a version" #'orig-stx #'vers)]
|
||||||
|
;; Main case:
|
||||||
|
[(_ orig-stx id/sup vers (field ...) ([other-vers make-proc-expr cycle-make-proc-expr] ...)
|
||||||
|
prop ...)
|
||||||
|
(let* ([id (if (identifier? #'id/sup)
|
||||||
|
#'id/sup
|
||||||
|
(car (syntax-e #'id/sup)))]
|
||||||
|
[super-info (if (identifier? #'id/sup)
|
||||||
|
#f
|
||||||
|
(extract-struct-info (syntax-local-value (cadr (syntax->list #'id/sup)))))]
|
||||||
|
[fields (syntax->list #'(field ...))]
|
||||||
|
[maker (datum->syntax id
|
||||||
|
(string->symbol
|
||||||
|
(format "make-~a" (syntax-e id)))
|
||||||
|
id)]
|
||||||
|
[getters (map (lambda (field)
|
||||||
|
(datum->syntax
|
||||||
|
id
|
||||||
|
(string->symbol
|
||||||
|
(format "~a-~a"
|
||||||
|
(syntax-e id)
|
||||||
|
(syntax-e
|
||||||
|
(if (identifier? field)
|
||||||
|
field
|
||||||
|
(syntax-case field ()
|
||||||
|
[(id . _)
|
||||||
|
(if (identifier? #'id)
|
||||||
|
#'id
|
||||||
|
#'bad)]
|
||||||
|
[_ #'bad])))))))
|
||||||
|
fields)]
|
||||||
|
[mutable? (ormap (lambda (x)
|
||||||
|
(eq? '#:mutable (syntax-e x)))
|
||||||
|
(syntax->list #'(prop ...)))]
|
||||||
|
[setters (map (lambda (field)
|
||||||
|
(let-values ([(field-id mut?)
|
||||||
|
(if (identifier? field)
|
||||||
|
(values field #f)
|
||||||
|
(syntax-case field ()
|
||||||
|
[(id prop ...)
|
||||||
|
(values (if (identifier? #'id)
|
||||||
|
#'id
|
||||||
|
#'bad)
|
||||||
|
(ormap (lambda (x)
|
||||||
|
(eq? '#:mutable (syntax-e x)))
|
||||||
|
(syntax->list #'(prop ...))))]
|
||||||
|
[_ (values #'bad #f)]))])
|
||||||
|
(and (or mutable? mut?)
|
||||||
|
(datum->syntax
|
||||||
|
id
|
||||||
|
(string->symbol
|
||||||
|
(format "set-~a-~a!"
|
||||||
|
(syntax-e id)
|
||||||
|
(syntax-e field-id)))))))
|
||||||
|
fields)]
|
||||||
|
[make-deserialize-id (lambda (vers)
|
||||||
|
(datum->syntax id
|
||||||
|
(string->symbol
|
||||||
|
(format "deserialize-info:~a-v~a"
|
||||||
|
(syntax-e id)
|
||||||
|
(syntax-e vers)))
|
||||||
|
id))]
|
||||||
|
[deserialize-id (make-deserialize-id #'vers)]
|
||||||
|
[other-deserialize-ids (map make-deserialize-id
|
||||||
|
(syntax->list #'(other-vers ...)))])
|
||||||
|
(when super-info
|
||||||
|
(unless (andmap values (list-ref super-info 3))
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"not all fields are known for parent struct type"
|
||||||
|
#'orig-stx
|
||||||
|
(syntax-case #'id/sup ()
|
||||||
|
[(_ sup) #'sup]))))
|
||||||
|
#`(begin
|
||||||
|
;; =============== struct with serialize property ================
|
||||||
|
(define-struct/derived orig-stx
|
||||||
|
id/sup
|
||||||
|
(field ...)
|
||||||
|
prop ...
|
||||||
|
#:property prop:serializable
|
||||||
|
(make-serialize-info
|
||||||
|
;; The struct-to-vector function: --------------------
|
||||||
|
(lambda (v)
|
||||||
|
(vector
|
||||||
|
#,@(if super-info
|
||||||
|
(reverse
|
||||||
|
(map (lambda (sel)
|
||||||
|
#`(#,sel v))
|
||||||
|
(list-ref super-info 3)))
|
||||||
|
null)
|
||||||
|
#,@(map (lambda (getter)
|
||||||
|
#`(#,getter v))
|
||||||
|
getters)))
|
||||||
|
;; The serializer id: --------------------
|
||||||
|
(quote-syntax #,deserialize-id)
|
||||||
|
;; Can handle cycles? --------------------
|
||||||
|
;; Yes, as long as we have mutators for the
|
||||||
|
;; superclass.
|
||||||
|
#,(and (andmap values setters)
|
||||||
|
(or (not super-info)
|
||||||
|
(andmap values (list-ref super-info 4))))
|
||||||
|
;; Directory for last-ditch resolution --------------------
|
||||||
|
(or (current-load-relative-directory)
|
||||||
|
(current-directory))))
|
||||||
|
;; =============== deserialize info ================
|
||||||
|
(define #,deserialize-id
|
||||||
|
(make-deserialize-info
|
||||||
|
;; The maker: --------------------
|
||||||
|
#,maker
|
||||||
|
;; The shell function: --------------------
|
||||||
|
;; Returns an shell object plus
|
||||||
|
;; a function to update the shell (used for
|
||||||
|
;; building cycles):
|
||||||
|
(let ([super-sets
|
||||||
|
(list #,@(if super-info
|
||||||
|
(list-ref super-info 4)
|
||||||
|
null))])
|
||||||
|
(lambda ()
|
||||||
|
(let ([s0
|
||||||
|
(#,maker
|
||||||
|
#,@(append
|
||||||
|
(if super-info
|
||||||
|
(map (lambda (x) #f)
|
||||||
|
(list-ref super-info 3))
|
||||||
|
null)
|
||||||
|
(map (lambda (g)
|
||||||
|
#f)
|
||||||
|
getters)))])
|
||||||
|
(values
|
||||||
|
s0
|
||||||
|
(lambda (s)
|
||||||
|
#,@(if super-info
|
||||||
|
(map (lambda (set get)
|
||||||
|
#`(#,set s0 (#,get s)))
|
||||||
|
(list-ref super-info 4)
|
||||||
|
(list-ref super-info 3))
|
||||||
|
null)
|
||||||
|
#,@(map (lambda (getter setter)
|
||||||
|
#`(#,setter s0 (#,getter s)))
|
||||||
|
getters
|
||||||
|
setters)
|
||||||
|
(void))))))))
|
||||||
|
#,@(map (lambda (other-deserialize-id proc-expr cycle-proc-expr)
|
||||||
|
#`(define #,other-deserialize-id
|
||||||
|
(make-deserialize-info proc-expr cycle-proc-expr)))
|
||||||
|
other-deserialize-ids
|
||||||
|
(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))))]
|
||||||
|
;; -- More error cases ---
|
||||||
|
;; Check fields
|
||||||
|
[(_ orig-stx id/sup vers fields . _rest)
|
||||||
|
;; fields isn't a sequence:
|
||||||
|
#`(define-struct/derived orig-stx fields)]
|
||||||
|
;; vers-spec bad?
|
||||||
|
[(_ orig-stx id/sup vers fields vers-spec prop ...)
|
||||||
|
;; Improve this:
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"expected a parenthesized sequence of version mappings"
|
||||||
|
#'orig-stx
|
||||||
|
#'vers-spec)]
|
||||||
|
;; Last-ditch error:
|
||||||
|
[(_ orig-stx . _)
|
||||||
|
(raise-syntax-error #f "bad syntax" #'orig-stx)]))
|
||||||
|
|
||||||
|
(define-syntax (define-serializable-struct/versions stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ . rest)
|
||||||
|
#`(define-serializable-struct/versions/derived #,stx . rest)]))
|
||||||
|
|
||||||
|
(define-syntax (define-serializable-struct stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ id/sup (field ...) prop ...)
|
||||||
|
#`(define-serializable-struct/versions/derived #,stx
|
||||||
|
id/sup 0 (field ...) () prop ...)]
|
||||||
|
[(_ . rest)
|
||||||
|
#`(define-struct/derived #,stx . rest)]))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
|
|
||||||
(module struct scheme/base
|
(module struct scheme/base
|
||||||
(require mzlib/serialize
|
(require scheme/serialize
|
||||||
scheme/contract
|
scheme/contract
|
||||||
(for-syntax scheme/base))
|
(for-syntax scheme/base))
|
||||||
|
|
||||||
|
|
@ -66,7 +66,7 @@
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (id ([field ct] ...)) ...)
|
[(_ (id ([field ct] ...)) ...)
|
||||||
#`(begin
|
#`(begin
|
||||||
(define-serializable-struct id (field ...)) ...
|
(define-serializable-struct id (field ...) #:mutable) ...
|
||||||
(provide/contract
|
(provide/contract
|
||||||
#,@(let ([ids (syntax->list #'(id ...))]
|
#,@(let ([ids (syntax->list #'(id ...))]
|
||||||
[fields+cts (syntax->list #'(([field ct] ...) ...))])
|
[fields+cts (syntax->list #'(([field ct] ...) ...))])
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user