From f5d23091647d17514206d2ec294cd1ad1a4138c6 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 14 Dec 2018 16:27:56 -0800 Subject: [PATCH] support structs as field sources --- xenomorph/xenomorph/struct.rkt | 63 +++++-------- xenomorph/xenomorph/test/pointer-test.rkt | 4 +- .../xenomorph/test/versioned-struct-test.rkt | 31 +++---- xenomorph/xenomorph/versioned-struct.rkt | 90 +++++++++---------- 4 files changed, 84 insertions(+), 104 deletions(-) diff --git a/xenomorph/xenomorph/struct.rkt b/xenomorph/xenomorph/struct.rkt index 0f9a7e4e..d43eec49 100644 --- a/xenomorph/xenomorph/struct.rkt +++ b/xenomorph/xenomorph/struct.rkt @@ -14,39 +14,19 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee |# -(define (choose-dict d k) - (if (memq k private-keys) - (struct-dict-res-_pvt d) - (struct-dict-res-_kv d))) - -(struct struct-dict-res (_kv _pvt) #:transparent - #:methods d:gen:dict - [(define (dict-set! d k v) (d:dict-set! (choose-dict d k) k v)) - (define (dict-ref d k [thunk #f]) - (define res (d:dict-ref (choose-dict d k) k thunk)) - (force res)) - (define (dict-remove! d k) (d:dict-remove! (choose-dict d k) k)) - ;; public keys only - (define (dict-keys d) (d:dict-keys (struct-dict-res-_kv d))) - (define (dict-iterate-first d) (and (pair? (dict-keys d)) 0)) - (define (dict-iterate-next d i) (and (< (add1 i) (length (dict-keys d))) (add1 i))) - (define (dict-iterate-key d i) (list-ref (dict-keys d) i)) - (define (dict-iterate-value d i) (dict-ref d (dict-iterate-key d i)))]) - -(define (+struct-dict-res [_kv (mhasheq)] [_pvt (mhasheq)]) - (struct-dict-res _kv _pvt)) - -(define (_setup port parent len) - (define sdr (+struct-dict-res)) ; not mere hash - (d:dict-set*! sdr 'parent parent +(define (xstruct-setup port parent len) + (define mheq (make-hasheq)) + (d:dict-set*! mheq + 'parent parent '_startOffset (pos port) '_currentOffset 0 '_length len) - sdr) + mheq) -(define (_parse-fields port sdr fields) +(define (xstruct-parse-fields port sdr fields-arg) + (define fields (if (xstruct? fields-arg) (xstruct-fields fields-arg) fields-arg)) (unless (assocs? fields) - (raise-argument-error '_parse-fields "assocs" fields)) + (raise-argument-error 'xstruct-parse-fields "assocs" fields)) (for/fold ([sdr sdr]) ([(key type) (d:in-dict fields)]) (define val (if (procedure? type) @@ -63,18 +43,17 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define (xstruct-xdecode xs [port-arg (current-input-port)] #:parent [parent #f] [len 0]) (define port (->input-port port-arg)) (parameterize ([current-input-port port]) - ;; _setup and _parse-fields are separate to cooperate with VersionedStruct - (define res + ;; xstruct-setup and xstruct-parse-fields are separate to cooperate with VersionedStruct + (define decoded-hash (post-decode xs - (let* ([sdr (_setup port parent len)] ; returns StructDictRes - [sdr (_parse-fields port sdr (xstruct-fields xs))]) - sdr))) - (unless (d:dict? res) - (raise-result-error 'xstruct-decode "dict" res)) - res)) - -(define/finalize-size (xstruct-size xs [val #f] #:parent [parent-arg #f] - #:include-pointers [include-pointers #t]) + (let* ([mheq (xstruct-setup port parent len)] ; returns StructDictRes + [mheq (xstruct-parse-fields port mheq (xstruct-fields xs))]) + mheq))) + (unless (d:dict? decoded-hash) + (raise-result-error 'xstruct-decode "dict" decoded-hash)) + decoded-hash)) + +(define/finalize-size (xstruct-size xs [val #f] #:parent [parent-arg #f] #:include-pointers [include-pointers #t]) (define parent (mhasheq 'parent parent-arg 'val val 'pointerSize 0)) @@ -90,9 +69,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define port (if (output-port? port-arg) port-arg (open-output-bytes))) (parameterize ([current-output-port port]) ;; check keys first, since `size` also relies on keys being valid - (define val (let* ([val (pre-encode xs val-arg)] - #;[val (inner res pre-encode val . args)]) - (unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val)) + (define val (let* ([val (pre-encode xs val-arg)]) + (unless (d:dict? val) + (raise-result-error 'xstruct-encode "dict" val)) val)) (unless (andmap (位 (key) (memq key (d:dict-keys val))) (d:dict-keys (xstruct-fields xs))) (raise-argument-error 'xstruct-encode diff --git a/xenomorph/xenomorph/test/pointer-test.rkt b/xenomorph/xenomorph/test/pointer-test.rkt index bf8a043f..5f7fe1f8 100644 --- a/xenomorph/xenomorph/test/pointer-test.rkt +++ b/xenomorph/xenomorph/test/pointer-test.rkt @@ -53,8 +53,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee "decode should support decoding pointers lazily" (parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) (define res (xdecode (+xstruct 'ptr (+xpointer #:lazy #t)))) - (check-true (promise? (dict-ref (struct-dict-res-_kv res) 'ptr))) - (check-equal? (dict-ref res 'ptr) 53))) + (check-true (promise? (dict-ref res 'ptr))) + (check-equal? (force (dict-ref res 'ptr)) 53))) (test-case "size" diff --git a/xenomorph/xenomorph/test/versioned-struct-test.rkt b/xenomorph/xenomorph/test/versioned-struct-test.rkt index a73787a0..9d99a194 100644 --- a/xenomorph/xenomorph/test/versioned-struct-test.rkt +++ b/xenomorph/xenomorph/test/versioned-struct-test.rkt @@ -6,6 +6,7 @@ "../number.rkt" "../string.rkt" "../pointer.rkt" + "../struct.rkt" "../versioned-struct.rkt") #| @@ -19,7 +20,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) @@ -33,7 +34,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")]) @@ -46,7 +47,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'header (dictify 'age uint8 'alive uint8) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")]) (check-equal? (decode vstruct) (mhasheq 'name "roxyb" @@ -66,7 +67,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) @@ -103,7 +104,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (set-post-decode! vstruct (位 (val) (dict-set! val 'processed "true") val)) @@ -117,7 +118,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (check-equal? (size vstruct (mhasheq 'name "roxyb" @@ -134,7 +135,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (check-exn exn:fail:contract? (位 () (size vstruct (mhasheq 'name "roxyb" 'age 21 'version 5)))))) @@ -146,7 +147,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'header (dictify 'age uint8 'alive uint8) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'gender uint8)))]) (check-equal? (size struct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0)) 9) (check-equal? (size struct (mhasheq 'name "roxyb 馃" 'gender 0 'age 21 'alive 1 'version 1)) 15))) @@ -157,7 +158,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'ptr (+xpointer #:offset-type uint8 #:type (+xstring uint8)))))]) @@ -172,7 +173,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (check-exn exn:fail:contract? (位 () (size vstruct))))) @@ -183,7 +184,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))] [op (open-output-bytes)]) @@ -197,7 +198,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))] [op (open-output-bytes)]) @@ -210,7 +211,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'header (dictify 'age uint8 'alive uint8) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'gender uint8)))] [op (open-output-bytes)]) (encode vstruct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0) op) @@ -223,7 +224,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'ptr (+xpointer #:offset-type uint8 #:type (+xstring uint8)))))] @@ -238,7 +239,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) + 1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))] [op (open-output-bytes)]) diff --git a/xenomorph/xenomorph/versioned-struct.rkt b/xenomorph/xenomorph/versioned-struct.rkt index bedcae69..cf430c59 100644 --- a/xenomorph/xenomorph/versioned-struct.rkt +++ b/xenomorph/xenomorph/versioned-struct.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang debug racket/base (require "helper.rkt" "struct.rkt" racket/dict sugar/unstable/dict) @@ -14,7 +14,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (define/post-decode (xversioned-struct-xdecode xvs [port-arg (current-input-port)] #:parent [parent #f] [length 0]) (define port (->input-port port-arg)) - (define res (_setup port parent length)) + (define res (xstruct-setup port parent length)) (dict-set! res 'version (cond @@ -27,67 +27,67 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee [else (xdecode (xversioned-struct-type xvs) port)])) (when (dict-ref (xversioned-struct-versions xvs) 'header #f) - (_parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header))) + (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 (_parse-fields port res fields) - res])) + [(xversioned-struct? fields) (xdecode fields port #:parent parent)] + [else (xstruct-parse-fields port res fields) + res])) + +(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/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 - (if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) - (size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent) - 0)) + (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))) + (size type (and val (dict-ref val key)) #:parent parent))) (define fields-size - (let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version)) - (raise-argument-error 'xversioned-struct-size "valid version key" version))]) - (for/sum ([(key type) (in-dict fields)]) - (size type (and val (dict-ref val key)) #:parent parent)))) + (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)) -(define/pre-encode (xversioned-struct-encode xvs val [port-arg (current-output-port)] #:parent [parent-arg #f]) +(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? val) - (raise-argument-error 'xversioned-struct-encode "dict" val)) - - (define parent (mhash 'pointers null - 'startOffset (pos port) - 'parent parent-arg - 'val val - 'pointerSize 0)) - (dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val #:parent parent #f))) - - (when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) - (encode (xversioned-struct-type xvs) (dict-ref val 'version #f))) - - (when (dict-ref (xversioned-struct-versions xvs) 'header #f) - (for ([(key type) (in-dict (dict-ref (xversioned-struct-versions xvs) 'header))]) - (encode type (dict-ref val key) #:parent parent))) - - (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f)) - (raise-argument-error 'xversioned-struct-encode "valid version key" version))) - - (unless (andmap (位 (key) (member key (dict-keys val))) (dict-keys fields)) - (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val))) - - (for ([(key type) (in-dict fields)]) - (encode type (dict-ref val 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)))) + (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 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)))) (struct xversioned-struct structish (type versions version-getter version-setter) #:transparent #:mutable #:methods gen:xenomorphic @@ -98,7 +98,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (define (+xversioned-struct type [versions (dictify)]) (unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)]) - (proc type)) + (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))) (raise-argument-error '+xversioned-struct "dict of dicts or structish" versions))