217 lines
10 KiB
Scheme
217 lines
10 KiB
Scheme
|
|
(module serialize scheme/base
|
|
(require "private/serialize.ss"
|
|
(for-syntax scheme/base
|
|
scheme/struct-info))
|
|
|
|
(provide (all-from-out "private/serialize.ss")
|
|
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)]))
|
|
|
|
)
|