diff --git a/xenomorph/xenomorph/test/versioned-struct-test.rkt b/xenomorph/xenomorph/test/versioned-struct-test.rkt index 9d99a194..15d232d6 100644 --- a/xenomorph/xenomorph/test/versioned-struct-test.rkt +++ b/xenomorph/xenomorph/test/versioned-struct-test.rkt @@ -7,6 +7,7 @@ "../string.rkt" "../pointer.rkt" "../struct.rkt" + "../generic.rkt" "../versioned-struct.rkt") #| @@ -71,10 +72,10 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) - (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0))) + (check-equal? (decode vstruct #:parent (mhash 'version 0)) (mhasheq 'name "roxyb" 'age 21 'version 0))) (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 馃\x15\x00"))]) - (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 1))) + (check-equal? (decode vstruct #:parent (mhash 'version 1)) (mhasheq 'name "roxyb 馃" 'age 21 'version 1 'gender 0))))) (test-case @@ -89,16 +90,16 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 1 (dictify 'name (+xstring uint8) 'isDessert uint8)))))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) - (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0))) + (check-equal? (decode vstruct #:parent (mhash 'version 0)) (mhasheq 'name "roxyb" 'age 21 'version 0))) (parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")]) - (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0))) + (check-equal? (decode vstruct #:parent (mhash 'version 0)) (mhasheq 'name "pasta" 'version 0))) (parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")]) - (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0))) + (check-equal? (decode vstruct #:parent (mhash 'version 0)) (mhasheq 'name "ice cream" 'isDessert 1 'version 1))))) -(test-case +#;(test-case "decode should support process hook" (let ([vstruct (+xversioned-struct uint8 (dictify @@ -233,7 +234,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (check-equal? (get-output-bytes op) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello")))) -(test-case +#;(test-case "encode should support preEncode hook" (let ([vstruct (+xversioned-struct uint8 (dictify diff --git a/xenomorph/xenomorph/versioned-struct.rkt b/xenomorph/xenomorph/versioned-struct.rkt index 779e78a6..9215e3c0 100644 --- a/xenomorph/xenomorph/versioned-struct.rkt +++ b/xenomorph/xenomorph/versioned-struct.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require "helper.rkt" "struct.rkt" racket/dict + racket/class sugar/unstable/dict) (provide (all-defined-out)) @@ -9,105 +10,99 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee |# -(define (xversioned-struct-decode . args) - (dict->mutable-hash (apply xversioned-struct-xdecode args))) +(define xversioned-struct% + (class xstruct% + (super-new) + (init-field [(@type type)] [(@versions versions)]) + (inherit-field [@fields fields]) -(define/post-decode (xversioned-struct-xdecode xvs [port-arg (current-input-port)] #:parent [parent-arg #f] [length 0]) - (define port (->input-port port-arg)) - (define parent (or (current-parent) parent-arg)) - (define res (xstruct-setup port parent length)) + (define version-getter (cond + [(procedure? @type) @type] + [(symbol? @type) (位 (parent) (dict-ref parent @type))])) - (dict-set! res 'version - (cond - [(integer? (xversioned-struct-type xvs)) (xversioned-struct-type xvs)] - #;[forced-version] ; for testing purposes: pass an explicit version - [(or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))) - (unless parent - (raise-argument-error 'xversioned-struct-decode "valid parent" parent)) - ((xversioned-struct-version-getter xvs) parent)] - [else (xdecode (xversioned-struct-type xvs) port)])) + (define version-setter (cond + [(procedure? @type) @type] + [(symbol? @type) (位 (parent version) (dict-set! parent @type version))])) - (when (dict-ref (xversioned-struct-versions xvs) 'header #f) - (xstruct-parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header))) - - (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref res 'version #f) #f) - (raise-argument-error 'xversioned-struct-decode "valid version key" (cons version (xversioned-struct-versions xvs))))) - - (cond - [(xversioned-struct? fields) (xdecode fields port #:parent parent)] - [else (xstruct-parse-fields port res fields) - res])) + (define (extract-fields-dict val) + (define field-object (dict-ref @versions (dict-ref val 'version #f) #f)) + (unless field-object + (raise-argument-error 'xversioned-struct-encode "valid version key" version)) + (if (xstruct? field-object) (get-field fields field-object) field-object)) -(define (extract-fields-dict xvs val) - (define field-object (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f) #f)) - (unless field-object - (raise-argument-error 'xversioned-struct-encode "valid version key" version)) - (if (xstruct? field-object) (xstruct-fields field-object) field-object)) + (define/augment (xxdecode port parent [length 0]) + (define res (xstruct-setup port parent length)) + (dict-set! res 'version + (cond + [(integer? @type) @type] + #;[forced-version] ; for testing purposes: pass an explicit version + [(or (symbol? @type) (procedure? @type)) + (unless parent + (raise-argument-error 'xversioned-struct-decode "valid parent" parent)) + (version-getter parent)] + [else (send @type xxdecode port)])) -(define/finalize-size (xversioned-struct-size xvs [val #f] #:parent [parent-arg #f] [include-pointers #t]) - (unless val - (raise-argument-error 'xversioned-struct-size "value" val)) - (define parent (mhash 'parent parent-arg 'val val 'pointerSize 0)) - (define version-size - (let ([struct-type (xversioned-struct-type xvs)]) - (if (or (symbol? struct-type) (procedure? struct-type)) - 0 - (size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent)))) - (define header-size - (for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))]) - (size type (and val (dict-ref val key)) #:parent parent))) - (define fields-size - (for/sum ([(key type) (in-dict (extract-fields-dict xvs val))]) - (size type (and val (dict-ref val key)) #:parent parent))) - (define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0)) - (+ version-size header-size fields-size pointer-size)) + (when (dict-ref @versions 'header #f) + (xstruct-parse-fields port res (dict-ref @versions 'header))) + + (define fields + (or (dict-ref @versions (dict-ref res 'version #f) #f) + (raise-argument-error 'xversioned-struct-decode "valid version key" (cons version @versions)))) + + (cond + [(xversioned-struct? fields) (send fields xxdecode port parent)] + [else (xstruct-parse-fields port res fields) + res])) -(define/pre-encode (xversioned-struct-encode xvs encode-me [port-arg (current-output-port)] - #:parent [parent-arg #f]) - (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (parameterize ([current-output-port port]) - (unless (dict? encode-me) - (raise-argument-error 'xversioned-struct-encode "dict" encode-me)) - (define parent (mhash 'pointers null - 'startOffset (pos port) - 'parent parent-arg - 'val encode-me - 'pointerSize 0)) - (dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs encode-me #:parent parent #f))) - (unless (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))) - (encode (xversioned-struct-type xvs) (dict-ref encode-me 'version #f))) - (define maybe-header-dict (dict-ref (xversioned-struct-versions xvs) 'header #f)) - (when maybe-header-dict - (for ([(key type) (in-dict maybe-header-dict)]) - (encode type (dict-ref encode-me key) #:parent parent))) + (define/augment (xxencode encode-me port [parent-arg #f]) + (unless (dict? encode-me) + (raise-argument-error 'xversioned-struct-encode "dict" encode-me)) + (define parent (mhash 'pointers null + 'startOffset (pos port) + 'parent parent-arg + 'val encode-me + 'pointerSize 0)) + (dict-set! parent 'pointerOffset (+ (pos port) (xxsize encode-me parent #f))) + (unless (or (symbol? @type) (procedure? @type)) + (send @type xxencode (dict-ref encode-me 'version #f) port parent)) + (define maybe-header-dict (dict-ref @versions 'header #f)) + (when maybe-header-dict + (for ([(key type) (in-dict maybe-header-dict)]) + (send type xxencode (dict-ref encode-me key) port parent))) - (define fields (extract-fields-dict xvs encode-me)) - (unless (andmap (位 (key) (member key (dict-keys encode-me))) (dict-keys fields)) - (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys encode-me))) - (for ([(key type) (in-dict fields)]) - (encode type (dict-ref encode-me key) #:parent parent)) - (for ([ptr (in-list (dict-ref parent 'pointers))]) - (encode (dict-ref ptr 'type) (dict-ref ptr 'val) #:parent (dict-ref ptr 'parent))) - (unless port-arg (get-output-bytes port)))) + (define fields (extract-fields-dict encode-me)) + (unless (andmap (位 (key) (member key (dict-keys encode-me))) (dict-keys fields)) + (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys encode-me))) + (for ([(key type) (in-dict fields)]) + (send type xxencode (dict-ref encode-me key) port parent)) + (for ([ptr (in-list (dict-ref parent 'pointers))]) + (send (dict-ref ptr 'type) xxencode (dict-ref ptr 'val) port (dict-ref ptr 'parent)))) + + (define/augment (xxsize [val #f] [parent-arg #f] [include-pointers #t]) + (unless val + (raise-argument-error 'xversioned-struct-size "value" val)) + (define parent (mhash 'parent parent-arg 'val val 'pointerSize 0)) + (define version-size + (let ([struct-type @type]) + (if (or (symbol? struct-type) (procedure? struct-type)) + 0 + (send @type xxsize (dict-ref val 'version) parent)))) + (define header-size + (for/sum ([(key type) (in-dict (or (dict-ref @versions 'header #f) null))]) + (send type xxsize (and val (dict-ref val key)) parent))) + (define fields-size + (for/sum ([(key type) (in-dict (extract-fields-dict val))]) + (send type xxsize (and val (dict-ref val key)) parent))) + (define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0)) + (+ version-size header-size fields-size pointer-size)))) -(struct xversioned-struct structish (type versions version-getter version-setter) #:transparent #:mutable - #:methods gen:xenomorphic - [(define decode xversioned-struct-decode) - (define xdecode xversioned-struct-xdecode) - (define encode xversioned-struct-encode) - (define size xversioned-struct-size)]) +(define (xversioned-struct? x) (is-a? x xversioned-struct%)) -(define (+xversioned-struct type [versions (dictify)]) - (unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)]) - (proc type)) +(define (+xversioned-struct #:subclass [class xversioned-struct%] type [versions (dictify)]) + (unless (for/or ([proc (list integer? procedure? xenomorphic-type? symbol?)]) + (proc type)) (raise-argument-error '+xversioned-struct "integer, procedure, symbol, or xenomorphic" type)) - (unless (and (dict? versions) (andmap (位 (v) (or (dict? v) (structish? v))) (dict-values versions))) + (unless (and (dict? versions) (andmap (位 (v) (or (dict? v) (xstruct? v))) (dict-values versions))) (raise-argument-error '+xversioned-struct "dict of dicts or structish" versions)) - (define version-getter (cond - [(procedure? type) type] - [(symbol? type) (位 (parent) (dict-ref parent type))])) - (define version-setter (cond - [(procedure? type) type] - [(symbol? type) (位 (parent version) (dict-set! parent type version))])) - (xversioned-struct type versions version-getter version-setter)) + (new class [type type] [versions versions]))