diff --git a/xenomorph/xenomorph/redo/base.rkt b/xenomorph/xenomorph/redo/base.rkt index 2e57f67a..239693f6 100644 --- a/xenomorph/xenomorph/redo/base.rkt +++ b/xenomorph/xenomorph/redo/base.rkt @@ -20,16 +20,13 @@ (bitwise-and sint (arithmetic-shift 1 bits))) (define (dump x) - (define (dump-dict x) - (for/list ([(k v) (in-dict x)]) - (cons (dump k) (dump v)))) - (let loop ([x x]) - (cond - [(input-port? x) (port->bytes x)] - [(output-port? x) (get-output-bytes x)] - [(dict? x) (dump-dict x)] - [(list? x) (map loop x)] - [else x]))) + (cond + [(input-port? x) (port->bytes x)] + [(output-port? x) (get-output-bytes x)] + [(dict? x) (for/list ([(k v) (in-dict x)]) + (cons (dump k) (dump v)))] + [(list? x) (map dump x)] + [else x])) (define (pos p [new-pos #f]) (when new-pos @@ -39,4 +36,6 @@ (define-generics xenomorphic (encode xenomorphic val [port] #:parent [parent]) (decode xenomorphic [port] #:parent [parent]) - (size xenomorphic [item] [parent])) \ No newline at end of file + (size xenomorphic [item] [parent])) + +(struct lazy-thunk (proc) #:transparent) \ No newline at end of file diff --git a/xenomorph/xenomorph/redo/struct.rkt b/xenomorph/xenomorph/redo/struct.rkt new file mode 100644 index 00000000..0d83922d --- /dev/null +++ b/xenomorph/xenomorph/redo/struct.rkt @@ -0,0 +1,130 @@ +#lang debug racket/base +(require (prefix-in d: racket/dict) racket/list "base.rkt" "util.rkt" "number.rkt" sugar/unstable/dict) +(provide (all-defined-out)) + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee +|# + +(define private-keys '(parent _startOffset _currentOffset _length)) + +(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)) + (if (lazy-thunk? res) ((lazy-thunk-proc res)) 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 + '_startOffset (pos port) + '_currentOffset 0 + '_length len) + sdr) + +(define (_parse-fields port sdr fields) + (unless (assocs? fields) + (raise-argument-error '_parse-fields "assocs" fields)) + (for/fold ([sdr sdr]) + ([(key type) (d:in-dict fields)]) + (define val (if (procedure? type) + (type sdr) + (decode type port #:parent sdr))) + (unless (void? val) + (d:dict-set! sdr key val)) + (d:dict-set! sdr '_currentOffset (- (pos port) (d:dict-ref sdr '_startOffset))) + sdr)) + +(define (xstruct-decode xs [port-arg (current-input-port)] #:parent [parent #f] [len 0]) + (define port (->input-port port-arg)) + ;; _setup and _parse-fields are separate to cooperate with VersionedStruct + (define res + (let* ([sdr (_setup port parent len)] ; returns StructDictRes + [sdr (_parse-fields port sdr (xstruct-fields xs))]) + sdr)) + (let* ([res ((xstruct-post-decode xs) res port parent)] + #;[res (inner res post-decode res . args)]) + (unless (d:dict? res) (raise-result-error 'xstruct-decode "dict" res)) + res)) + +(define (xstruct-size xs [val #f] [parent #f] [include-pointers #t]) + (define ctx (mhasheq 'parent parent + 'val val + 'pointerSize 0)) + (+ (for/sum ([(key type) (d:in-dict (xstruct-fields xs))] + #:when (xenomorphic? type)) + (size type (and val (d:dict-ref val key)) ctx)) + (if include-pointers (d:dict-ref ctx 'pointerSize) 0))) + +(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent #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))) + ;; check keys first, since `size` also relies on keys being valid + (define val (let* ([val ((xstruct-pre-encode xs) val-arg port)] + #;[val (inner res pre-encode val . args)]) + (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 Struct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val))) + + (define ctx (mhash 'pointers empty + 'startOffset (pos port) + 'parent parent + 'val val + 'pointerSize 0)) + + (d:dict-set! ctx 'pointerOffset (+ (pos port) (if (xenomorphic? val) (size val #f ctx) 0))) + + (for ([(key type) (d:in-dict (xstruct-fields xs))]) + (encode type (d:dict-ref val key) port #:parent ctx)) + (for ([ptr (in-list (d:dict-ref ctx 'pointers))]) + (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) port #:parent (d:dict-ref ptr 'parent))) + (unless port-arg (get-output-bytes port))) + +(struct xstruct (fields post-decode pre-encode) #:transparent #:mutable + #:methods gen:xenomorphic + [(define decode xstruct-decode) + (define encode xstruct-encode) + (define size xstruct-size)]) + +(define (+xstruct [fields null] [post-decode (λ (val port ctx) val)] [pre-encode (λ (val port) val)]) + (unless (d:dict? fields) + (raise-argument-error '+xstruct "dict" fields)) + (xstruct fields post-decode pre-encode)) + +(module+ test + (require rackunit "number.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 diff --git a/xenomorph/xenomorph/redo/test/struct-test.rkt b/xenomorph/xenomorph/redo/test/struct-test.rkt new file mode 100644 index 00000000..a0e814e0 --- /dev/null +++ b/xenomorph/xenomorph/redo/test/struct-test.rkt @@ -0,0 +1,90 @@ +#lang debug racket/base +(require rackunit racket/dict + "../base.rkt" + "../struct.rkt" + "../string.rkt" + "../number.rkt" + sugar/unstable/dict) + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee +|# + +(test-case + "decode into an object" + (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) + (check-equal? + (dump (decode (+xstruct (dictify 'name (+xstring uint8) + 'age uint8)))) + '((name . "roxyb") (age . 21))))) + +(test-case + "decode with process hook" + (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")]) + (define struct (+xstruct (dictify 'name (+xstring uint8) + 'age uint8))) + (set-xstruct-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o)) + (check-equal? (dump (decode struct)) + '((name . "roxyb") (canDrink . #t) (age . 32))))) + +(test-case + "decode supports function keys" + (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")]) + (define struct (+xstruct (dictify 'name (+xstring uint8) + 'age uint8 + 'canDrink (λ (o) (>= (dict-ref o 'age) 21))))) + (check-equal? (dump (decode struct)) + '((name . "roxyb") (canDrink . #t) (age . 32))))) + +(test-case + "compute the correct size" + (check-equal? (size (+xstruct (dictify + 'name (+xstring uint8) + 'age uint8)) + (hasheq 'name "roxyb" 'age 32)) 7)) + +;; todo: reinstate pointer test +#;(test-case + "compute the correct size with pointers" + (check-equal? (size (+xstruct (dictify + 'name (+xstring uint8) + 'age uint8 + 'ptr (+Pointer uint8 (+xstring uint8)))) + (mhash 'name "roxyb" 'age 21 'ptr "hello")) 14)) + +(test-case + "get the correct size when no value is given" + (check-equal? (size (+xstruct (dictify 'name (+xstring 4) 'age uint8))) 5)) + +(test-case + "throw when getting non-fixed length size and no value is given" + (check-exn exn:fail:contract? (λ () (size (+xstruct (dictify 'name (+xstring uint8) + 'age uint8)))))) + +(test-case + "encode objects to buffers" + (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) + (check-equal? (dump (decode (+xstruct (dictify 'name (+xstring uint8) + 'age uint8)))) + '((name . "roxyb") (age . 21))))) + +(test-case + "support pre-encode hook" + (parameterize ([current-output-port (open-output-bytes)]) + (define struct (+xstruct (dictify 'nameLength uint8 + 'name (+xstring 'nameLength) + 'age uint8))) + (set-xstruct-pre-encode! struct (λ (val port) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val)) + (encode struct (mhasheq 'name "roxyb" 'age 21)) + (check-equal? (dump (current-output-port)) #"\x05roxyb\x15"))) + +;; todo: reinstate pointer test +#;(test-case + "encode pointer data after structure" + (parameterize ([current-output-port (open-output-bytes)]) + (define struct (+xstruct (dictify 'name (+xstring uint8) + 'age uint8 + 'ptr (+Pointer uint8 (+xstring uint8))))) + (encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello")) + (check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello"))) \ No newline at end of file