diff --git a/xenomorph/xenomorph/struct.rkt b/xenomorph/xenomorph/struct.rkt index d43eec49..2bc401b7 100644 --- a/xenomorph/xenomorph/struct.rkt +++ b/xenomorph/xenomorph/struct.rkt @@ -1,6 +1,6 @@ #lang debug racket/base -(require (prefix-in d: racket/dict) - racket/promise +(require racket/dict + racket/class racket/sequence racket/list "helper.rkt" @@ -13,10 +13,9 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee |# - (define (xstruct-setup port parent len) (define mheq (make-hasheq)) - (d:dict-set*! mheq + (dict-set*! mheq 'parent parent '_startOffset (pos port) '_currentOffset 0 @@ -24,109 +23,89 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee mheq) (define (xstruct-parse-fields port sdr fields-arg) - (define fields (if (xstruct? fields-arg) (xstruct-fields fields-arg) fields-arg)) + (define fields (if (xstruct? fields-arg) (get-field fields fields-arg) fields-arg)) (unless (assocs? fields) (raise-argument-error 'xstruct-parse-fields "assocs" fields)) (for/fold ([sdr sdr]) - ([(key type) (d:in-dict fields)]) + ([(key type) (in-dict fields)]) (define val (if (procedure? type) (type sdr) - (xdecode type port #:parent sdr))) + (send type xxdecode port sdr))) (unless (void? val) - (d:dict-set! sdr key val)) - (d:dict-set! sdr '_currentOffset (- (pos port) (d:dict-ref sdr '_startOffset))) + (dict-set! sdr key val)) + (dict-set! sdr '_currentOffset (- (pos port) (dict-ref sdr '_startOffset))) sdr)) -(define (xstruct-decode . args) - (dict->mutable-hash (apply xstruct-xdecode args))) - -(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]) - ;; xstruct-setup and xstruct-parse-fields are separate to cooperate with VersionedStruct - (define decoded-hash - (post-decode xs - (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)) - (define fields-size (for/sum ([(key type) (d:in-dict (xstruct-fields xs))] - #:when (xenomorphic? type)) - (size type (and val (d:dict-ref val key)) #:parent parent))) - (define pointers-size (if include-pointers (d:dict-ref parent 'pointerSize) 0)) - (+ fields-size pointers-size)) - -(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f]) - (unless (d:dict? val-arg) - (raise-argument-error 'xstruct-encode "dict" val-arg)) - (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)]) - (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 - (format "dict that contains superset of xstruct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val))) +(define xstruct% + (class xenobase% + (super-new) + (init-field [(@fields fields)]) - (define parent (mhash 'pointers empty - 'startOffset (pos port) - 'parent parent-arg - 'val val - 'pointerSize 0)) + (define/augment (xxdecode port parent [len 0]) + ;; xstruct-setup and xstruct-parse-fields are separate to cooperate with VersionedStruct + (define decoded-hash + (xstruct-parse-fields port (xstruct-setup port parent len) @fields)) + (unless (dict? decoded-hash) + (raise-result-error 'xstruct-decode "dict" decoded-hash)) + decoded-hash) - ; deliberately use `xstruct-size` instead of `size` to use extra arg - (d:dict-set! parent 'pointerOffset - (+ (pos port) (xstruct-size xs val #:parent parent #:include-pointers #f))) + (define/augment (xxencode val port [parent-arg #f]) + ;; check keys first, since `size` also relies on keys being valid + (unless (dict? val) + (raise-result-error 'xstruct-encode "dict" val)) + (unless (andmap (λ (key) (memq key (dict-keys val))) (dict-keys @fields)) + (raise-argument-error 'xstruct-encode + (format "dict that contains superset of xstruct keys: ~a" + (dict-keys @fields)) (dict-keys val))) + (define parent (mhash 'pointers empty + 'startOffset (pos port) + 'parent parent-arg + 'val val + 'pointerSize 0)) + (dict-set! parent 'pointerOffset (+ (pos port) (xxsize-without-pointers val parent))) + (for ([(key type) (in-dict @fields)]) + (send type xxencode (dict-ref val 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)))) - (for ([(key type) (d:in-dict (xstruct-fields xs))]) - (encode type (d:dict-ref val key) #:parent parent)) - (for ([ptr (in-list (d:dict-ref parent 'pointers))]) - (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent))) - (unless port-arg (get-output-bytes port)))) + (define (xxsize-without-pointers [val #f] [parent #f]) + (define new-parent (mhasheq 'parent parent 'val val 'pointerSize 0)) + (for/sum ([(key type) (in-dict @fields)] + #:when (xenomorphic-type? type)) + (send type xxsize (and val (dict-ref val key)) new-parent))) + + (define/augment (xxsize [val #f] [parent #f]) + (define pointers-size (dict-ref parent 'pointerSize)) + (+ (xxsize-without-pointers val parent) pointers-size)))) -(struct structish xbase () #:transparent) -(struct xstruct structish (fields) #:transparent #:mutable - #:methods gen:xenomorphic - [(define decode xstruct-decode) - (define xdecode xstruct-xdecode) - (define encode xstruct-encode) - (define size xstruct-size)]) +(define (xstruct? x) (is-a? x xstruct%)) -(define (+xstruct . dicts) +(define (+xstruct #:subclass [class xstruct%] . dicts) (define args (flatten dicts)) (unless (even? (length args)) (raise-argument-error '+xstruct "equal number of keys and values" dicts)) (define fields (for/list ([kv (in-slice 2 args)]) - (unless (symbol? (car kv)) - (raise-argument-error '+xstruct "symbol" (car kv))) - (apply cons kv))) - (unless (d:dict? fields) + (unless (symbol? (car kv)) + (raise-argument-error '+xstruct "symbol" (car kv))) + (apply cons kv))) + (unless (dict? fields) (raise-argument-error '+xstruct "dict" fields)) - (xstruct fields)) + (new class [fields fields])) (module+ test - (require rackunit "number.rkt") + (require rackunit "number.rkt" "generic.rkt") (define (random-pick xs) (list-ref xs (random (length xs)))) (check-exn exn:fail:contract? (λ () (+xstruct 42))) (for ([i (in-range 20)]) - ;; make random structs and make sure we can round trip - (define field-types - (for/list ([i (in-range 40)]) - (random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) - (define size-num-types - (for/sum ([num-type (in-list field-types)]) - (size num-type))) - (define xs (+xstruct (for/list ([num-type (in-list field-types)]) - (cons (gensym) num-type)))) - (define bs (apply bytes (for/list ([i (in-range size-num-types)]) - (random 256)))) - (check-equal? (encode xs (decode xs bs) #f) bs))) \ No newline at end of file + ;; make random structs and make sure we can round trip + (define field-types + (for/list ([i (in-range 40)]) + (random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) + (define size-num-types + (for/sum ([num-type (in-list field-types)]) + (size num-type))) + (define xs (+xstruct (for/list ([num-type (in-list field-types)]) + (cons (gensym) num-type)))) + (define bs (apply bytes (for/list ([i (in-range size-num-types)]) + (random 256)))) + (check-equal? (encode xs (decode xs bs) #f) bs))) \ No newline at end of file diff --git a/xenomorph/xenomorph/test/struct-test.rkt b/xenomorph/xenomorph/test/struct-test.rkt index c8354102..ea3443cb 100644 --- a/xenomorph/xenomorph/test/struct-test.rkt +++ b/xenomorph/xenomorph/test/struct-test.rkt @@ -1,10 +1,12 @@ #lang debug racket/base (require rackunit racket/dict + racket/class "../helper.rkt" "../struct.rkt" "../string.rkt" "../pointer.rkt" "../number.rkt" + "../generic.rkt" sugar/unstable/dict) #| @@ -22,8 +24,10 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (test-case "decode with process hook" (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")]) - (define struct (+xstruct 'name (+xstring #:length uint8) 'age uint8)) - (set-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o)) + (define mystruct% (class xstruct% + (super-new) + (define/override (post-decode o) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o))) + (define struct (+xstruct #:subclass mystruct% 'name (+xstring #:length uint8) 'age uint8)) (check-equal? (decode struct) (mhasheq 'name "roxyb" 'age 32 'canDrink #t)))) @@ -63,10 +67,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (test-case "support pre-encode hook" (parameterize ([current-output-port (open-output-bytes)]) - (define struct (+xstruct 'nameLength uint8 + (define mystruct% (class xstruct% + (super-new) + (define/override (pre-encode val) + (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))) + (define struct (+xstruct #:subclass mystruct% + 'nameLength uint8 'name (+xstring 'nameLength) 'age uint8)) - (set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val)) + ;(set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val)) (encode struct (mhasheq 'name "roxyb" 'age 21)) (check-equal? (get-output-bytes (current-output-port)) #"\x05roxyb\x15")))