diff --git a/xenomorph/xenomorph/array.rkt b/xenomorph/xenomorph/array.rkt index 3361c6a9..66c80d78 100644 --- a/xenomorph/xenomorph/array.rkt +++ b/xenomorph/xenomorph/array.rkt @@ -1,5 +1,11 @@ #lang debug racket/base -(require racket/dict racket/sequence "helper.rkt" "number.rkt" "util.rkt" sugar/unstable/dict) +(require racket/dict + racket/class + racket/sequence + "helper.rkt" + "number.rkt" + "util.rkt" + sugar/unstable/dict) (provide (all-defined-out)) #| @@ -7,94 +13,96 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Array.coffee |# -(define/post-decode (xarray-decode xa [port-arg (current-input-port)] #:parent [parent #f]) - (define port (->input-port port-arg)) - (parameterize ([current-input-port port]) - (define new-parent (if (xint? (xarray-base-len xa)) - (mhasheq 'parent parent - '_startOffset (pos port) - '_currentOffset 0 - '_length (xarray-base-len xa)) - parent)) - (define decoded-len (resolve-length (xarray-base-len xa) #:parent parent)) - (cond - [(or (not decoded-len) (eq? (xarray-length-type xa) 'bytes)) - (define end-pos (cond - ;; decoded-len is byte length - [decoded-len (+ (pos port) decoded-len)] - ;; no decoded-len, but parent has length - [(and parent (not (zero? (dict-ref parent '_length)))) (+ (dict-ref parent '_startOffset) (dict-ref parent '_length))] - ;; no decoded-len or parent, so consume whole stream - [else +inf.0])) - (for/list ([i (in-naturals)] - #:break (or (eof-object? (peek-byte)) (= (pos port) end-pos))) - (xdecode (xarray-base-type xa) #:parent new-parent))] - ;; we have decoded-len, which is treated as count of items - [else (for/list ([i (in-range decoded-len)]) - (xdecode (xarray-base-type xa) #:parent new-parent))]))) +(define xarray-base% + (class* xenobase% () + (super-new) + (init-field type len) + (unless (xenomorphic? type) + (raise-argument-error '+xarray "xenomorphic type" type)) + (unless (length-resolvable? len) + (raise-argument-error '+xarray "length-resolvable?" len)))) -(define/pre-encode (xarray-encode xa array [port-arg (current-output-port)] #:parent [parent #f]) - (unless (sequence? array) - (raise-argument-error 'xarray-encode "sequence" array)) - (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (parameterize ([current-output-port port]) - (define (encode-items parent) - ;; todo: should array with fixed length stop encoding after it reaches max? - ;; cf. xstring, which rejects input that is too big for fixed length. - (let* (#;[items (sequence->list array)] - #;[item-count (length items)] - #;[max-items (if (number? (xarray-len xa)) (xarray-len xa) item-count)]) - (for ([item array]) - (encode (xarray-base-type xa) item #:parent parent)))) - (cond - [(xint? (xarray-base-len xa)) - (let ([parent (mhash 'pointers null - 'startOffset (pos port) - 'parent parent)]) - (dict-set! parent 'pointerOffset (+ (pos port) (size xa array #:parent parent))) - (encode (xarray-base-len xa) (length array)) ; encode length at front - (encode-items parent) - (for ([ptr (in-list (dict-ref parent 'pointers))]) ; encode pointer data at end - (encode (dict-ref ptr 'type) (dict-ref ptr 'val))))] - [else (encode-items parent)]) - (unless port-arg (get-output-bytes port)))) +(define xarray% + (class* xarray-base% () + (super-new) + (init-field length-type) + (unless (memq length-type '(bytes count)) + (raise-argument-error '+xarray "'bytes or 'count" length-type)) -(define/finalize-size (xarray-size xa [val #f] #:parent [parent #f]) - (when val (unless (sequence? val) - (raise-argument-error 'xarray-size "sequence" val))) - (cond - [val (define-values (new-parent len-size) (if (xint? (xarray-base-len xa)) - (values (mhasheq 'parent parent) (size (xarray-base-len xa))) - (values parent 0))) - (define items-size (for/sum ([item val]) - (size (xarray-base-type xa) item #:parent new-parent))) - (+ items-size len-size)] - [else (define item-count (resolve-length (xarray-base-len xa) #f #:parent parent)) - (define item-size (size (xarray-base-type xa) #f #:parent parent)) - (* item-size item-count)])) + (inherit-field type len) -(struct xarray-base xbase (type len) #:transparent) -(struct xarray xarray-base (length-type) #:transparent - #:methods gen:xenomorphic - [(define decode xarray-decode) - (define xdecode xarray-decode) - (define encode xarray-encode) - (define size xarray-size)]) + (define/augment (xxdecode port parent . _) + (define new-parent (if (xint? len) + (mhasheq 'parent parent + '_startOffset (pos port) + '_currentOffset 0 + '_length len) + parent)) + (define decoded-len (resolve-length len #:parent parent)) + (cond + [(or (not decoded-len) (eq? length-type 'bytes)) + (define end-pos (cond + ;; decoded-len is byte length + [decoded-len (+ (pos port) decoded-len)] + ;; no decoded-len, but parent has length + [(and parent (not (zero? (dict-ref parent '_length)))) + (+ (dict-ref parent '_startOffset) (dict-ref parent '_length))] + ;; no decoded-len or parent, so consume whole stream + [else +inf.0])) + (for/list ([i (in-naturals)] + #:break (or (eof-object? (peek-byte)) (= (pos port) end-pos))) + (send type xxdecode port new-parent))] + ;; we have decoded-len, which is treated as count of items + [else (for/list ([i (in-range decoded-len)]) + (send type xxdecode port new-parent))])) + + (define/augment (xxencode array port [parent #f]) + (unless (sequence? array) + (raise-argument-error 'xarray-encode "sequence" array)) + (define (encode-items parent) + ;; todo: should array with fixed length stop encoding after it reaches max? + ;; cf. xstring, which rejects input that is too big for fixed length. + (let* (#;[items (sequence->list array)] + #;[item-count (length items)] + #;[max-items (if (number? (xarray-len xa)) (xarray-len xa) item-count)]) + (for ([item array]) + (send type xxencode item port parent)))) + (cond + [(xint? len) + (let ([parent (mhash 'pointers null + 'startOffset (pos port) + 'parent parent)]) + (dict-set! parent 'pointerOffset (+ (pos port) (xxsize array parent))) + (send len xxencode (length array) port) ; encode length at front + (encode-items parent) + (for ([ptr (in-list (dict-ref parent 'pointers))]) ; encode pointer data at end + (send (dict-ref ptr 'type) xxencode (dict-ref ptr 'val) port)))] + [else (encode-items parent)])) + + (define/augment (xxsize [val #f] [parent #f]) + (when val (unless (sequence? val) + (raise-argument-error 'xarray-size "sequence" val))) + (cond + [val (define-values (new-parent len-size) + (if (xint? len) + (values (mhasheq 'parent parent) (send len xxsize)) + (values parent 0))) + (define items-size (for/sum ([item val]) + (send type xxsize item new-parent))) + (+ items-size len-size)] + [else (define item-count (resolve-length len #f #:parent parent)) + (define item-size (send type xxsize #f parent)) + (* item-size item-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) - (raise-argument-error '+xarray "length-resolvable?" len)) - (unless (memq length-type '(bytes count)) - (raise-argument-error '+xarray "'bytes or 'count" length-type)) - (xarray type len length-type)) + #:type [type-kwarg #f] + #:length [len-kwarg #f] + #:count-bytes [count-bytes? #f] + #:subclass [class xarray%]) + (new class [type (or type-arg type-kwarg)] + [len (or len-arg len-kwarg)] + [length-type (if count-bytes? 'bytes length-type-arg)])) - (module+ test (require rackunit) (check-equal? (decode (+xarray uint16be 3) #"ABCDEF") '(16706 17220 17734)) diff --git a/xenomorph/xenomorph/pointer.rkt b/xenomorph/xenomorph/pointer.rkt index 4cc26934..d60093a1 100644 --- a/xenomorph/xenomorph/pointer.rkt +++ b/xenomorph/xenomorph/pointer.rkt @@ -2,6 +2,7 @@ (require "helper.rkt" "number.rkt" racket/dict + racket/class racket/promise sugar/unstable/dict) (provide (all-defined-out)) @@ -16,7 +17,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee [(dict-ref parent 'parent #f) => find-top-parent] [else parent])) -(define/post-decode (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f]) +#;(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 (xdecode (xpointer-offset-type xp) #:parent parent)) @@ -53,7 +54,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee [(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))] [else (raise-argument-error 'Pointer:size "VoidPointer" val)])) -(define/pre-encode (xpointer-encode xp val [port-arg (current-output-port)] #:parent [parent #f]) +#;(define/pre-encode (xpointer-encode xp val [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) (unless parent ; todo: furnish default pointer context? adapt from Struct? (raise-argument-error 'xpointer-encode "valid pointer context" parent)) @@ -78,7 +79,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (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]) +#;(define (xpointer-size xp [val #f] #:parent [parent #f]) (let*-values ([(parent) (case (pointer-relative-to xp) [(local immediate) parent] [(parent) (dict-ref parent 'parent)] @@ -90,7 +91,20 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (+ (dict-ref parent 'pointerSize) (size type val #:parent parent))))) (size (xpointer-offset-type xp)))) -(struct xpointer xbase (offset-type type options) #:transparent +(define xpointer% + (class* xenobase% () + (super-new) + (init-field offset-type type 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)) + + + )) + +#;(struct xpointer xbase (offset-type type options) #:transparent #:methods gen:xenomorphic [(define decode xpointer-decode) (define xdecode xpointer-decode) @@ -111,14 +125,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee '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)) + (new xpointer% + [offset-type (or offset-arg offset-kwarg uint8)] + [type (case type-in [(void) #f][else type-in])] + [options options])) -(define (pointer-relative-to xp) (dict-ref (xpointer-options xp) 'relative-to)) -(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)) ;; A pointer whose type is determined at decode time (struct xvoid-pointer (type value) #:transparent) diff --git a/xenomorph/xenomorph/test/array-test.rkt b/xenomorph/xenomorph/test/array-test.rkt index 20889f1f..fb31930c 100644 --- a/xenomorph/xenomorph/test/array-test.rkt +++ b/xenomorph/xenomorph/test/array-test.rkt @@ -1,5 +1,6 @@ #lang racket/base (require rackunit + racket/class "../helper.rkt" "../array.rkt" "../number.rkt" @@ -19,8 +20,10 @@ 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 xa (+xarray #:type uint8 #:length 4)) - (set-post-decode! xa (λ (val . _) (map (λ (x) (* 2 x)) val))) + (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%)) (check-equal? (decode xa) '(2 4 6 8)))) (test-case @@ -31,12 +34,12 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (test-case "decode length from parent key" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (check-equal? (xdecode (+xarray #:type uint8 #:length 'len) #:parent (mhash 'len 4)) '(1 2 3 4)))) + (check-equal? (send (+xarray #:type uint8 #:length 'len) xxdecode (current-input-port) (mhash 'len 4)) '(1 2 3 4)))) (test-case "decode byte count from parent key" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (check-equal? (xdecode (+xarray #:type uint16be #:length 'len #:count-bytes #t) #:parent (mhash 'len 4)) '(258 772)))) + (check-equal? (send (+xarray #:type uint16be #:length 'len #:count-bytes #t) xxdecode (current-input-port) (mhash 'len 4)) '(258 772)))) (test-case "decode length as number before array" @@ -61,12 +64,12 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (test-case "decode to the end of parent if no length given" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (check-equal? (xdecode (+xarray #:type uint8) #:parent (mhash '_length 4 '_startOffset 0)) '(1 2 3 4)))) + (check-equal? (send (+xarray #:type uint8) xxdecode (current-input-port) (mhash '_length 4 '_startOffset 0)) '(1 2 3 4)))) (test-case "decode to the end of the stream if parent exists, but its length is 0" (parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))]) - (check-equal? (xdecode (+xarray #:type uint8) #:parent (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5)))) + (check-equal? (send (+xarray #:type uint8) xxdecode (current-input-port) (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5)))) (test-case "decode to the end of the stream if no parent and length is given" @@ -92,8 +95,10 @@ 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 xa (+xarray #:type uint8 #:length 4)) - (set-pre-encode! xa (λ (val . _) (map (λ (x) (* 2 x)) val))) + (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%)) (check-equal? (encode xa '(1 2 3 4) #f) (bytes 2 4 6 8)))) (test-case