diff --git a/xenomorph/xenomorph/redo/array.rkt b/xenomorph/xenomorph/redo/array.rkt index d8a957aa..bc013def 100644 --- a/xenomorph/xenomorph/redo/array.rkt +++ b/xenomorph/xenomorph/redo/array.rkt @@ -80,7 +80,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee (define encode xarray-encode) (define size xarray-size)]) -(define (+xarray type [len #f] [length-type 'count]) +(define (+xarray [type-arg #f] [len-arg #f] [length-type-arg 'count] + #:type [type-kwarg #f] #:length [len-kwarg #f] #:count-bytes [count-bytes? #f]) + (define type (or type-arg type-kwarg)) + (define len (or len-arg len-kwarg)) + (define length-type (if count-bytes? 'bytes length-type-arg)) (unless (xenomorphic? type) (raise-argument-error '+xarray "xenomorphic type" type)) (unless (length-resolvable? len) diff --git a/xenomorph/xenomorph/redo/bitfield.rkt b/xenomorph/xenomorph/redo/bitfield.rkt index cf7928ba..25b8ef94 100644 --- a/xenomorph/xenomorph/redo/bitfield.rkt +++ b/xenomorph/xenomorph/redo/bitfield.rkt @@ -35,7 +35,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee (define encode xbitfield-encode) (define size xbitfield-size)]) -(define (+xbitfield type [flags null]) +(define (+xbitfield [type-arg #f] [flag-arg #f] + #:type [type-kwarg #f] #:flags [flag-kwarg #f]) + (define type (or type-arg type-kwarg)) + (define flags (or flag-arg flag-kwarg null)) (unless (andmap (λ (f) (or (symbol? f) (not f))) flags) (raise-argument-error '+xbitfield "list of symbols" flags)) (xbitfield type flags)) diff --git a/xenomorph/xenomorph/redo/lazy-array.rkt b/xenomorph/xenomorph/redo/lazy-array.rkt index e1739acf..11808a01 100644 --- a/xenomorph/xenomorph/redo/lazy-array.rkt +++ b/xenomorph/xenomorph/redo/lazy-array.rkt @@ -43,7 +43,10 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee (define encode xlazy-array-encode) (define size xlazy-array-size)]) -(define (+xlazy-array type [len #f]) +(define (+xlazy-array [type-arg #f] [len-arg #f] + #:type [type-kwarg #f] #:length [len-kwarg #f]) + (define type (or type-arg type-kwarg)) + (define len (or len-arg len-kwarg)) (unless (xenomorphic? type) (raise-argument-error '+xarray "xenomorphic type" type)) (unless (length-resolvable? len) diff --git a/xenomorph/xenomorph/redo/pointer.rkt b/xenomorph/xenomorph/redo/pointer.rkt index 83d96131..a0060bf7 100644 --- a/xenomorph/xenomorph/redo/pointer.rkt +++ b/xenomorph/xenomorph/redo/pointer.rkt @@ -1,5 +1,6 @@ #lang debug racket/base (require "helper.rkt" + "number.rkt" racket/dict racket/promise sugar/unstable/dict) @@ -18,34 +19,34 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (define/post-decode (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) (parameterize ([current-input-port port]) - (define offset (decode (xpointer-offset-type xp) #:parent parent)) - (cond - [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers - [else - (define relative (+ (case (pointer-style xp) - [(local) (dict-ref parent '_startOffset)] - [(immediate) (- (pos port) (size (xpointer-offset-type xp)))] - [(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)] - [(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)] - [else (error 'unknown-pointer-style)]) - ((relative-getter-or-0 xp) parent))) - (define ptr (+ offset relative)) - (cond - [(xpointer-type xp) - (define val (void)) - (define (decode-value) - (cond - [(not (void? val)) val] - [else - (define orig-pos (pos port)) - (pos port ptr) - (set! val (decode (xpointer-type xp) #:parent parent)) - (pos port orig-pos) - val])) - (if (pointer-lazy? xp) - (delay (decode-value)) - (decode-value))] - [else ptr])]))) + (define offset (decode (xpointer-offset-type xp) #:parent parent)) + (cond + [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers + [else + (define relative (+ (case (pointer-style xp) + [(local) (dict-ref parent '_startOffset)] + [(immediate) (- (pos port) (size (xpointer-offset-type xp)))] + [(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)] + [(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)] + [else (error 'unknown-pointer-style)]) + ((relative-getter-or-0 xp) parent))) + (define ptr (+ offset relative)) + (cond + [(xpointer-type xp) + (define val (void)) + (define (decode-value) + (cond + [(not (void? val)) val] + [else + (define orig-pos (pos port)) + (pos port ptr) + (set! val (decode (xpointer-type xp) #:parent parent)) + (pos port orig-pos) + val])) + (if (pointer-lazy? xp) + (delay (decode-value)) + (decode-value))] + [else ptr])]))) (define (resolve-void-pointer type val) (cond @@ -58,37 +59,37 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (unless parent ; todo: furnish default pointer context? adapt from Struct? (raise-argument-error 'xpointer-encode "valid pointer context" parent)) (parameterize ([current-output-port port]) - (if (not val) - (encode (xpointer-offset-type xp) (null-value xp) port) - (let* ([new-parent (case (pointer-style xp) - [(local immediate) parent] - [(parent) (dict-ref parent 'parent)] - [(global) (find-top-parent parent)] - [else (error 'unknown-pointer-style)])] - [relative (+ (case (pointer-style xp) - [(local parent) (dict-ref new-parent 'startOffset)] - [(immediate) (+ (pos port) (size (xpointer-offset-type xp) val #:parent parent))] - [(global) 0]) - ((relative-getter-or-0 xp) (dict-ref parent 'val #f)))]) - (encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative)) - (let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)]) - (dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers) - (list (mhasheq 'type type - 'val val - 'parent parent)))) - (dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type val #:parent parent))))))) + (if (not val) + (encode (xpointer-offset-type xp) (null-value xp) port) + (let* ([new-parent (case (pointer-style xp) + [(local immediate) parent] + [(parent) (dict-ref parent 'parent)] + [(global) (find-top-parent parent)] + [else (error 'unknown-pointer-style)])] + [relative (+ (case (pointer-style xp) + [(local parent) (dict-ref new-parent 'startOffset)] + [(immediate) (+ (pos port) (size (xpointer-offset-type xp) val #:parent parent))] + [(global) 0]) + ((relative-getter-or-0 xp) (dict-ref parent 'val #f)))]) + (encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative)) + (let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)]) + (dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers) + (list (mhasheq 'type type + 'val val + 'parent parent)))) + (dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type val #:parent parent))))))) (unless port-arg (get-output-bytes port))) (define (xpointer-size xp [val #f] #:parent [parent #f]) (let*-values ([(parent) (case (pointer-style xp) - [(local immediate) parent] - [(parent) (dict-ref parent 'parent)] - [(global) (find-top-parent parent)] - [else (error 'unknown-pointer-style)])] + [(local immediate) parent] + [(parent) (dict-ref parent 'parent)] + [(global) (find-top-parent parent)] + [else (error 'unknown-pointer-style)])] [(type val) (resolve-void-pointer (xpointer-type xp) val)]) (when (and val parent) (dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f) - (+ (dict-ref parent 'pointerSize) (size type val #:parent parent))))) + (+ (dict-ref parent 'pointerSize) (size type val #:parent parent))))) (size (xpointer-offset-type xp)))) (struct xpointer xbase (offset-type type options) #:transparent @@ -97,13 +98,30 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (define encode xpointer-encode) (define size xpointer-size)]) -(define (+xpointer offset-type type-in [options (mhasheq)]) - (xpointer offset-type (and (not (eq? type-in 'void)) type-in) options)) +(define (+xpointer [offset-arg #f] [type-arg #f] + #:offset-type [offset-kwarg #f] + #:type [type-kwarg #f] + #:style [style 'local] + #:relative-to [relative-to #f] + #:lazy [lazy? #f] + #:allow-null [allow-null? #t] + #:null [null-value 0]) + (define valid-pointer-styles '(local immediate parent global)) + (unless (memq style valid-pointer-styles) + (raise-argument-error '+xpointer (format "~v" valid-pointer-styles) style)) + (define options (mhasheq 'style style + 'relativeTo relative-to + 'lazy lazy? + 'allowNull allow-null? + 'nullValue null-value)) + (define offset-type (or offset-arg offset-kwarg uint8)) + (define type-in (or type-arg type-kwarg uint8)) + (xpointer offset-type (case type-in [(void) #f][else type-in]) options)) -(define (pointer-style xp) (or (dict-ref (xpointer-options xp) 'type #f) 'local)) -(define (allow-null xp) (or (dict-ref (xpointer-options xp) 'allowNull #f) #t)) -(define (null-value xp) (or (dict-ref (xpointer-options xp) 'nullValue #f) 0)) -(define (pointer-lazy? xp) (dict-ref (xpointer-options xp) 'lazy #f)) +(define (pointer-style xp) (dict-ref (xpointer-options xp) 'style)) +(define (allow-null xp) (dict-ref (xpointer-options xp) 'allowNull)) +(define (null-value xp) (dict-ref (xpointer-options xp) 'nullValue)) +(define (pointer-lazy? xp) (dict-ref (xpointer-options xp) 'lazy)) (define (relative-getter-or-0 xp) (or (dict-ref (xpointer-options xp) 'relativeTo #f) (λ (parent) 0))) ; changed this to a simple lambda ;; A pointer whose type is determined at decode time diff --git a/xenomorph/xenomorph/redo/string.rkt b/xenomorph/xenomorph/redo/string.rkt index 1fd7be66..f2cabbea 100644 --- a/xenomorph/xenomorph/redo/string.rkt +++ b/xenomorph/xenomorph/redo/string.rkt @@ -87,7 +87,10 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (define size xstring-size)]) (define supported-encodings '(ascii utf8)) -(define (+xstring [len #f] [encoding 'ascii]) +(define (+xstring [len-arg #f] [enc-arg #f] + #:length [len-kwarg #f] #:encoding [enc-kwarg #f]) + (define len (or len-arg len-kwarg)) + (define encoding (or enc-arg enc-kwarg 'ascii)) (unless (length-resolvable? len) (raise-argument-error '+xarray "length-resolvable?" len)) (unless (or (procedure? encoding) (memq encoding supported-encodings)) @@ -110,7 +113,10 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (define encode xsymbol-encode) (define size xstring-size)]) -(define (+xsymbol [len #f] [encoding 'ascii]) +(define (+xsymbol [len-arg #f] [enc-arg #f] + #:length [len-kwarg #f] #:encoding [enc-kwarg #f]) + (define len (or len-arg len-kwarg)) + (define encoding (or enc-arg enc-kwarg 'ascii)) (xsymbol len encoding)) (module+ test diff --git a/xenomorph/xenomorph/redo/struct.rkt b/xenomorph/xenomorph/redo/struct.rkt index b29dfa97..7f0c688b 100644 --- a/xenomorph/xenomorph/redo/struct.rkt +++ b/xenomorph/xenomorph/redo/struct.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require (prefix-in d: racket/dict) racket/promise + racket/sequence racket/list "helper.rkt" "number.rkt" @@ -116,7 +117,14 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define encode xstruct-encode) (define size xstruct-size)]) -(define (+xstruct [fields null]) +(define (+xstruct . dicts) + (define args (flatten dicts)) + (unless (even? (length args)) + (raise-argument-error '+xstruct "equal 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) (raise-argument-error '+xstruct "dict" fields)) (xstruct fields)) diff --git a/xenomorph/xenomorph/redo/test/array-test.rkt b/xenomorph/xenomorph/redo/test/array-test.rkt index dd464b5c..b4a52db5 100644 --- a/xenomorph/xenomorph/redo/test/array-test.rkt +++ b/xenomorph/xenomorph/redo/test/array-test.rkt @@ -102,4 +102,5 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (test-case "add pointers after array if length is encoded at start" - (check-equal? (encode (+xarray (+xpointer uint8 uint8) uint8) '(1 2 3 4) #f) (bytes 4 5 6 7 8 1 2 3 4))) \ No newline at end of file + (check-equal? (encode (+xarray (+xpointer #:offset-type uint8 + #:type uint8) uint8) '(1 2 3 4) #f) (bytes 4 5 6 7 8 1 2 3 4))) \ No newline at end of file diff --git a/xenomorph/xenomorph/redo/test/pointer-test.rkt b/xenomorph/xenomorph/redo/test/pointer-test.rkt index b828cedd..1178b8f8 100644 --- a/xenomorph/xenomorph/redo/test/pointer-test.rkt +++ b/xenomorph/xenomorph/redo/test/pointer-test.rkt @@ -16,37 +16,37 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (test-case "decode should handle null pointers" (parameterize ([current-input-port (open-input-bytes (bytes 0))]) - (check-false (decode (+xpointer uint8 uint8) #:parent (mhash '_startOffset 50))))) + (check-false (decode (+xpointer) #:parent (mhash '_startOffset 50))))) (test-case "decode should use local offsets from start of parent by default" (parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) - (check-equal? (decode (+xpointer uint8 uint8) #:parent (mhash '_startOffset 0)) 53))) + (check-equal? (decode (+xpointer) #:parent (mhash '_startOffset 0)) 53))) (test-case "decode should support immediate offsets" (parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) - (check-equal? (decode (+xpointer uint8 uint8 (mhash 'type 'immediate))) 53))) + (check-equal? (decode (+xpointer #:style 'immediate)) 53))) (test-case "decode should support offsets relative to the parent" (parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))]) (pos (current-input-port) 2) - (check-equal? (decode (+xpointer uint8 uint8 (mhash 'type 'parent)) + (check-equal? (decode (+xpointer #:style 'parent) #:parent (mhash 'parent (mhash '_startOffset 2))) 53))) (test-case "decode should support global offsets" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))]) (pos (current-input-port) 2) - (check-equal? (decode (+xpointer uint8 uint8 (mhash 'type 'global)) + (check-equal? (decode (+xpointer #:style 'global) #:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2)))) 53))) (test-case "decode should support offsets relative to a property on the parent" (parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))]) - (check-equal? (decode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (parent) (dict-ref (dict-ref parent 'parent) 'ptr)))) + (check-equal? (decode (+xpointer #:relative-to (λ (parent) (dict-ref (dict-ref parent 'parent) 'ptr))) #:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4))) 53))) @@ -59,32 +59,32 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (test-case "decode should support decoding pointers lazily" (parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) - (define res (decode (+xstruct (dictify 'ptr (+xpointer uint8 uint8 (mhasheq 'lazy #t)))))) + (define res (decode (+xstruct (dictify 'ptr (+xpointer #:lazy #t))))) (check-true (promise? (dict-ref (struct-dict-res-_kv res) 'ptr))) (check-equal? (dict-ref res 'ptr) 53))) (test-case "size" (let ([parent (mhash 'pointerSize 0)]) - (check-equal? (size (+xpointer uint8 uint8) 10 #:parent parent) 1) + (check-equal? (size (+xpointer) 10 #:parent parent) 1) (check-equal? (dict-ref parent 'pointerSize) 1))) (test-case "size should add to immediate pointerSize" (let ([parent (mhash 'pointerSize 0)]) - (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent parent) 1) + (check-equal? (size (+xpointer #:style 'immediate) 10 #:parent parent) 1) (check-equal? (dict-ref parent 'pointerSize) 1))) (test-case "size should add to parent pointerSize" (let ([parent (mhash 'parent (mhash 'pointerSize 0))]) - (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent parent) 1) + (check-equal? (size (+xpointer #:style 'parent) 10 #:parent parent) 1) (check-equal? (dict-ref (dict-ref parent 'parent) 'pointerSize) 1))) (test-case "size should add to global pointerSize" (let ([parent (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))]) - (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'global)) 10 #:parent parent) 1) + (check-equal? (size (+xpointer #:style 'global) 10 #:parent parent) 1) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerSize) 1))) (test-case @@ -100,7 +100,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (test-case "size should return a fixed size without a value" - (check-equal? (size (+xpointer uint8 uint8)) 1)) + (check-equal? (size (+xpointer)) 1)) (test-case "encode should handle null pointers" @@ -109,7 +109,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 0 'pointerOffset 0 'pointers null)) - (encode (+xpointer uint8 uint8) #f #:parent parent) + (encode (+xpointer) #f #:parent parent) (check-equal? (dict-ref parent 'pointerSize) 0) (check-equal? (dump (current-output-port)) (bytes 0)))) @@ -120,7 +120,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 0 'pointerOffset 1 'pointers null)) - (encode (+xpointer uint8 uint8) 10 #:parent parent) + (encode (+xpointer) 10 #:parent parent) (check-equal? (dict-ref parent 'pointerOffset) 2) (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8 'val 10 @@ -134,7 +134,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 0 'pointerOffset 1 'pointers null)) - (encode (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent parent) + (encode (+xpointer #:style 'immediate) 10 #:parent parent) (check-equal? (dict-ref parent 'pointerOffset) 2) (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8 'val 10 @@ -148,7 +148,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 3 'pointerOffset 5 'pointers null))) - (encode (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent parent) + (encode (+xpointer #:style 'parent) 10 #:parent parent) (check-equal? (dict-ref (dict-ref parent 'parent) 'pointerOffset) 6) (check-equal? (dict-ref (dict-ref parent 'parent) 'pointers) (list (mhasheq 'type uint8 'val 10 @@ -164,7 +164,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 3 'pointerOffset 5 'pointers null))))) - (encode (+xpointer uint8 uint8 (mhash 'type 'global)) 10 #:parent parent) + (encode (+xpointer #:style 'global) 10 #:parent parent) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerOffset) 6) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointers) (list (mhasheq 'type uint8 @@ -180,7 +180,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 10 'pointers null 'val (mhash 'ptr 4))) - (encode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (parent) (dict-ref parent 'ptr)))) 10 #:parent parent) + (encode (+xpointer #:relative-to (λ (parent) (dict-ref parent 'ptr))) 10 #:parent parent) (check-equal? (dict-ref parent 'pointerOffset) 11) (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8 'val 10 diff --git a/xenomorph/xenomorph/redo/test/struct-test.rkt b/xenomorph/xenomorph/redo/test/struct-test.rkt index 674eff8e..7f481a3f 100644 --- a/xenomorph/xenomorph/redo/test/struct-test.rkt +++ b/xenomorph/xenomorph/redo/test/struct-test.rkt @@ -16,15 +16,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee "decode into an object" (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) (check-equal? - (dump (decode (+xstruct (dictify 'name (+xstring uint8) - 'age uint8)))) + (dump (decode (+xstruct 'name (+xstring #:length 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))) + (define struct (+xstruct 'name (+xstring #:length uint8) + 'age uint8)) (set-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))))) @@ -32,58 +32,56 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (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))))) + (define struct (+xstruct 'name (+xstring #:length 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)) + (check-equal? (size (+xstruct 'name (+xstring #:length uint8) + 'age uint8) (hasheq 'name "roxyb" 'age 32)) 7)) (test-case - "compute the correct size with pointers" - (check-equal? (size (+xstruct (dictify - 'name (+xstring uint8) - 'age uint8 - 'ptr (+xpointer uint8 (+xstring uint8)))) - (mhash 'name "roxyb" 'age 21 'ptr "hello")) 14)) + "compute the correct size with pointers" + (check-equal? (size (+xstruct 'name (+xstring #:length uint8) + 'age uint8 + 'ptr (+xpointer #:type (+xstring #:length 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)) + (check-equal? (size (+xstruct '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)))))) + (check-exn exn:fail:contract? (λ () (size (+xstruct 'name (+xstring #:length 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)))) + (check-equal? (dump (decode (+xstruct 'name (+xstring #:length 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))) + (define struct (+xstruct 'nameLength uint8 + 'name (+xstring 'nameLength) + 'age uint8)) (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? (dump (current-output-port)) #"\x05roxyb\x15"))) (test-case - "encode pointer data after structure" - (parameterize ([current-output-port (open-output-bytes)]) - (define struct (+xstruct (dictify 'name (+xstring uint8) - 'age uint8 - 'ptr (+xpointer 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 + "encode pointer data after structure" + (parameterize ([current-output-port (open-output-bytes)]) + (define struct (+xstruct 'name (+xstring #:length uint8) + 'age uint8 + 'ptr (+xpointer #:type (+xstring #:length 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 diff --git a/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt b/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt index 5737ed66..3fefb874 100644 --- a/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt +++ b/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt @@ -17,9 +17,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "decode should get version from number type" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) @@ -31,9 +31,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "decode should throw for unknown version" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")]) @@ -45,8 +45,8 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 'header (dictify 'age uint8 'alive uint8) - 0 (dictify 'name (+xstring uint8 'ascii)) - 1 (dictify 'name (+xstring uint8 'utf8) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")]) (check-equal? (dump (decode vstruct)) '((version . 0) (name . "roxyb") (age . 21) (alive . 1)))) @@ -61,9 +61,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "decode should support parent version key" (let ([vstruct (+xversioned-struct 'version (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) @@ -77,7 +77,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "decode should support sub versioned structs" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) 1 (+xversioned-struct uint8 (dictify @@ -98,9 +98,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "decode should support process hook" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (set-post-decode! vstruct (λ (val) (dict-set! val 'processed "true") val)) @@ -112,9 +112,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "size should compute the correct size" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (check-equal? (size vstruct (mhasheq 'name "roxyb" @@ -129,9 +129,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "size should throw for unknown version" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (check-exn exn:fail:contract? (λ () (size vstruct (mhasheq 'name "roxyb" @@ -144,8 +144,8 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 'header (dictify 'age uint8 'alive uint8) - 0 (dictify 'name (+xstring uint8 'ascii)) - 1 (dictify 'name (+xstring uint8 'utf8) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'gender uint8)))]) (check-equal? (size struct (mhasheq 'name "roxyb" 'age 21 @@ -161,11 +161,12 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "size should compute the correct size with pointers" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 - 'ptr (+xpointer uint8 (+xstring uint8)))))]) + 'ptr (+xpointer #:offset-type uint8 + #:type (+xstring uint8)))))]) (check-equal? (size vstruct (mhasheq 'name "roxyb" 'age 21 'version 1 @@ -175,9 +176,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "size should throw if no value is given" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))]) (check-exn exn:fail:contract? (λ () (size vstruct))))) @@ -186,9 +187,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "encode should encode objects to buffers" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))] [op (open-output-bytes)]) @@ -205,9 +206,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "encode should throw for unknown version" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))] [op (open-output-bytes)]) @@ -221,8 +222,8 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe (dictify 'header (dictify 'age uint8 'alive uint8) - 0 (dictify 'name (+xstring uint8 'ascii)) - 1 (dictify 'name (+xstring uint8 'utf8) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'gender uint8)))] [op (open-output-bytes)]) (encode vstruct (mhasheq 'name "roxyb" @@ -240,11 +241,12 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "encode should encode pointer data after structure" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 - 'ptr (+xpointer uint8 (+xstring uint8)))))] + 'ptr (+xpointer #:offset-type uint8 + #:type (+xstring uint8)))))] [op (open-output-bytes)]) (encode vstruct (mhasheq 'version 1 'name "roxyb" @@ -257,9 +259,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe "encode should support preEncode hook" (let ([vstruct (+xversioned-struct uint8 (dictify - 0 (dictify 'name (+xstring uint8 'ascii) + 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii) 'age uint8) - 1 (dictify 'name (+xstring uint8 'utf8) + 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8) 'age uint8 'gender uint8)))] [stream (open-output-bytes)])