mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

support kw args

Browse Source
main
Matthew Butterick 6 years ago
parent cb858bc636
commit 4118c0f1de
10 changed files with 190 additions and 147 deletions
Show Stats Download Patch File Download Diff File

6
xenomorph/xenomorph/redo/array.rkt
Unescape Escape View File

@ -80,7 +80,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(define encode xarray-encode) (define encode xarray-encode)
(define size xarray-size)]) (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) (unless (xenomorphic? type)
(raise-argument-error '+xarray "xenomorphic type" type)) (raise-argument-error '+xarray "xenomorphic type" type))
(unless (length-resolvable? len) (unless (length-resolvable? len)

5
xenomorph/xenomorph/redo/bitfield.rkt
Unescape Escape View File

@ -35,7 +35,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
(define encode xbitfield-encode) (define encode xbitfield-encode)
(define size xbitfield-size)]) (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) (unless (andmap (λ (f) (or (symbol? f) (not f))) flags)
(raise-argument-error '+xbitfield "list of symbols" flags)) (raise-argument-error '+xbitfield "list of symbols" flags))
(xbitfield type flags)) (xbitfield type flags))

5
xenomorph/xenomorph/redo/lazy-array.rkt
Unescape Escape View File

@ -43,7 +43,10 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee
(define encode xlazy-array-encode) (define encode xlazy-array-encode)
(define size xlazy-array-size)]) (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) (unless (xenomorphic? type)
(raise-argument-error '+xarray "xenomorphic type" type)) (raise-argument-error '+xarray "xenomorphic type" type))
(unless (length-resolvable? len) (unless (length-resolvable? len)

134
xenomorph/xenomorph/redo/pointer.rkt
Unescape Escape View File

@ -1,5 +1,6 @@
#lang debug racket/base #lang debug racket/base
(require "helper.rkt" (require "helper.rkt"
"number.rkt"
racket/dict racket/dict
racket/promise racket/promise
sugar/unstable/dict) 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/post-decode (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(define offset (decode (xpointer-offset-type xp) #:parent parent)) (define offset (decode (xpointer-offset-type xp) #:parent parent))
(cond (cond
[(and allow-null (= offset (null-value xp))) #f] ; handle null pointers [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers
[else [else
(define relative (+ (case (pointer-style xp) (define relative (+ (case (pointer-style xp)
[(local) (dict-ref parent '_startOffset)] [(local) (dict-ref parent '_startOffset)]
[(immediate) (- (pos port) (size (xpointer-offset-type xp)))] [(immediate) (- (pos port) (size (xpointer-offset-type xp)))]
[(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)] [(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)]
[(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)] [(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)]
[else (error 'unknown-pointer-style)]) [else (error 'unknown-pointer-style)])
((relative-getter-or-0 xp) parent))) ((relative-getter-or-0 xp) parent)))
(define ptr (+ offset relative)) (define ptr (+ offset relative))
(cond (cond
[(xpointer-type xp) [(xpointer-type xp)
(define val (void)) (define val (void))
(define (decode-value) (define (decode-value)
(cond (cond
[(not (void? val)) val] [(not (void? val)) val]
[else [else
(define orig-pos (pos port)) (define orig-pos (pos port))
(pos port ptr) (pos port ptr)
(set! val (decode (xpointer-type xp) #:parent parent)) (set! val (decode (xpointer-type xp) #:parent parent))
(pos port orig-pos) (pos port orig-pos)
val])) val]))
(if (pointer-lazy? xp) (if (pointer-lazy? xp)
(delay (decode-value)) (delay (decode-value))
(decode-value))] (decode-value))]
[else ptr])]))) [else ptr])])))
(define (resolve-void-pointer type val) (define (resolve-void-pointer type val)
(cond (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? (unless parent ; todo: furnish default pointer context? adapt from Struct?
(raise-argument-error 'xpointer-encode "valid pointer context" parent)) (raise-argument-error 'xpointer-encode "valid pointer context" parent))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(if (not val) (if (not val)
(encode (xpointer-offset-type xp) (null-value xp) port) (encode (xpointer-offset-type xp) (null-value xp) port)
(let* ([new-parent (case (pointer-style xp) (let* ([new-parent (case (pointer-style xp)
[(local immediate) parent] [(local immediate) parent]
[(parent) (dict-ref parent 'parent)] [(parent) (dict-ref parent 'parent)]
[(global) (find-top-parent parent)] [(global) (find-top-parent parent)]
[else (error 'unknown-pointer-style)])] [else (error 'unknown-pointer-style)])]
[relative (+ (case (pointer-style xp) [relative (+ (case (pointer-style xp)
[(local parent) (dict-ref new-parent 'startOffset)] [(local parent) (dict-ref new-parent 'startOffset)]
[(immediate) (+ (pos port) (size (xpointer-offset-type xp) val #:parent parent))] [(immediate) (+ (pos port) (size (xpointer-offset-type xp) val #:parent parent))]
[(global) 0]) [(global) 0])
((relative-getter-or-0 xp) (dict-ref parent 'val #f)))]) ((relative-getter-or-0 xp) (dict-ref parent 'val #f)))])
(encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative)) (encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative))
(let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)]) (let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)])
(dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers) (dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers)
(list (mhasheq 'type type (list (mhasheq 'type type
'val val 'val val
'parent parent)))) 'parent parent))))
(dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type 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))) (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-style xp) (let*-values ([(parent) (case (pointer-style xp)
[(local immediate) parent] [(local immediate) parent]
[(parent) (dict-ref parent 'parent)] [(parent) (dict-ref parent 'parent)]
[(global) (find-top-parent parent)] [(global) (find-top-parent parent)]
[else (error 'unknown-pointer-style)])] [else (error 'unknown-pointer-style)])]
[(type val) (resolve-void-pointer (xpointer-type xp) val)]) [(type val) (resolve-void-pointer (xpointer-type xp) val)])
(when (and val parent) (when (and val parent)
(dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f) (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)))) (size (xpointer-offset-type xp))))
(struct xpointer xbase (offset-type type options) #:transparent (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 encode xpointer-encode)
(define size xpointer-size)]) (define size xpointer-size)])
(define (+xpointer offset-type type-in [options (mhasheq)]) (define (+xpointer [offset-arg #f] [type-arg #f]
(xpointer offset-type (and (not (eq? type-in 'void)) type-in) options)) #: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 (pointer-style xp) (dict-ref (xpointer-options xp) 'style))
(define (allow-null xp) (or (dict-ref (xpointer-options xp) 'allowNull #f) #t)) (define (allow-null xp) (dict-ref (xpointer-options xp) 'allowNull))
(define (null-value xp) (or (dict-ref (xpointer-options xp) 'nullValue #f) 0)) (define (null-value xp) (dict-ref (xpointer-options xp) 'nullValue))
(define (pointer-lazy? xp) (dict-ref (xpointer-options xp) 'lazy #f)) (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 (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 ;; A pointer whose type is determined at decode time

10
xenomorph/xenomorph/redo/string.rkt
Unescape Escape View File

@ -87,7 +87,10 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
(define size xstring-size)]) (define size xstring-size)])
(define supported-encodings '(ascii utf8)) (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) (unless (length-resolvable? len)
(raise-argument-error '+xarray "length-resolvable?" len)) (raise-argument-error '+xarray "length-resolvable?" len))
(unless (or (procedure? encoding) (memq encoding supported-encodings)) (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 encode xsymbol-encode)
(define size xstring-size)]) (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)) (xsymbol len encoding))
(module+ test (module+ test

10
xenomorph/xenomorph/redo/struct.rkt
Unescape Escape View File

@ -1,6 +1,7 @@
#lang debug racket/base #lang debug racket/base
(require (prefix-in d: racket/dict) (require (prefix-in d: racket/dict)
racket/promise racket/promise
racket/sequence
racket/list racket/list
"helper.rkt" "helper.rkt"
"number.rkt" "number.rkt"
@ -116,7 +117,14 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(define encode xstruct-encode) (define encode xstruct-encode)
(define size xstruct-size)]) (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) (unless (d:dict? fields)
(raise-argument-error '+xstruct "dict" fields)) (raise-argument-error '+xstruct "dict" fields))
(xstruct fields)) (xstruct fields))

3
xenomorph/xenomorph/redo/test/array-test.rkt
Unescape Escape View File

@ -102,4 +102,5 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee
(test-case (test-case
"add pointers after array if length is encoded at start" "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))) (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)))

36
xenomorph/xenomorph/redo/test/pointer-test.rkt
Unescape Escape View File

@ -16,37 +16,37 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"decode should handle null pointers" "decode should handle null pointers"
(parameterize ([current-input-port (open-input-bytes (bytes 0))]) (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 (test-case
"decode should use local offsets from start of parent by default" "decode should use local offsets from start of parent by default"
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) (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 (test-case
"decode should support immediate offsets" "decode should support immediate offsets"
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) (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 (test-case
"decode should support offsets relative to the parent" "decode should support offsets relative to the parent"
(parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))]) (parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))])
(pos (current-input-port) 2) (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))) #:parent (mhash 'parent (mhash '_startOffset 2))) 53)))
(test-case (test-case
"decode should support global offsets" "decode should support global offsets"
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))]) (parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))])
(pos (current-input-port) 2) (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)))) #:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
53))) 53)))
(test-case (test-case
"decode should support offsets relative to a property on the parent" "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))]) (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))) #:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
53))) 53)))
@ -59,32 +59,32 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"decode should support decoding pointers lazily" "decode should support decoding pointers lazily"
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))]) (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-true (promise? (dict-ref (struct-dict-res-_kv res) 'ptr)))
(check-equal? (dict-ref res 'ptr) 53))) (check-equal? (dict-ref res 'ptr) 53)))
(test-case (test-case
"size" "size"
(let ([parent (mhash 'pointerSize 0)]) (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))) (check-equal? (dict-ref parent 'pointerSize) 1)))
(test-case (test-case
"size should add to immediate pointerSize" "size should add to immediate pointerSize"
(let ([parent (mhash 'pointerSize 0)]) (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))) (check-equal? (dict-ref parent 'pointerSize) 1)))
(test-case (test-case
"size should add to parent pointerSize" "size should add to parent pointerSize"
(let ([parent (mhash 'parent (mhash 'pointerSize 0))]) (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))) (check-equal? (dict-ref (dict-ref parent 'parent) 'pointerSize) 1)))
(test-case (test-case
"size should add to global pointerSize" "size should add to global pointerSize"
(let ([parent (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))]) (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))) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerSize) 1)))
(test-case (test-case
@ -100,7 +100,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"size should return a fixed size without a value" "size should return a fixed size without a value"
(check-equal? (size (+xpointer uint8 uint8)) 1)) (check-equal? (size (+xpointer)) 1))
(test-case (test-case
"encode should handle null pointers" "encode should handle null pointers"
@ -109,7 +109,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
'startOffset 0 'startOffset 0
'pointerOffset 0 'pointerOffset 0
'pointers null)) 'pointers null))
(encode (+xpointer uint8 uint8) #f #:parent parent) (encode (+xpointer) #f #:parent parent)
(check-equal? (dict-ref parent 'pointerSize) 0) (check-equal? (dict-ref parent 'pointerSize) 0)
(check-equal? (dump (current-output-port)) (bytes 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 'startOffset 0
'pointerOffset 1 'pointerOffset 1
'pointers null)) '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 'pointerOffset) 2)
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
@ -134,7 +134,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
'startOffset 0 'startOffset 0
'pointerOffset 1 'pointerOffset 1
'pointers null)) '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 'pointerOffset) 2)
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
@ -148,7 +148,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
'startOffset 3 'startOffset 3
'pointerOffset 5 'pointerOffset 5
'pointers null))) '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) 'pointerOffset) 6)
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref (dict-ref parent 'parent) 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
@ -164,7 +164,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
'startOffset 3 'startOffset 3
'pointerOffset 5 'pointerOffset 5
'pointers null))))) '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) 'pointerOffset) 6)
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointers) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointers)
(list (mhasheq 'type uint8 (list (mhasheq 'type uint8
@ -180,7 +180,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
'pointerOffset 10 'pointerOffset 10
'pointers null 'pointers null
'val (mhash 'ptr 4))) '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 'pointerOffset) 11)
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10

