diff --git a/xenomorph/xenomorph/pointer.rkt b/xenomorph/xenomorph/pointer.rkt index a0060bf7..9074dd4a 100644 --- a/xenomorph/xenomorph/pointer.rkt +++ b/xenomorph/xenomorph/pointer.rkt @@ -23,13 +23,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (cond [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers [else - (define relative (+ (case (pointer-style xp) + (define relative (+ (case (pointer-relative-to 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))) + [else (error 'unknown-pointer-style)]))) (define ptr (+ offset relative)) (cond [(xpointer-type xp) @@ -61,16 +60,15 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (parameterize ([current-output-port port]) (if (not val) (encode (xpointer-offset-type xp) (null-value xp) port) - (let* ([new-parent (case (pointer-style xp) + (let* ([new-parent (case (pointer-relative-to xp) [(local immediate) parent] [(parent) (dict-ref parent 'parent)] [(global) (find-top-parent parent)] [else (error 'unknown-pointer-style)])] - [relative (+ (case (pointer-style xp) + [relative (+ (case (pointer-relative-to 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)))]) + [(global) 0]))]) (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) @@ -81,7 +79,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (unless port-arg (get-output-bytes port))) (define (xpointer-size xp [val #f] #:parent [parent #f]) - (let*-values ([(parent) (case (pointer-style xp) + (let*-values ([(parent) (case (pointer-relative-to xp) [(local immediate) parent] [(parent) (dict-ref parent 'parent)] [(global) (find-top-parent parent)] @@ -101,16 +99,14 @@ 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] - #:style [style 'local] - #:relative-to [relative-to #f] + #:relative-to [relative-to 'local] #: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 + (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)) @@ -118,11 +114,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (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) (dict-ref (xpointer-options xp) 'style)) +(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)) -(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 (struct xvoid-pointer (type value) #:transparent) diff --git a/xenomorph/xenomorph/test/pointer-test.rkt b/xenomorph/xenomorph/test/pointer-test.rkt index 1178b8f8..c3d1f53c 100644 --- a/xenomorph/xenomorph/test/pointer-test.rkt +++ b/xenomorph/xenomorph/test/pointer-test.rkt @@ -26,30 +26,23 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (test-case "decode should support immediate offsets" (parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) - (check-equal? (decode (+xpointer #:style 'immediate)) 53))) + (check-equal? (decode (+xpointer #:relative-to '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 #:style 'parent) + (check-equal? (decode (+xpointer #:relative-to '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 #:style 'global) + (check-equal? (decode (+xpointer #:relative-to '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 #:relative-to (λ (parent) (dict-ref (dict-ref parent 'parent) 'ptr))) - #:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4))) - 53))) - (test-case "decode should support returning pointer if there is no decode type" (parameterize ([current-input-port (open-input-bytes (bytes 4))]) @@ -72,19 +65,19 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (test-case "size should add to immediate pointerSize" (let ([parent (mhash 'pointerSize 0)]) - (check-equal? (size (+xpointer #:style 'immediate) 10 #:parent parent) 1) + (check-equal? (size (+xpointer #:relative-to '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 #:style 'parent) 10 #:parent parent) 1) + (check-equal? (size (+xpointer #:relative-to '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 #:style 'global) 10 #:parent parent) 1) + (check-equal? (size (+xpointer #:relative-to 'global) 10 #:parent parent) 1) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerSize) 1))) (test-case @@ -134,7 +127,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 0 'pointerOffset 1 'pointers null)) - (encode (+xpointer #:style 'immediate) 10 #:parent parent) + (encode (+xpointer #:relative-to '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 +141,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 3 'pointerOffset 5 'pointers null))) - (encode (+xpointer #:style 'parent) 10 #:parent parent) + (encode (+xpointer #:relative-to '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 +157,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'startOffset 3 'pointerOffset 5 'pointers null))))) - (encode (+xpointer #:style 'global) 10 #:parent parent) + (encode (+xpointer #:relative-to '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 @@ -172,21 +165,6 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'parent parent))) (check-equal? (dump (current-output-port)) (bytes 5)))) -(test-case - "encode should support offsets relative to a property on the parent" - (parameterize ([current-output-port (open-output-bytes)]) - (define parent (mhash 'pointerSize 0 - 'startOffset 0 - 'pointerOffset 10 - 'pointers null - 'val (mhash 'ptr 4))) - (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 - 'parent parent))) - (check-equal? (dump (current-output-port)) (bytes 6)))) - (test-case "encode should support void pointers" (parameterize ([current-output-port (open-output-bytes)])