diff --git a/xenomorph/xenomorph/array.rkt b/xenomorph/xenomorph/array.rkt index ad5877af..f5725058 100644 --- a/xenomorph/xenomorph/array.rkt +++ b/xenomorph/xenomorph/array.rkt @@ -92,8 +92,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee #:type [type-kwarg #f] #:length [len-kwarg #f] #:count-bytes [count-bytes? #f] - #:subclass [class xarray%]) - (new class [type (or type-arg type-kwarg)] + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) + (new (generate-subclass xarray% pre-proc post-proc) [type (or type-arg type-kwarg)] [len (or len-arg len-kwarg)] [length-type (if count-bytes? 'bytes length-type-arg)])) diff --git a/xenomorph/xenomorph/bitfield.rkt b/xenomorph/xenomorph/bitfield.rkt index 3f11ec2b..aeffb95a 100644 --- a/xenomorph/xenomorph/bitfield.rkt +++ b/xenomorph/xenomorph/bitfield.rkt @@ -34,10 +34,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee (define (+xbitfield [type-arg #f] [flag-arg #f] #:type [type-kwarg #f] #:flags [flag-kwarg #f] - #:subclass [class xbitfield%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define type (or type-arg type-kwarg)) (define flags (or flag-arg flag-kwarg null)) - (new class [type type] [flags flags])) + (new (generate-subclass xbitfield% pre-proc post-proc) [type type] [flags flags])) (module+ test (require rackunit "number.rkt" "generic.rkt") diff --git a/xenomorph/xenomorph/buffer.rkt b/xenomorph/xenomorph/buffer.rkt index b997d7a5..0dec0391 100644 --- a/xenomorph/xenomorph/buffer.rkt +++ b/xenomorph/xenomorph/buffer.rkt @@ -34,6 +34,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee (define (+xbuffer [len-arg #f] #:length [len-kwarg #f] - #:subclass [class xbuffer%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define len (or len-arg len-kwarg #xffff)) - (new class [len len])) \ No newline at end of file + (new (generate-subclass xbuffer% pre-proc post-proc) [len len])) \ No newline at end of file diff --git a/xenomorph/xenomorph/enum.rkt b/xenomorph/xenomorph/enum.rkt index 7ae212f5..94c39c1e 100644 --- a/xenomorph/xenomorph/enum.rkt +++ b/xenomorph/xenomorph/enum.rkt @@ -33,7 +33,8 @@ https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee (define (+xenum [type-arg #f] [values-arg #f] #:type [type-kwarg #f] #:values [values-kwarg #f] - #:subclass [class xenum%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define type (or type-arg type-kwarg)) (define values (or values-arg values-kwarg)) - (new class [type type] [values values])) \ No newline at end of file + (new (generate-subclass xenum% pre-proc post-proc) [type type] [values values])) \ No newline at end of file diff --git a/xenomorph/xenomorph/helper.rkt b/xenomorph/xenomorph/helper.rkt index 0ee715db..f7435eaf 100644 --- a/xenomorph/xenomorph/helper.rkt +++ b/xenomorph/xenomorph/helper.rkt @@ -19,26 +19,44 @@ (define xenomorphic<%> (interface* () ([(generic-property gen:xenomorphic) - (generic-method-table gen:xenomorphic - (define (decode xo [port-arg (current-input-port)] #:parent [parent #f]) - (define port - (cond - [(input-port? port-arg) port-arg] - [(bytes? port-arg) (open-input-bytes port-arg)] - [else (raise-argument-error 'decode "byte string or input port" port-arg)])) - (send xo decode port parent)) + (generic-method-table + gen:xenomorphic + (define (decode xo [port-arg (current-input-port)] #:parent [parent #f]) + (define port + (cond + [(input-port? port-arg) port-arg] + [(bytes? port-arg) (open-input-bytes port-arg)] + [else (raise-argument-error 'decode "byte string or input port" port-arg)])) + (send xo decode port parent)) - (define (encode xo val [port-arg (current-output-port)] - #:parent [parent #f]) - (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (send xo xxencode val port parent) - (unless port-arg (get-output-bytes port))) + (define (encode xo val [port-arg (current-output-port)] + #:parent [parent #f]) + (define port (if (output-port? port-arg) port-arg (open-output-bytes))) + (send xo xxencode val port parent) + (unless port-arg (get-output-bytes port))) - (define (size xo [val #f] #:parent [parent #f]) - (send xo xxsize val parent)))]))) + (define (size xo [val #f] #:parent [parent #f]) + (send xo xxsize val parent)))]))) (define (xenomorphic-type? x) (is-a? x xenobase%)) +(define-syntax-rule (generate-subclass CLASS PRE-ENCODE-PROC POST-DECODE-PROC) + (cond + [(and PRE-ENCODE-PROC POST-DECODE-PROC) + (class CLASS + (super-new) + (define/override (pre-encode x) (super pre-encode (PRE-ENCODE-PROC x))) + (define/override (post-decode x) (POST-DECODE-PROC (super post-decode x))))] + [PRE-ENCODE-PROC + (class CLASS + (super-new) + (define/override (pre-encode x) (super pre-encode (PRE-ENCODE-PROC x))))] + [POST-DECODE-PROC + (class CLASS + (super-new) + (define/override (post-decode x) (POST-DECODE-PROC (super post-decode x))))] + [else CLASS])) + (define xenobase% (class* object% (xenomorphic<%>) (super-new) diff --git a/xenomorph/xenomorph/lazy-array.rkt b/xenomorph/xenomorph/lazy-array.rkt index 1228f951..23ebc5e6 100644 --- a/xenomorph/xenomorph/lazy-array.rkt +++ b/xenomorph/xenomorph/lazy-array.rkt @@ -41,10 +41,11 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee (define (+xlazy-array [type-arg #f] [len-arg #f] #:type [type-kwarg #f] #:length [len-kwarg #f] - #:subclass [class xlazy-array%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define type (or type-arg type-kwarg)) (define len (or len-arg len-kwarg)) - (new class [type type] + (new (generate-subclass xlazy-array% pre-proc post-proc) [type type] [len len] [length-type 'count])) diff --git a/xenomorph/xenomorph/number.rkt b/xenomorph/xenomorph/number.rkt index 844d99f9..c02291e4 100644 --- a/xenomorph/xenomorph/number.rkt +++ b/xenomorph/xenomorph/number.rkt @@ -73,8 +73,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian] - #:subclass [class xint%]) - (new class [size size] [signed signed] [endian endian])) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) + (new (generate-subclass xint% pre-proc post-proc) [size size] [signed signed] [endian endian])) (define int8 (+xint 1)) (define int16 (+xint 2)) @@ -155,8 +156,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define/augment (xxencode val . _) (real->floating-point-bytes val @size (eq? @endian 'be))))) -(define (+xfloat [size 4] #:endian [endian system-endian]) - (new xfloat% [size size] [endian endian])) +(define (+xfloat [size 4] #:endian [endian system-endian] + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) + (new (generate-subclass xfloat% pre-proc post-proc) [size size] [endian endian])) (define float (+xfloat 4)) (define floatbe (+xfloat 4 #:endian 'be)) @@ -184,8 +187,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] - #:fracbits [fracbits (/ (* size 8) 2)]) - (new xfixed% [size size] [signed signed] [endian endian] [fracbits fracbits])) + #:fracbits [fracbits (/ (* size 8) 2)] + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) + (new (generate-subclass xfixed% pre-proc post-proc) [size size] [signed signed] [endian endian] [fracbits fracbits])) (define fixed16 (+xfixed 2)) (define fixed16be (+xfixed 2 #:endian 'be)) diff --git a/xenomorph/xenomorph/optional.rkt b/xenomorph/xenomorph/optional.rkt index 9b2545c3..caf0df52 100644 --- a/xenomorph/xenomorph/optional.rkt +++ b/xenomorph/xenomorph/optional.rkt @@ -35,10 +35,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee (define (+xoptional [type-arg #f] [cond-arg no-val] #:type [type-kwarg #f] #:condition [cond-kwarg no-val] - #:subclass [class xoptional%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define type (or type-arg type-kwarg)) (define condition (cond [(and (eq? cond-arg no-val) (eq? cond-kwarg no-val)) #true] [(not (eq? cond-arg no-val)) cond-arg] [(not (eq? cond-kwarg no-val)) cond-kwarg])) - (new class [type type] [condition condition])) + (new (generate-subclass xoptional% pre-proc post-proc) [type type] [condition condition])) diff --git a/xenomorph/xenomorph/pointer.rkt b/xenomorph/xenomorph/pointer.rkt index 0089ed73..298ba8cf 100644 --- a/xenomorph/xenomorph/pointer.rkt +++ b/xenomorph/xenomorph/pointer.rkt @@ -26,19 +26,19 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (define xpointer% (class xenobase% (super-new) - (init-field [(@offset-type offset-type)][(@type type)] [(@options options)]) - - (define pointer-relative-to (dict-ref @options 'relative-to)) - (define allow-null (dict-ref @options 'allowNull)) - (define null-value (dict-ref @options 'nullValue)) - (define pointer-lazy? (dict-ref @options 'lazy)) + (init-field [(@offset-type offset-type)] + [(@type type)] + [(@pointer-relative-to pointer-relative-to)] + [(@allow-null? allow-null?)] + [(@null-value null-value)] + [(@pointer-lazy? pointer-lazy?)]) (define/augment (xxdecode port parent) (define offset (send @offset-type xxdecode port parent)) (cond - [(and allow-null (= offset null-value)) #f] ; handle null pointers + [(and @allow-null? (= offset @null-value)) #f] ; handle null pointers [else - (define relative (+ (case pointer-relative-to + (define relative (+ (case @pointer-relative-to [(local) (dict-ref parent '_startOffset)] [(immediate) (- (pos port) (send @offset-type xxsize))] [(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)] @@ -52,7 +52,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (begin0 (send @type xxdecode port parent) (pos port orig-pos))) - (if pointer-lazy? (delay (decode-value)) (decode-value))] + (if @pointer-lazy? (delay (decode-value)) (decode-value))] [else ptr])])) (define/augment (xxencode val-in port [parent #f]) @@ -60,12 +60,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (raise-argument-error 'xpointer-encode "valid pointer context" parent)) (cond [val-in - (define new-parent (case pointer-relative-to + (define new-parent (case @pointer-relative-to [(local immediate) parent] [(parent) (dict-ref parent 'parent)] [(global) (find-top-parent parent)] [else (error 'unknown-pointer-style)])) - (define relative (+ (case pointer-relative-to + (define relative (+ (case @pointer-relative-to [(local parent) (dict-ref new-parent 'startOffset)] [(immediate) (+ (pos port) (send @offset-type xxsize val-in parent))] [(global) 0]))) @@ -75,10 +75,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (λ (ptrs) (append ptrs (list (mhasheq 'type type 'val val 'parent parent))))) (dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (send type xxsize val parent)))] - [else (send @offset-type xxencode null-value port)])) + [else (send @offset-type xxencode @null-value port)])) (define/augment (xxsize [val-in #f] [parent #f]) - (define new-parent (case pointer-relative-to + (define new-parent (case @pointer-relative-to [(local immediate) parent] [(parent) (dict-ref parent 'parent)] [(global) (find-top-parent parent)] @@ -93,24 +93,23 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (define (+xpointer [offset-arg #f] [type-arg #f] #:offset-type [offset-kwarg #f] #:type [type-kwarg #f] - #:relative-to [relative-to 'local] - #:lazy [lazy? #f] + #:relative-to [pointer-relative-to 'local] + #:lazy [pointer-lazy? #f] #:allow-null [allow-null? #t] #:null [null-value 0] - #:subclass [class xpointer%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define valid-pointer-relatives '(local immediate parent global)) - (unless (memq relative-to valid-pointer-relatives) - (raise-argument-error '+xpointer (format "~v" valid-pointer-relatives) relative-to)) - (define options (mhasheq 'relative-to relative-to - 'lazy lazy? - 'allowNull allow-null? - 'nullValue null-value)) + (unless (memq pointer-relative-to valid-pointer-relatives) + (raise-argument-error '+xpointer (format "~v" valid-pointer-relatives) pointer-relative-to)) (define type-in (or type-arg type-kwarg uint8)) - (new class + (new (generate-subclass xpointer% pre-proc post-proc) [offset-type (or offset-arg offset-kwarg uint8)] [type (case type-in [(void) #f][else type-in])] - [options options])) - + [pointer-relative-to pointer-relative-to] + [pointer-lazy? pointer-lazy?] + [allow-null? allow-null?] + [null-value null-value])) ;; A pointer whose type is determined at decode time (define xvoid-pointer% (class xenobase% diff --git a/xenomorph/xenomorph/reserved.rkt b/xenomorph/xenomorph/reserved.rkt index 17d640cd..aca0c88b 100644 --- a/xenomorph/xenomorph/reserved.rkt +++ b/xenomorph/xenomorph/reserved.rkt @@ -28,7 +28,8 @@ https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee (define (+xreserved [type-arg #f] [count-arg #f] #:type [type-kwarg #f] #:count [count-kwarg #f] - #:subclass [class xreserved%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define type (or type-arg type-kwarg)) (define count (or count-arg count-kwarg 1)) - (new class [type type] [count count])) \ No newline at end of file + (new (generate-subclass xreserved% pre-proc post-proc) [type type] [count count])) \ No newline at end of file diff --git a/xenomorph/xenomorph/string.rkt b/xenomorph/xenomorph/string.rkt index a3f7fb66..5c6c1cf9 100644 --- a/xenomorph/xenomorph/string.rkt +++ b/xenomorph/xenomorph/string.rkt @@ -79,10 +79,11 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (define (+xstring [len-arg #f] [enc-arg #f] #:length [len-kwarg #f] #:encoding [enc-kwarg #f] - #:subclass [class xstring%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define len (or len-arg len-kwarg)) (define encoding (or enc-arg enc-kwarg 'ascii)) - (new class [len len] [encoding encoding])) + (new (generate-subclass xstring% pre-proc post-proc) [len len] [encoding encoding])) (define xsymbol% (class xstring% @@ -99,10 +100,11 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (define (+xsymbol [len-arg #f] [enc-arg #f] #:length [len-kwarg #f] #:encoding [enc-kwarg #f] - #:subclass [class xsymbol%]) + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) (define len (or len-arg len-kwarg)) (define encoding (or enc-arg enc-kwarg 'utf8)) - (new class [len len] [encoding encoding])) + (new (generate-subclass xsymbol% pre-proc post-proc) [len len] [encoding encoding])) (module+ test (require rackunit "generic.rkt") diff --git a/xenomorph/xenomorph/struct.rkt b/xenomorph/xenomorph/struct.rkt index ee22632e..0385dcc8 100644 --- a/xenomorph/xenomorph/struct.rkt +++ b/xenomorph/xenomorph/struct.rkt @@ -42,7 +42,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define h (make-hasheq)) (for ([(k v) (in-dict x)] #:unless (memq k private-keys)) - (hash-set! h k v)) + (hash-set! h k v)) h) (define xstruct% @@ -79,9 +79,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee 'pointerSize 0)) (dict-set! parent 'pointerOffset (+ (pos port) (xxsize val parent #f))) (for ([(key type) (in-dict @fields)]) - (send type xxencode (dict-ref val key) port parent)) + (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)))) + (send (dict-ref ptr 'type) xxencode (dict-ref ptr 'val) port (dict-ref ptr 'parent)))) (define/augride (xxsize [val #f] [parent-arg #f] [include-pointers #t]) (define parent (mhasheq 'parent parent-arg @@ -89,36 +89,37 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee 'pointerSize 0)) (define fields-size (for/sum ([(key type) (in-dict @fields)] #:when (xenomorphic-type? type)) - (send type xxsize (and val (dict-ref val key)) parent))) + (send type xxsize (and val (dict-ref val key)) parent))) (define pointers-size (if include-pointers (dict-ref parent 'pointerSize) 0)) (+ fields-size pointers-size)))) (define (xstruct? x) (is-a? x xstruct%)) -(define (+xstruct #:subclass [class xstruct%] . dicts) +(define (+xstruct #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f] . 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))) - (new class [fields fields])) + (unless (symbol? (car kv)) + (raise-argument-error '+xstruct "symbol" (car kv))) + (apply cons kv))) + (new (generate-subclass xstruct% pre-proc post-proc) [fields fields])) (module+ test (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/array-test.rkt b/xenomorph/xenomorph/test/array-test.rkt index c1ae7375..47881fa2 100644 --- a/xenomorph/xenomorph/test/array-test.rkt +++ b/xenomorph/xenomorph/test/array-test.rkt @@ -20,10 +20,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (test-case "decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (define myarray% (class xarray% - (super-new) - (define/override (post-decode val) (map (λ (x) (* 2 x)) val)))) - (define xa (+xarray #:type uint8 #:length 4 #:subclass myarray%)) + (define xa (+xarray #:type uint8 #:length 4 #:post-decode (λ (val) (map (λ (x) (* 2 x)) val)))) (check-equal? (decode xa) '(2 4 6 8)))) (test-case @@ -95,10 +92,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (test-case "encode with pre-encode" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (define myarray% (class xarray% - (super-new) - (define/override (pre-encode val) (map (λ (x) (* 2 x)) val)))) - (define xa (+xarray #:type uint8 #:length 4 #:subclass myarray%)) + (define xa (+xarray #:type uint8 #:length 4 #:pre-encode (λ (val) (map (λ (x) (* 2 x)) val)))) (check-equal? (encode xa '(1 2 3 4) #f) (bytes 2 4 6 8)))) (test-case diff --git a/xenomorph/xenomorph/test/bitfield-test.rkt b/xenomorph/xenomorph/test/bitfield-test.rkt index 7e0b7059..fb776568 100644 --- a/xenomorph/xenomorph/test/bitfield-test.rkt +++ b/xenomorph/xenomorph/test/bitfield-test.rkt @@ -36,10 +36,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee (test-case "bitfield should decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))]) - (define mybitfield% (class xbitfield% - (super-new) - (define/override (post-decode fh) (hash-set! fh 'foo 42) fh))) - (define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) #:subclass mybitfield%)) + (define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) #:post-decode (λ (fh) (hash-set! fh 'foo 42) fh))) (check-equal? (decode bitfield) (mhasheq 'Quack #t 'Nack #t 'Lack #f @@ -64,14 +61,12 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee (test-case "bitfield should encode with pre-encode" - (define mybitfield% (class xbitfield% - (super-new) - (define/override (pre-encode fh) - (hash-set! fh 'Jack #f) - (hash-set! fh 'Mack #f) - (hash-set! fh 'Pack #f) - fh))) - (define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) #:subclass mybitfield%)) + (define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) + #:pre-encode (λ (fh) + (hash-set! fh 'Jack #f) + (hash-set! fh 'Mack #f) + (hash-set! fh 'Pack #f) + fh))) (check-equal? (encode bitfield (mhasheq 'Quack #t 'Nack #t 'Lack #f diff --git a/xenomorph/xenomorph/test/buffer-test.rkt b/xenomorph/xenomorph/test/buffer-test.rkt index 591ed059..5bfb4372 100644 --- a/xenomorph/xenomorph/test/buffer-test.rkt +++ b/xenomorph/xenomorph/test/buffer-test.rkt @@ -24,10 +24,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Buffer.coffee (test-case "buffer should decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))]) - (define myboof% (class xbuffer% - (super-new) - (define/override (post-decode val) (bytes 1 2)))) - (define buf (+xbuffer #:length 2 #:subclass myboof%)) + (define buf (+xbuffer #:length 2 #:post-decode (λ (val) (bytes 1 2)))) (check-equal? (decode buf) (bytes 1 2)) (check-equal? (decode buf) (bytes 1 2)))) @@ -56,10 +53,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Buffer.coffee (test-case "encode should encode with pre-encode" (let () - (define myboof% (class xbuffer% - (super-new) - (define/override (pre-encode val) (bytes 1 2)))) - (define buf (+xbuffer 2 #:subclass myboof%)) + (define buf (+xbuffer 2 #:pre-encode (λ (val) (bytes 1 2)))) (check-equal? (bytes-append (encode buf (bytes #xab #xff) #f) (encode buf (bytes #x1f #xb6) #f)) (bytes 1 2 1 2)))) diff --git a/xenomorph/xenomorph/test/enum-test.rkt b/xenomorph/xenomorph/test/enum-test.rkt index 5b54b96e..58af4f77 100644 --- a/xenomorph/xenomorph/test/enum-test.rkt +++ b/xenomorph/xenomorph/test/enum-test.rkt @@ -35,12 +35,9 @@ https://github.com/mbutterick/restructure/blob/master/test/Enum.coffee (test-case "decode should decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))]) - (define myenum% (class xenum% - (super-new) - (define/override (post-decode val) "foobar"))) (define e2 (+xenum #:type uint8 #:values '("foo" "bar" "baz") - #:subclass myenum%)) + #:post-decode (λ (val) "foobar"))) (check-equal? (decode e2) "foobar") (check-equal? (decode e2) "foobar") (check-equal? (decode e2) "foobar"))) @@ -56,12 +53,9 @@ https://github.com/mbutterick/restructure/blob/master/test/Enum.coffee (test-case "encode should encode with pre-encode" (parameterize ([current-output-port (open-output-bytes)]) - (define myenum% (class xenum% - (super-new) - (define/override (pre-encode val) "foo"))) (define e2 (+xenum #:type uint8 #:values '("foo" "bar" "baz") - #:subclass myenum%)) + #:pre-encode (λ (val) "foo"))) (encode e2 "bar") (encode e2 "baz") (encode e2 "foo") diff --git a/xenomorph/xenomorph/test/lazy-array-test.rkt b/xenomorph/xenomorph/test/lazy-array-test.rkt index b7db4755..df53fd88 100644 --- a/xenomorph/xenomorph/test/lazy-array-test.rkt +++ b/xenomorph/xenomorph/test/lazy-array-test.rkt @@ -28,10 +28,7 @@ https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee (test-case "decode should decode items lazily with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (define myxla% (class xlazy-array% - (super-new) - (define/override (post-decode str) (stream-map (λ (i) (* 2 i)) str)))) - (define xla (+xlazy-array uint8 4 #:subclass myxla%)) + (define xla (+xlazy-array uint8 4 #:post-decode (λ (str) (stream-map (λ (i) (* 2 i)) str)))) (define arr (decode xla)) (check-false (xarray? arr)) (check-equal? (stream-length arr) 4) @@ -72,9 +69,6 @@ https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee (test-case "encode should work with xlazy-arrays with pre-encode" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (define myxla% (class xlazy-array% - (super-new) - (define/override (pre-encode str) (stream-map (λ (val) (* 2 val)) str)))) - (define xla (+xlazy-array uint8 4 #:subclass myxla%)) + (define xla (+xlazy-array uint8 4 #:pre-encode (λ (str) (stream-map (λ (val) (* 2 val)) str)))) (define arr (decode xla)) (check-equal? (encode xla arr #f) (bytes 2 4 6 8)))) diff --git a/xenomorph/xenomorph/test/number-test.rkt b/xenomorph/xenomorph/test/number-test.rkt index ac105d6b..c1948b89 100644 --- a/xenomorph/xenomorph/test/number-test.rkt +++ b/xenomorph/xenomorph/test/number-test.rkt @@ -22,11 +22,9 @@ https://github.com/mbutterick/restructure/blob/master/test/Number.coffee (test-case "uint8: decode with post-decode, size, encode with pre-encode" - (define myuint8% (class xint% - (super-new) - (define/override (post-decode int) #xdeadbeef) - (define/override (pre-encode val) #xcc))) - (define myuint8 (+xint 1 #:signed #f #:subclass myuint8%)) + (define myuint8 (+xint 1 #:signed #f + #:post-decode (λ (val) #xdeadbeef) + #:pre-encode (λ (val) #xcc))) (parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))]) (check-equal? (decode myuint8) #xdeadbeef) (check-equal? (decode myuint8) #xdeadbeef)) diff --git a/xenomorph/xenomorph/test/optional-test.rkt b/xenomorph/xenomorph/test/optional-test.rkt index 35cd625e..34ad132f 100644 --- a/xenomorph/xenomorph/test/optional-test.rkt +++ b/xenomorph/xenomorph/test/optional-test.rkt @@ -21,10 +21,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee (test-case "decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes 0))]) - (define myxopt% (class xoptional% - (super-new) - (define/override (post-decode val) 42))) - (define optional (+xoptional #:type uint8 #:condition #f #:subclass myxopt%)) + (define optional (+xoptional #:type uint8 #:condition #f #:post-decode (λ (val) 42))) (check-equal? (decode optional) 42) (check-equal? (pos (current-input-port)) 0))) @@ -86,10 +83,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee (test-case "encode with pre-encode" (parameterize ([current-output-port (open-output-bytes)]) - (define myxopt% (class xoptional% - (super-new) - (define/override (pre-encode val) 42))) - (define optional (+xoptional #:type uint8 #:subclass myxopt%)) + (define optional (+xoptional #:type uint8 #:pre-encode (λ (val) 42))) (encode optional 128) (check-equal? (get-output-bytes (current-output-port)) (bytes 42)))) diff --git a/xenomorph/xenomorph/test/reserved-test.rkt b/xenomorph/xenomorph/test/reserved-test.rkt index fc15e251..6f638feb 100644 --- a/xenomorph/xenomorph/test/reserved-test.rkt +++ b/xenomorph/xenomorph/test/reserved-test.rkt @@ -29,10 +29,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Reserved.coffee (test-case "should decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes 0 0))]) - (define myxres% (class xreserved% - (super-new) - (define/override (post-decode val) 42))) - (define reserved (+xreserved uint16be #:subclass myxres%)) + (define reserved (+xreserved uint16be #:post-decode (λ (val) 42))) (check-equal? (decode reserved) 42) (check-equal? (pos (current-input-port)) 2))) @@ -46,9 +43,6 @@ https://github.com/mbutterick/restructure/blob/master/test/Reserved.coffee (test-case "should encode with pre-encode" (parameterize ([current-output-port (open-output-bytes)]) - (define myxres% (class xreserved% - (super-new) - (define/override (pre-encode val) 42))) - (define reserved (+xreserved uint32be #:subclass myxres%)) + (define reserved (+xreserved uint32be #:pre-encode (λ (val) 42))) (encode reserved #f) (check-equal? (get-output-bytes (current-output-port)) (bytes 0 0 0 0)))) \ No newline at end of file diff --git a/xenomorph/xenomorph/test/string-test.rkt b/xenomorph/xenomorph/test/string-test.rkt index d21b9bfb..be8f38c5 100644 --- a/xenomorph/xenomorph/test/string-test.rkt +++ b/xenomorph/xenomorph/test/string-test.rkt @@ -20,10 +20,7 @@ https://github.com/mbutterick/restructure/blob/master/test/String.coffee (test-case "decode fixed length with post-decode" (parameterize ([current-input-port (open-input-bytes #"testing")]) - (define mystr% (class xstring% - (super-new) - (define/override (post-decode val) "ring a ding"))) - (define xs (+xstring 7 #:subclass mystr%)) + (define xs (+xstring 7 #:post-decode (λ (val) "ring a ding"))) (check-equal? (decode xs) "ring a ding"))) (test-case @@ -92,10 +89,7 @@ https://github.com/mbutterick/restructure/blob/master/test/String.coffee (test-case "encode using string length and pre-encode" (parameterize ([current-output-port (open-output-bytes)]) - (define mystr% (class xstring% - (super-new) - (define/override (pre-encode val) (list->string (reverse (string->list val)))))) - (define xs (+xstring 7 #:subclass mystr%)) + (define xs (+xstring 7 #:pre-encode (λ (val) (list->string (reverse (string->list val)))))) (encode xs "testing") (check-equal? (get-output-bytes (current-output-port)) #"gnitset"))) diff --git a/xenomorph/xenomorph/test/struct-test.rkt b/xenomorph/xenomorph/test/struct-test.rkt index 02baba22..1b98b200 100644 --- a/xenomorph/xenomorph/test/struct-test.rkt +++ b/xenomorph/xenomorph/test/struct-test.rkt @@ -24,10 +24,8 @@ 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 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)) + (define struct (+xstruct #:post-decode (λ (o) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o) + 'name (+xstring #:length uint8) 'age uint8)) (check-equal? (decode struct) (mhasheq 'name "roxyb" 'age 32 'canDrink #t)))) @@ -67,11 +65,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (test-case "support pre-encode hook" (parameterize ([current-output-port (open-output-bytes)]) - (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% + (define struct (+xstruct #:pre-encode (λ (val) + (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val) 'nameLength uint8 'name (+xstring 'nameLength) 'age uint8)) diff --git a/xenomorph/xenomorph/versioned-struct.rkt b/xenomorph/xenomorph/versioned-struct.rkt index 2667a36a..a1a35b6f 100644 --- a/xenomorph/xenomorph/versioned-struct.rkt +++ b/xenomorph/xenomorph/versioned-struct.rkt @@ -16,7 +16,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (init-field [(@type type)] [(@versions versions)]) (unless (for/or ([proc (list integer? procedure? xenomorphic-type? 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) (xstruct? v))) (dict-values @versions))) (raise-argument-error '+xversioned-struct "dict of dicts or structish" @versions)) @@ -72,15 +72,15 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (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))) + (send type xxencode (dict-ref encode-me key) port parent))) (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)) + (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)))) + (send (dict-ref ptr 'type) xxencode (dict-ref ptr 'val) port (dict-ref ptr 'parent)))) (define/override (xxsize [val #f] [parent-arg #f] [include-pointers #t]) (unless val @@ -93,15 +93,17 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (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))) + (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))) + (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)))) (define (xversioned-struct? x) (is-a? x xversioned-struct%)) -(define (+xversioned-struct #:subclass [class xversioned-struct%] type [versions (dictify)]) - (new class [type type] [versions versions][fields #f])) +(define (+xversioned-struct type [versions (dictify)] + #:pre-encode [pre-proc #f] + #:post-decode [post-proc #f]) + (new (generate-subclass xversioned-struct% pre-proc post-proc) [type type] [versions versions][fields #f]))