60
xenomorph/xenomorph/redo/test/struct-test.rkt
Unescape Escape View File

@ -16,15 +16,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
"decode into an object" "decode into an object"
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
(check-equal? (check-equal?
(dump (decode (+xstruct (dictify 'name (+xstring uint8) (dump (decode (+xstruct 'name (+xstring #:length uint8)
'age uint8)))) 'age uint8)))
'((name . "roxyb") (age . 21))))) '((name . "roxyb") (age . 21)))))
(test-case (test-case
"decode with process hook" "decode with process hook"
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
(define struct (+xstruct (dictify 'name (+xstring uint8) (define struct (+xstruct 'name (+xstring #:length uint8)
'age uint8))) 'age uint8))
(set-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o)) (set-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o))
(check-equal? (dump (decode struct)) (check-equal? (dump (decode struct))
'((name . "roxyb") (canDrink . #t) (age . 32))))) '((name . "roxyb") (canDrink . #t) (age . 32)))))
@ -32,58 +32,56 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
(test-case (test-case
"decode supports function keys" "decode supports function keys"
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
(define struct (+xstruct (dictify 'name (+xstring uint8) (define struct (+xstruct 'name (+xstring #:length uint8)
'age uint8 'age uint8
'canDrink (λ (o) (>= (dict-ref o 'age) 21))))) 'canDrink (λ (o) (>= (dict-ref o 'age) 21))))
(check-equal? (dump (decode struct)) (check-equal? (dump (decode struct))
'((name . "roxyb") (canDrink . #t) (age . 32))))) '((name . "roxyb") (canDrink . #t) (age . 32)))))
(test-case (test-case
"compute the correct size" "compute the correct size"
(check-equal? (size (+xstruct (dictify (check-equal? (size (+xstruct 'name (+xstring #:length uint8)
'name (+xstring uint8) 'age uint8)
'age uint8))
(hasheq 'name "roxyb" 'age 32)) 7)) (hasheq 'name "roxyb" 'age 32)) 7))
(test-case (test-case
"compute the correct size with pointers" "compute the correct size with pointers"
(check-equal? (size (+xstruct (dictify (check-equal? (size (+xstruct 'name (+xstring #:length uint8)
'name (+xstring uint8) 'age uint8
'age uint8 'ptr (+xpointer #:type (+xstring #:length uint8)))
'ptr (+xpointer uint8 (+xstring uint8)))) (mhash 'name "roxyb" 'age 21 'ptr "hello")) 14))
(mhash 'name "roxyb" 'age 21 'ptr "hello")) 14))
(test-case (test-case
"get the correct size when no value is given" "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 (test-case
"throw when getting non-fixed length size and no value is given" "throw when getting non-fixed length size and no value is given"
(check-exn exn:fail:contract? (λ () (size (+xstruct (dictify 'name (+xstring uint8) (check-exn exn:fail:contract? (λ () (size (+xstruct 'name (+xstring #:length uint8)
'age uint8)))))) 'age uint8)))))
(test-case (test-case
"encode objects to buffers" "encode objects to buffers"
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
(check-equal? (dump (decode (+xstruct (dictify 'name (+xstring uint8) (check-equal? (dump (decode (+xstruct 'name (+xstring #:length uint8)
'age uint8)))) 'age uint8)))
'((name . "roxyb") (age . 21))))) '((name . "roxyb") (age . 21)))))
(test-case (test-case
"support pre-encode hook" "support pre-encode hook"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define struct (+xstruct (dictify 'nameLength uint8 (define struct (+xstruct 'nameLength uint8
'name (+xstring 'nameLength) 'name (+xstring 'nameLength)
'age uint8))) 'age uint8))
(set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val)) (set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))
(encode struct (mhasheq 'name "roxyb" 'age 21)) (encode struct (mhasheq 'name "roxyb" 'age 21))
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15"))) (check-equal? (dump (current-output-port)) #"\x05roxyb\x15")))
(test-case (test-case
"encode pointer data after structure" "encode pointer data after structure"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define struct (+xstruct (dictify 'name (+xstring uint8) (define struct (+xstruct 'name (+xstring #:length uint8)
'age uint8 'age uint8
'ptr (+xpointer uint8 (+xstring uint8))))) 'ptr (+xpointer #:type (+xstring #:length uint8))))
(encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello")) (encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello"))) (check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello")))

68
xenomorph/xenomorph/redo/test/versioned-struct-test.rkt
Unescape Escape View File

@ -17,9 +17,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
"decode should get version from number type" "decode should get version from number type"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) (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" "decode should throw for unknown version"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")]) (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 (dictify
'header (dictify 'age uint8 'header (dictify 'age uint8
'alive uint8) 'alive uint8)
0 (dictify 'name (+xstring uint8 'ascii)) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'gender uint8)))]) 'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")]) (parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
(check-equal? (dump (decode vstruct)) '((version . 0) (name . "roxyb") (age . 21) (alive . 1)))) (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" "decode should support parent version key"
(let ([vstruct (+xversioned-struct 'version (let ([vstruct (+xversioned-struct 'version
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) (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" "decode should support sub versioned structs"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (+xversioned-struct uint8 1 (+xversioned-struct uint8
(dictify (dictify
@ -98,9 +98,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
"decode should support process hook" "decode should support process hook"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(set-post-decode! vstruct (λ (val) (dict-set! val 'processed "true") val)) (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" "size should compute the correct size"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(check-equal? (size vstruct (mhasheq 'name "roxyb" (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" "size should throw for unknown version"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(check-exn exn:fail:contract? (λ () (size vstruct (mhasheq 'name "roxyb" (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 (dictify
'header (dictify 'age uint8 'header (dictify 'age uint8
'alive uint8) 'alive uint8)
0 (dictify 'name (+xstring uint8 'ascii)) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'gender uint8)))]) 'gender uint8)))])
(check-equal? (size struct (mhasheq 'name "roxyb" (check-equal? (size struct (mhasheq 'name "roxyb"
'age 21 'age 21
@ -161,11 +161,12 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
"size should compute the correct size with pointers" "size should compute the correct size with pointers"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'ptr (+xpointer uint8 (+xstring uint8)))))]) 'ptr (+xpointer #:offset-type uint8
#:type (+xstring uint8)))))])
(check-equal? (size vstruct (mhasheq 'name "roxyb" (check-equal? (size vstruct (mhasheq 'name "roxyb"
'age 21 'age 21
'version 1 'version 1
@ -175,9 +176,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
"size should throw if no value is given" "size should throw if no value is given"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))]) 'gender uint8)))])
(check-exn exn:fail:contract? (λ () (size vstruct))))) (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" "encode should encode objects to buffers"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))] 'gender uint8)))]
[op (open-output-bytes)]) [op (open-output-bytes)])
@ -205,9 +206,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
"encode should throw for unknown version" "encode should throw for unknown version"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))] 'gender uint8)))]
[op (open-output-bytes)]) [op (open-output-bytes)])
@ -221,8 +222,8 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
(dictify (dictify
'header (dictify 'age uint8 'header (dictify 'age uint8
'alive uint8) 'alive uint8)
0 (dictify 'name (+xstring uint8 'ascii)) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'gender uint8)))] 'gender uint8)))]
[op (open-output-bytes)]) [op (open-output-bytes)])
(encode vstruct (mhasheq 'name "roxyb" (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" "encode should encode pointer data after structure"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'ptr (+xpointer uint8 (+xstring uint8)))))] 'ptr (+xpointer #:offset-type uint8
#:type (+xstring uint8)))))]
[op (open-output-bytes)]) [op (open-output-bytes)])
(encode vstruct (mhasheq 'version 1 (encode vstruct (mhasheq 'version 1
'name "roxyb" 'name "roxyb"
@ -257,9 +259,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
"encode should support preEncode hook" "encode should support preEncode hook"
(let ([vstruct (+xversioned-struct uint8 (let ([vstruct (+xversioned-struct uint8
(dictify (dictify
0 (dictify 'name (+xstring uint8 'ascii) 0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
'age uint8) 'age uint8)
1 (dictify 'name (+xstring uint8 'utf8) 1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
'age uint8 'age uint8
'gender uint8)))] 'gender uint8)))]
[stream (open-output-bytes)]) [stream (open-output-bytes)])

Write Preview
Loading…
Cancel
Save