main
Matthew Butterick 6 years ago
parent c9dd1f7321
commit 964ced9cdf

@ -1,94 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
sugar/unstable/dict
sugar/unstable/js
"private/generic.rkt"
"private/helper.rkt"
"number.rkt"
"utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
|#
(define-subclass xenomorph-base% (ArrayT type [len #f] [length-type 'count])
(define/augride (decode port [parent #f])
(define ctx (if (NumberT? len)
(mhasheq 'parent parent
'_startOffset (pos port)
'_currentOffset 0
'_length len)
parent))
(define decoded-len (resolve-length len port 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? (· parent _length)))) (+ (· parent _startOffset) (· 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 port)) (= (pos port) end-pos)))
(send type decode port ctx))]
;; we have decoded-len, which is treated as count of items
[else (for/list ([i (in-range decoded-len)])
(send type decode port ctx))]))
(define/augride (size [val #f] [ctx #f])
(when val (unless (countable? val)
(raise-argument-error 'Array:size "countable" val)))
(cond
[val (let-values ([(ctx len-size) (if (NumberT? len)
(values (mhasheq 'parent ctx) (send len size))
(values ctx 0))])
(+ len-size (for/sum ([item (in-list (countable->list val))])
(send type size item ctx))))]
[else (let ([item-count (resolve-length len #f ctx)]
[item-size (send type size #f ctx)])
(* item-size item-count))]))
(define/augride (encode port array [parent #f])
(when array (unless (countable? array)
(raise-argument-error 'Array:encode "list or countable" array)))
(define (encode-items ctx)
(let* ([items (countable->list array)]
[item-count (length items)]
[max-items (if (number? len) len item-count)])
(for ([item (in-list items)])
(send type encode port item ctx))))
(cond
[(NumberT? len) (define ctx (mhash 'pointers null
'startOffset (pos port)
'parent parent))
(ref-set! ctx 'pointerOffset (+ (pos port) (size array ctx)))
(send len encode port (length array)) ; encode length at front
(encode-items ctx)
(for ([ptr (in-list (· ctx pointers))]) ; encode pointer data at end
(send (· ptr type) encode port (· ptr val)))]
[else (encode-items parent)])))
(define-syntax-rule (define-procedures (NEW ...) (OLD ...))
(define-values (NEW ...)
(values (if (procedure? OLD)
(procedure-rename OLD 'NEW)
OLD) ...)))
(define-procedures (Array Array? +Array) (ArrayT ArrayT? +ArrayT))
(define-procedures (array% array? array) (ArrayT ArrayT? +ArrayT))
(test-module
(check-equal? (decode (+Array uint16be 3) #"ABCDEF") '(16706 17220 17734))
(check-equal? (encode (+Array uint16be 3) '(16706 17220 17734) #f) #"ABCDEF")
(check-equal? (size (+Array uint16be) '(1 2 3)) 6)
(check-equal? (size (+Array doublebe) '(1 2 3 4 5)) 40))

@ -1,123 +0,0 @@
#lang debug racket/base
(require racket/class
sugar/unstable/class
racket/generic
racket/private/generic-methods
"private/generic.rkt"
racket/port
racket/dict)
(provide (all-defined-out))
(define-generics posable
(pos posable [new-pos])
#:defaults
([port? (define (pos p [new-pos #f]) (when new-pos
(file-position p new-pos))
(file-position p))]))
(define posable<%>
(interface* ()
([(generic-property gen:posable)
(generic-method-table gen:posable
(define (pos o [new-pos #f]) (send o pos new-pos)))])))
(define-generics codable
(decode codable #:parent [parent] [stream])
(encode codable [val] [stream] #:parent [parent]))
(define codable<%>
(interface* ()
([(generic-property gen:codable)
(generic-method-table gen:codable
(define (decode o [port (current-input-port)] #:parent [parent #f])
(send o decode port parent))
(define (encode o [val #f] [port (current-output-port)] #:parent [parent #f])
(when (port? val)
(raise-argument-error 'encode "encodable value" val))
(send o encode port val parent)))])))
(define-generics sizable
(size sizable [val] [parent]))
(define sizable<%>
(interface* ()
([(generic-property gen:sizable)
(generic-method-table gen:sizable
(define (size o [val #f] [parent #f]) (send o size val parent)))])))
(define (dump x)
(define (dump-dict x)
(for/list ([(k v) (in-dict x)])
(cons (dump k) (dump v))))
(let loop ([x x])
(cond
[(input-port? x) (port->bytes x)]
[(output-port? x) (get-output-bytes x)]
[(and (object? x)
(memq 'dump (interface->method-names (object-interface x)))) (send x dump)]
[(dict? x) (dump-dict x)]
[(list? x) (map loop x)]
[else x])))
#;(define dumpable<%>
(interface* ()
([(generic-property gen:dumpable)
(generic-method-table gen:dumpable
(define (dump o) (send o dump)))])))
(define (symbol-append . syms)
(string->symbol (apply string-append (map symbol->string syms))))
(define xenomorph-base%
(class* object% (codable<%> sizable<%>)
(super-new)
(field [_hash (make-hash)]
[_list null])
(define/pubment (decode port [parent #f] . args)
;; todo: is `indexable?` really a necessary condition? doesn't seem to break anything withou it
#;(when parent (unless (indexable? parent)
#;(raise-argument-error (symbol-append (get-class-name) ':decode) "indexable" parent)))
(define ip (cond
[(bytes? port) (open-input-bytes port)]
[(input-port? port) port]
[else (raise-argument-error (symbol-append (get-class-name) ':decode) "bytes or input port" port)]))
(post-decode (inner (void) decode ip parent) port parent . args))
(define/pubment (encode port val-in [parent #f] . args)
#;(report* port val-in parent)
(define val (pre-encode val-in port))
#;(when parent (unless (indexable? parent)
(raise-argument-error (symbol-append (get-class-name) ':encode) "indexable" parent)))
(define op (cond
[(output-port? port) port]
[(not port) (open-output-bytes)]
[else (raise-argument-error 'Xenomorph "output port or #f" port)]))
(define encode-result (inner (void) encode op val parent . args))
(when (bytes? encode-result)
(write-bytes encode-result op))
(when (not port) (get-output-bytes op)))
(define/pubment (size [val #f] [parent #f] . args)
(when parent (unless (indexable? parent)
(raise-argument-error (symbol-append (get-class-name) ':size) "indexable" parent)))
(define result (inner (void) size val parent . args))
(cond
[(void? result) 0]
[(and (integer? result) (not (negative? result))) result]
[else (raise-argument-error (symbol-append (get-class-name) ':size) "nonnegative integer" result)]))
(define/public (get-class-name) (define-values (name _) (object-info this))
(or name 'Xenomorph))
(define/public (post-decode val . _) val)
(define/public (pre-encode val . _) val)
(define/public (dump) (void))))
(define-class-predicates xenomorph-base%)
(define-subclass xenomorph-base% (RestructureBase))
(define-subclass RestructureBase (Streamcoder))

@ -1,49 +0,0 @@
#lang racket/base
(require racket/class
racket/list
sugar/unstable/class
sugar/unstable/dict
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
|#
(define-subclass Streamcoder (Bitfield type [flags empty])
(unless (andmap (λ (f) (or (key? f) (not f))) flags)
(raise-argument-error 'Bitfield "list of keys" flags))
(define/augment (decode stream . _)
(define flag-hash (mhasheq))
(for* ([val (in-value (send type decode stream))]
[(flag i) (in-indexed flags)]
#:when flag)
(hash-set! flag-hash flag (bitwise-bit-set? val i)))
flag-hash)
(define/augment (size . _) (send type size))
(define/augment (encode port flag-hash [ctx #f])
(define bit-int (for/sum ([(flag i) (in-indexed flags)]
#:when (and flag (ref flag-hash flag)))
(arithmetic-shift 1 i)))
(send type encode port bit-int))
(define/override (get-class-name) 'Bitfield))
(test-module
(require "number.rkt")
(define bfer (+Bitfield uint16be '(bold italic underline #f shadow condensed extended)))
(define bf (send bfer decode #"\0\25"))
(check-equal? (length (ref-keys bf)) 6) ; omits #f flag
(check-true (ref bf 'bold))
(check-true (ref bf 'underline))
(check-true (ref bf 'shadow))
(check-false (ref bf 'italic))
(check-false (ref bf 'condensed))
(check-false (ref bf 'extended))
(check-equal? (encode bfer bf #f) #"\0\25"))

@ -1,60 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
"private/generic.rkt"
"private/helper.rkt"
"number.rkt"
"utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
|#
#|
A Buffer is a container object for any data object that supports random access
A Node Buffer object is basically a byte string.
First argument must be a string, Buffer, ArrayBuffer, Array, or array-like object.
A Restructure RBuffer object is separate.
|#
(define (+Buffer xs [type #f])
((if (string? xs)
string->bytes/utf-8
list->bytes) xs))
(define-subclass xenomorph-base% (RBuffer [len #xffff])
(define/augment (decode port [parent #f])
(define decoded-len (resolve-length len port parent))
(read-bytes decoded-len port))
(define/augment (size [val #f] [parent #f])
(when val (unless (bytes? val)
(raise-argument-error 'Buffer:size "bytes" val)))
(if val
(bytes-length val)
(resolve-length len val parent)))
(define/augment (encode port buf [parent #f])
(unless (bytes? buf)
(raise-argument-error 'Buffer:encode "bytes" buf))
(define op (or port (open-output-bytes)))
(when (NumberT? len)
(send len encode op (length buf)))
(write-bytes buf op)
(unless port (get-output-bytes op))))
(define-subclass RBuffer (BufferT))
#;(test-module
(require "stream.rkt")
(define stream (+DecodeStream #"\2BCDEF"))
(define S (+String uint8 'utf8))
(check-equal? (send S decode stream) "BC")
(define os (+EncodeStream))
(send S encode os "Mike")
(check-equal? (send os dump) #"\4Mike")
(check-equal? (send (+String) size "foobar") 6))

@ -1,26 +0,0 @@
#lang racket/base
(require racket/class
racket/list
sugar/unstable/class
"private/helper.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
|#
(define-subclass xenomorph-base% (Enum type [options empty])
(define/augment (decode stream . _)
(define index (send type decode stream))
(or (list-ref options index) index))
(define/augment (size . _) (send type size))
(define/augment (encode stream val [ctx #f])
(define index (index-of options val))
(unless index
(raise-argument-error 'Enum:encode "valid option" val))
(send type encode stream index)))

@ -1,4 +0,0 @@
#lang info
(define scribblings '(("scribblings/xenomorph.scrbl" ())))
(define compile-omit-paths '("test/"))

@ -1,83 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
sugar/unstable/dict
"private/generic.rkt"
"private/helper.rkt"
"utils.rkt"
"array.rkt"
"number.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee
|#
(define (get o i) (send o get i))
(define (LazyArray->list o) (send o to-list))
(define-subclass object% (InnerLazyArray type [len #f] [port-in #f] [ctx #f])
(field ([port port] (cond
[(bytes? port-in) (open-input-bytes port-in)]
[(port? port-in) port-in]
[else (raise-argument-error 'LazyArray "port" port)])))
(define starting-pos (pos port))
(define item-cache (mhasheqv)) ; integer-keyed hash, rather than list
(define/public-final (get index)
(unless (<= 0 index (sub1 len))
(raise-argument-error 'LazyArray:get (format "index in range 0 to ~a" (sub1 len)) index))
(ref! item-cache index (λ ()
(define orig-pos (pos port))
(pos port (+ starting-pos (* (send type size #f ctx) index)))
(define new-item (send type decode port ctx))
(pos port orig-pos)
new-item)))
(define/public-final (to-list)
(for/list ([i (in-range len)])
(get i))))
(define-subclass ArrayT (LazyArray)
(inherit-field len type)
(define/override (decode port [parent #f])
(define starting-pos (pos port)) ; ! placement matters. `resolve-length` will change `pos`
(define decoded-len (resolve-length len port parent))
(let ([parent (if (NumberT? len)
(mhasheq 'parent parent
'_startOffset starting-pos
'_currentOffset 0
'_length len)
parent)])
(define res (+InnerLazyArray type decoded-len port parent))
(pos port (+ (pos port) (* decoded-len (send type size #f parent))))
res))
(define/override (size [val #f] [ctx #f])
(super size (if (InnerLazyArray? val)
(send val to-list)
val) ctx))
(define/override (encode port val [ctx #f])
(super encode port (if (InnerLazyArray? val)
(send val to-list)
val) ctx)))
(test-module
(define bstr #"ABCD1234")
(define ds (open-input-bytes bstr))
(define la (+LazyArray uint8 4))
(define ila (decode la ds))
(check-equal? (pos ds) 4)
(check-equal? (get ila 1) 66)
(check-equal? (get ila 3) 68)
(check-equal? (pos ds) 4)
(check-equal? (LazyArray->list ila) '(65 66 67 68))
(define la2 (+LazyArray int16be (λ (t) 4)))
(check-equal? (encode la2 '(1 2 3 4) #f) #"\0\1\0\2\0\3\0\4")
(check-equal? (send (decode la2 (open-input-bytes #"\0\1\0\2\0\3\0\4")) to-list) '(1 2 3 4)))

@ -1,18 +0,0 @@
#lang racket/base
(define-syntax-rule (r+p ID ...)
(begin (require ID ...) (provide (all-from-out ID ...))))
(r+p "array.rkt"
"base.rkt"
"bitfield.rkt"
"buffer.rkt"
"enum.rkt"
"lazy-array.rkt"
"number.rkt"
"optional.rkt"
"pointer.rkt"
"reserved.rkt"
"string.rkt"
"struct.rkt"
"versioned-struct.rkt")

@ -1,197 +0,0 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
"sizes.rkt"
racket/match)
racket/class
sugar/unstable/class
"private/helper.rkt"
"sizes.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
|#
(define (ends-with-8? type)
(define str (symbol->string type))
(equal? (substring str (sub1 (string-length str))) "8"))
(define (signed-type? type)
(not (equal? "u" (substring (symbol->string type) 0 1))))
(test-module
(check-false (signed-type? 'uint16))
(check-true (signed-type? 'int16)))
(define (exact-if-possible x) (if (integer? x) (inexact->exact x) x))
(define system-endian (if (system-big-endian?) 'be 'le))
(define-subclass xenomorph-base% (Integer [type 'uint16] [endian system-endian])
(getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))])
(define _signed? (signed-type? type))
;; `get-type-size` will raise error if number-type is invalid: use this as check of input
;; size of a number doesn't change, so we can stash it as `_size`
(define _size (with-handlers ([exn:fail:contract?
(λ (exn)
(raise-argument-error 'Integer "valid type and endian" (format "~v ~v" type endian)))])
(get-type-size number-type)))
(define bits (* _size 8))
(define/augment (size . args) _size)
(define-values (bound-min bound-max)
;; if a signed integer has n bits, it can contain a number
;; between - (expt 2 (sub1 n)) and (sub1 (expt 2 (sub1 n)).
(let* ([signed-max (sub1 (arithmetic-shift 1 (sub1 bits)))]
[signed-min (sub1 (- signed-max))]
[delta (if _signed? 0 signed-min)])
(values (- signed-min delta) (- signed-max delta))))
(define/augment (decode port [parent #f])
(define bstr (read-bytes _size port))
(define bs ((if (eq? endian system-endian) values reverse) (bytes->list bstr)))
(define unsigned-int (for/sum ([(b i) (in-indexed bs)])
(arithmetic-shift b (* 8 i))))
unsigned-int)
(define/override (post-decode unsigned-val . _)
(if _signed? (unsigned->signed unsigned-val bits) unsigned-val))
(define/override (pre-encode val . _)
(exact-if-possible val))
(define/augment (encode port val [parent #f])
(unless (<= bound-min val bound-max)
(raise-argument-error 'Integer:encode (format "value within range of ~a ~a-byte int (~a to ~a)" (if _signed? "signed" "unsigned") _size bound-min bound-max) val))
(define-values (bs _) (for/fold ([bs null] [n val])
([i (in-range _size)])
(values (cons (bitwise-and n #xff) bs) (arithmetic-shift n -8))))
(apply bytes ((if (eq? endian 'be) values reverse) bs))))
(define-values (NumberT NumberT? +NumberT) (values Integer Integer? +Integer))
(define-values (Number Number? +Number) (values Integer Integer? +Integer))
(define-subclass xenomorph-base% (Float _size [endian system-endian])
(define byte-size (/ _size 8))
(define/augment (decode port [parent #f]) ; convert int to float
(define bs (read-bytes byte-size port))
(floating-point-bytes->real bs (eq? endian 'be)))
(define/augment (encode port val [parent #f]) ; convert float to int
(define bs (real->floating-point-bytes val byte-size (eq? endian 'be)))
bs)
(define/augment (size . args) byte-size))
(define-instance float (make-object Float 32))
(define-instance floatbe (make-object Float 32 'be))
(define-instance floatle (make-object Float 32 'le))
(define-instance double (make-object Float 64))
(define-instance doublebe (make-object Float 64 'be))
(define-instance doublele (make-object Float 64 'le))
(define-subclass* Integer (Fixed size [fixed-endian system-endian] [fracBits (floor (/ size 2))])
(super-make-object (string->symbol (format "int~a" size)) fixed-endian)
(define _point (arithmetic-shift 1 fracBits))
(define/override (post-decode int . _)
(exact-if-possible (/ int _point 1.0)))
(define/override (pre-encode fixed . _)
(exact-if-possible (floor (* fixed _point)))))
(define-instance fixed16 (make-object Fixed 16))
(define-instance fixed16be (make-object Fixed 16 'be))
(define-instance fixed16le (make-object Fixed 16 'le))
(define-instance fixed32 (make-object Fixed 32))
(define-instance fixed32be (make-object Fixed 32 'be))
(define-instance fixed32le (make-object Fixed 32 'le))
(test-module
(check-exn exn:fail:contract? (λ () (+Integer 'not-a-valid-type)))
(check-exn exn:fail:contract? (λ () (encode uint8 256 #f)))
(check-not-exn (λ () (encode uint8 255 #f)))
(check-exn exn:fail:contract? (λ () (encode int8 256 #f)))
(check-exn exn:fail:contract? (λ () (encode int8 255 #f)))
(check-not-exn (λ () (encode int8 127 #f)))
(check-not-exn (λ () (encode int8 -128 #f )))
(check-exn exn:fail:contract? (λ () (encode int8 -129 #f)))
(check-exn exn:fail:contract? (λ () (encode uint16 (add1 #xffff) #f)))
(check-not-exn (λ () (encode uint16 #xffff #f)))
(let ([o (+Integer 'uint16 'le)]
[ip (open-input-bytes (bytes 1 2 3 4))]
[op (open-output-bytes)])
(check-equal? (send o decode ip) 513) ;; 1000 0000 0100 0000
(check-equal? (send o decode ip) 1027) ;; 1100 0000 0010 0000
(encode o 513 op)
(check-equal? (get-output-bytes op) (bytes 1 2))
(encode o 1027 op)
(check-equal? (get-output-bytes op) (bytes 1 2 3 4)))
(let ([o (+Integer 'uint16 'be)]
[ip (open-input-bytes (bytes 1 2 3 4))]
[op (open-output-bytes)])
(check-equal? (send o decode ip) 258) ;; 0100 0000 1000 0000
(check-equal? (send o decode ip) 772) ;; 0010 0000 1100 0000
(encode o 258 op)
(check-equal? (get-output-bytes op) (bytes 1 2))
(encode o 772 op)
(check-equal? (get-output-bytes op) (bytes 1 2 3 4))))
(test-module
(check-equal? (send (+Integer 'uint8) size) 1)
(check-equal? (send (+Integer) size) 2)
(check-equal? (send (+Integer 'uint32) size) 4)
(check-equal? (send (+Integer 'double) size) 8)
(check-equal? (send (+Number 'uint8) size) 1)
(check-equal? (send (+Number) size) 2)
(check-equal? (send (+Number 'uint32) size) 4)
(check-equal? (send (+Number 'double) size) 8))
;; use keys of type-sizes hash to generate corresponding number definitions
(define-syntax (make-int-types stx)
(syntax-case stx ()
[(_) (with-syntax* ([((ID BASE ENDIAN) ...) (for*/list ([k (in-hash-keys type-sizes)]
[kstr (in-value (format "~a" k))]
#:unless (regexp-match #rx"^(float|double)" kstr))
(match-define (list* prefix suffix _)
(regexp-split #rx"(?=[bl]e|$)" kstr))
(map string->symbol
(list (string-downcase kstr)
prefix
(if (positive? (string-length suffix))
suffix
(if (system-big-endian?) "be" "le")))))]
[(ID ...) (map (λ (s) (datum->syntax stx (syntax->datum s))) (syntax->list #'(ID ...)))])
#'(begin (define-instance ID (make-object Integer 'BASE 'ENDIAN)) ...))]))
(make-int-types)
(test-module
(check-equal? (size uint8) 1)
(check-equal? (size uint16) 2)
(check-equal? (size uint32) 4)
(check-equal? (size double) 8)
(define bs (encode fixed16be 123.45 #f))
(check-equal? bs #"{s")
(check-equal? (ceiling (* (decode fixed16be bs) 100)) 12345.0)
(check-equal? (decode int8 (bytes 127)) 127)
(check-equal? (decode int8 (bytes 255)) -1)
(check-equal? (encode int8 -1 #f) (bytes 255))
(check-equal? (encode int8 127 #f) (bytes 127)))

@ -1,30 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
"private/helper.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
|#
(define-subclass xenomorph-base% (Optional type [condition #t])
(define (resolve-condition parent)
(if (procedure? condition)
(condition parent)
condition))
(define/augment (decode stream parent)
(when (resolve-condition parent)
(send type decode stream parent)))
(define/augment (size val parent)
(when (resolve-condition parent)
(send type size val parent)))
(define/augment (encode stream val parent)
(when (resolve-condition parent)
(send type encode stream val parent))))

@ -1,107 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
sugar/unstable/case
sugar/unstable/dict
sugar/unstable/js
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
|#
(define (resolve-void-pointer type val)
(cond
[type (values type val)]
[(VoidPointer? val) (values (· val type) (· val value))]
[else (raise-argument-error 'Pointer:size "VoidPointer" val)]))
(define (find-top-ctx ctx)
(cond
[(· ctx parent) => find-top-ctx]
[else ctx]))
(define-subclass xenomorph-base% (Pointer offset-type type-in [options (mhasheq)])
(field [type (and (not (eq? type-in 'void)) type-in)])
(define pointer-style (or (· options type) 'local))
(define allow-null (or (· options allowNull) #t))
(define null-value (or (· options nullValue) 0))
(define lazy (· options lazy))
(define relative-getter-or-0 (or (· options relativeTo) (λ (ctx) 0))) ; changed this to a simple lambda
(define/augment (decode port [ctx #f])
(define offset (send offset-type decode port ctx))
(cond
[(and allow-null (= offset null-value)) #f] ; handle null pointers
[else
(define relative (+ (caseq pointer-style
[(local) (· ctx _startOffset)]
[(immediate) (- (pos port) (send offset-type size))]
[(parent) (· ctx parent _startOffset)]
[(global) (or (· (find-top-ctx ctx) _startOffset) 0)]
[else (error 'unknown-pointer-style)])
(relative-getter-or-0 ctx)))
(define ptr (+ offset relative))
(cond
[type (define val (void))
(define (decode-value)
(cond
[(not (void? val)) val]
[else
(define orig-pos (pos port))
(pos port ptr)
(set! val (send type decode port ctx))
(pos port orig-pos)
val]))
(if lazy
(LazyThunk decode-value)
(decode-value))]
[else ptr])]))
(define/augment (size [val #f] [ctx #f])
(let*-values ([(parent) ctx]
[(ctx) (caseq pointer-style
[(local immediate) ctx]
[(parent) (· ctx parent)]
[(global) (find-top-ctx ctx)]
[else (error 'unknown-pointer-style)])]
[(type val) (resolve-void-pointer type val)])
(when (and val ctx)
(ref-set! ctx 'pointerSize (and (· ctx pointerSize)
(+ (· ctx pointerSize) (send type size val parent)))))
(send offset-type size)))
(define/augment (encode port val [ctx #f])
(unless ctx
;; todo: furnish default pointer context? adapt from Struct?
(raise-argument-error 'Pointer:encode "valid pointer context" ctx))
(if (not val)
(send offset-type encode port null-value)
(let* ([parent ctx]
[ctx (caseq pointer-style
[(local immediate) ctx]
[(parent) (· ctx parent)]
[(global) (find-top-ctx ctx)]
[else (error 'unknown-pointer-style)])]
[relative (+ (caseq pointer-style
[(local parent) (· ctx startOffset)]
[(immediate) (+ (pos port) (send offset-type size val parent))]
[(global) 0])
(relative-getter-or-0 (· parent val)))])
(send offset-type encode port (- (· ctx pointerOffset) relative))
(let-values ([(type val) (resolve-void-pointer type val)])
(ref-set! ctx 'pointers (append (· ctx pointers) (list (mhasheq 'type type
'val val
'parent parent))))
(ref-set! ctx 'pointerOffset (+ (· ctx pointerOffset) (send type size val parent))))))))
;; A pointer whose type is determined at decode time
(define-subclass object% (VoidPointer type value))

@ -1,110 +0,0 @@
#lang racket/base
(require racket/generic
(prefix-in b: racket/base)
racket/dict
racket/class
racket/match)
(provide (all-defined-out))
(define-generics indexable
(ref indexable i [thunk])
(ref! indexable i [thunk])
(ref-set! indexable i v)
(ref-keys indexable)
#:defaults
([hash? (define (ref o i [thunk #f]) (hash-ref o i thunk))
(define (ref! o i [thunk #f]) (hash-ref! o i thunk))
(define ref-set! hash-set!)
(define ref-keys hash-keys)]
[dict? (define (ref o i [thunk #f]) (dict-ref o i thunk))
(define (ref! o i [thunk #f]) (dict-ref o i thunk))
(define ref-set! dict-set!)
(define ref-keys dict-keys)]
[object? (define (ref o i [thunk #f]) (with-handlers ([exn:fail:object? (λ (exn) (hash-ref (get-field _hash o) i thunk))]) (dynamic-get-field i o)))
(define (ref-set! o i v) (with-handlers ([exn:fail:object? (λ (exn) (hash-set! (get-field _hash o) i v))]) (dynamic-set-field! i o v)))
(define (ref-keys o) (append (remove '_hash (field-names o)) (hash-keys (get-field _hash o))))]))
(module+ test
(require rackunit racket/set)
(define h (make-hash '((foo . 42))))
(check-equal? (ref h 'foo) 42)
(ref-set! h 'foo 85)
(check-equal? (ref h 'foo) 85)
(ref-set! h 'bar 121)
(check-equal? (ref h 'bar) 121)
(check-equal? (apply set (ref-keys h)) (apply set '(foo bar)))
(define o (make-object (class object% (super-new) (field [_hash (make-hash)][foo 42]))))
(check-equal? (ref o 'foo) 42)
(ref-set! o 'foo 100)
(check-equal? (ref o 'foo) 100)
(ref-set! o 'bar 121)
(check-equal? (ref o 'bar) 121)
(check-equal? (apply set (ref-keys o)) (apply set '(foo bar))))
(define (ref* c . is)
(for/fold ([c c])
([i (in-list is)])
(ref c i)))
(define (ref*-set! c . is+val)
(match-define (list is ... i val) is+val)
(ref-set! (apply ref* c is) i val))
(require sugar/debug)
(define (ref-set*! c . kvs)
(for ([k (in-list kvs)]
[v (in-list (cdr kvs))]
[i (in-naturals)]
#:when (even? i))
(ref-set! c k v)))
(module+ test
(define h2 (make-hash (list (cons 'foo (make-hash (list (cons 'bar (make-hash '((zam . 42))))))))))
(check-equal? (ref* h2 'foo 'bar 'zam) 42)
(ref*-set! h2 'foo 'bar 'zam 89)
(check-equal? (ref* h2 'foo 'bar 'zam) 89)
(ref-set*! h2 'hi 1 'there 2)
(check-equal? (ref h2 'hi) 1)
(check-equal? (ref h2 'there) 2))
(define-generics countable
(length countable)
(countable->list countable)
#:defaults
([list? (define length b:length)
(define countable->list (λ (x) x))]
[vector? (define length vector-length)
(define countable->list vector->list)]
[string? (define length string-length)
(define countable->list string->list)]
[bytes? (define length bytes-length)
(define countable->list bytes->list)]
[dict? (define length dict-count)
(define countable->list (λ (x) x))]
[object? (define (length o) (b:length (get-field _list o)))
(define (countable->list o) (get-field _list o))]))
(module+ test
(require racket/list)
(check-equal? (length (make-list 42 #f)) 42)
(check-equal? (length (make-vector 42 #f)) 42)
(check-equal? (length (make-string 42 #\x)) 42)
(check-equal? (length (make-bytes 42 0)) 42)
(check-equal? (length (map cons (range 42) (range 42))) 42)
(check-equal? (length (make-object (class object% (super-new) (field [_list (make-list 42 #f)])))) 42))
(define-generics pushable
(push-end pushable xs)
#:defaults
([list? (define push-end b:append)]
[object? (define (push-end o xs)
(append (get-field _list o) xs))]))
(module+ test
(check-equal? (push-end (range 3) '(3 4 5)) (range 6))
(define o2 (make-object (class object% (super-new) (field [_list (range 3)]))))
(ref-set! o2 '_list (push-end o2 '(3 4 5)))
(check-equal? (ref o2 '_list) (range 6)))

@ -1,23 +0,0 @@
#lang racket/base
(require (for-syntax racket/base br/syntax) racket/class br/define "../base.rkt")
(provide (all-defined-out) (all-from-out "../base.rkt"))
(define-macro (test-module . EXPRS)
#`(module+ test
(require #,(datum->syntax caller-stx 'rackunit) #,(datum->syntax caller-stx 'racket/serialize))
. EXPRS))
(define index? (λ (x) (and (number? x) (integer? x) (not (negative? x)))))
(define key? symbol?)
(define (keys? x) (and (pair? x) (andmap key? x)))
(define (unsigned->signed uint bits)
(define most-significant-bit-mask (arithmetic-shift 1 (sub1 bits)))
(- (bitwise-xor uint most-significant-bit-mask) most-significant-bit-mask))
(define (signed->unsigned sint bits)
(bitwise-and sint (arithmetic-shift 1 bits)))
(struct LazyThunk (proc) #:transparent)

@ -1,24 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
"private/helper.rkt"
"utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee
|#
(define-subclass xenomorph-base% (Reserved type [count 1])
(define/augment (decode port parent)
(pos port (+ (pos port) (size #f parent)))
(void))
(define/augment (size [val #f] [parent #f])
(* (send type size) (resolve-length count #f parent)))
(define/augment (encode port val [parent #f])
(make-bytes (size val parent) 0)))

@ -1,36 +0,0 @@
#lang racket/base
(require "private/helper.rkt")
(provide type-sizes get-type-size)
(define-values (int-keys byte-values) (for*/lists (int-keys byte-values)
([signed (in-list '("u" ""))]
[bit-size (in-list '(8 16 24 32))])
(values (format "~aint~a" signed bit-size) (/ bit-size 8))))
(define type-sizes (for/hash ([type-key (in-list (append '("float" "double") int-keys))]
[byte-value (in-list (append '(4 8) byte-values))]
#:when #t
[endian (in-list '("" "be" "le"))])
(values (string->symbol (string-append type-key endian)) byte-value)))
(define (get-type-size key)
(hash-ref type-sizes key (λ () (raise-argument-error 'DecodeStream:get-type-size "valid type" key))))
(test-module
(check-equal? (get-type-size 'int8) 1)
(check-equal? (get-type-size 'uint8) 1)
(check-equal? (get-type-size 'uint8be) 1)
(check-equal? (get-type-size 'int16) 2)
(check-equal? (get-type-size 'uint16) 2)
(check-equal? (get-type-size 'uint16be) 2)
(check-equal? (get-type-size 'uint16le) 2)
(check-equal? (get-type-size 'uint32) 4)
(check-equal? (get-type-size 'uint32le) 4)
(check-equal? (get-type-size 'int32be) 4)
(check-equal? (get-type-size 'float) 4)
(check-equal? (get-type-size 'floatle) 4)
(check-equal? (get-type-size 'floatbe) 4)
(check-equal? (get-type-size 'double) 8)
(check-equal? (get-type-size 'doublele) 8)
(check-equal? (get-type-size 'doublebe) 8)
(check-exn exn:fail:contract? (λ () (get-type-size 'not-a-type))))

@ -1,112 +0,0 @@
#lang racket/base
(require racket/class
sugar/unstable/class
sugar/unstable/case
sugar/unstable/js
"private/generic.rkt"
"private/helper.rkt"
"number.rkt"
"utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/String.coffee
|#
(define (read-encoded-string port len [encoding 'ascii])
(define proc (caseq encoding
[(utf16le) (error 'bah)]
[(ucs2) (error 'bleh)]
[(utf8) bytes->string/utf-8]
[(ascii) bytes->string/latin-1]
[else values]))
(proc (read-bytes len port)))
(define (write-encoded-string port string [encoding 'ascii])
;; todo: handle encodings correctly.
;; right now just utf8 and ascii are correct
(define proc (caseq encoding
[(ucs2 utf8 ascii) string->bytes/utf-8]
[(utf16le) (error 'swap-bytes-unimplemented)]
[else (error 'unsupported-string-encoding)]))
(write-bytes (proc string) port))
(define (count-nonzero-chars port)
;; helper function for String
;; counts nonzero chars from current position
(length (car (regexp-match-peek "[^\u0]*" port))))
(define (byte-length val encoding)
(define encoder
(caseq encoding
[(ascii utf8) string->bytes/utf-8]))
(bytes-length (encoder (format "~a" val))))
(define (bytes-left-in-port? port)
(not (eof-object? (peek-byte port))))
(define-subclass xenomorph-base% (StringT [len #f] [encoding 'ascii])
(define/augment (decode port [parent #f])
(let ([len (or (resolve-length len port parent) (count-nonzero-chars port))]
[encoding (if (procedure? encoding)
(or (encoding parent) 'ascii)
encoding)]
[adjustment (if (and (not len) (bytes-left-in-port? port)) 1 0)])
(define string (read-encoded-string port len encoding))
(pos port (+ (pos port) adjustment))
string))
(define/augment (encode port val [parent #f])
(let* ([val (format "~a" val)]
[encoding (if (procedure? encoding)
(or (encoding (and parent (· parent val)) 'ascii))
encoding)])
(define encoded-length (byte-length val encoding))
(when (and (exact-nonnegative-integer? len) (> encoded-length len))
(raise-argument-error 'String:encode (format "string no longer than ~a" len) val))
(when (NumberT? len)
(send len encode port encoded-length))
(write-encoded-string port val encoding)
(when (not len) (write-byte #x00 port)))) ; null terminated when no len
(define/augment (size [val #f] [parent #f])
(if (not val)
(resolve-length len #f parent)
(let* ([encoding (if (procedure? encoding)
(or (encoding (and parent (· parent val)) 'ascii))
encoding)]
[encoding (if (eq? encoding 'utf16be) 'utf16le encoding)])
(+ (byte-length val encoding) (cond
[(not len) 1]
[(NumberT? len) (send len size)]
[else 0]))))))
(define-values (String? +String) (values StringT? +StringT))
(define-subclass StringT (Symbol)
(define/override (post-decode string-val . _)
(string->symbol string-val))
(define/override (pre-encode sym-val . _)
(unless (or (string? sym-val) (symbol? sym-val))
(raise-argument-error 'Symbol "symbol or string" sym-val))
(if (symbol? sym-val) sym-val (string->symbol sym-val))))
(test-module
(define S-fixed (+String 4 'utf8))
(check-equal? (encode S-fixed "Mike" #f) #"Mike")
(check-exn exn:fail? (λ () (encode S-fixed "Mikes" #f))) ; too long for fixed string
(define S (+String uint8 'utf8))
(check-equal? (decode S #"\2BCDEF") "BC")
(check-equal? (encode S "Mike" #f) #"\4Mike")
(check-equal? (size (+String) "foobar") 7) ; null terminated when no len
(check-equal? (decode (+Symbol 4) #"Mike") 'Mike)
(check-equal? (encode (+Symbol 4) 'Mike #f) #"Mike")
(check-equal? (encode (+Symbol 4) "Mike" #f) #"Mike")
(check-exn exn:fail:contract? (λ () (encode (+Symbol 4) 42 #f))))

@ -1,161 +0,0 @@
#lang racket/base
(require racket/list
sugar/unstable/class
sugar/unstable/dict
sugar/unstable/js
racket/class
"private/helper.rkt"
"private/generic.rkt"
racket/dict
racket/private/generic-methods)
(provide (all-defined-out) ref* ref*-set! (all-from-out racket/dict))
(require (prefix-in d: racket/dict))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
|#
(define private-keys '(parent _startOffset _currentOffset _length))
(define (choose-dict d k)
(if (memq k private-keys)
(get-field _pvt d)
(get-field _kv d)))
(define dictable<%>
(interface* ()
([(generic-property gen:dict)
(generic-method-table gen:dict
(define (dict-set! d k v) (d:dict-set! (choose-dict d k) k v))
(define (dict-ref d k [thunk #f])
(define res (d:dict-ref (choose-dict d k) k thunk))
(if (LazyThunk? res) ((LazyThunk-proc res)) res))
(define (dict-remove! d k) (d:dict-remove! (choose-dict d k) k))
;; public keys only
(define (dict-keys d) (d:dict-keys (get-field _kv d)))
(define (dict-iterate-first d) (and (pair? (dict-keys d)) 0))
(define (dict-iterate-next d i) (and (< (add1 i) (length (dict-keys d))) (add1 i)))
(define (dict-iterate-key d i) (list-ref (dict-keys d) i))
(define (dict-iterate-value d i) (dict-ref d (dict-iterate-key d i))))]
[(generic-property gen:custom-write)
(generic-method-table gen:custom-write
(define (write-proc o port mode)
(define proc (case mode
[(#t) write]
[(#f) display]
[else (λ (p port) (print p port mode))]))
(proc (dump o) port)))])))
(define-subclass*/interfaces xenomorph-base% (dictable<%>)
(StructDictRes)
(super-make-object)
(field [_kv (mhasheq)]
[_pvt (mhasheq)])
(define/override (dump)
;; convert to immutable for display & debug
(for/hasheq ([(k v) (in-hash _kv)])
(values k v)))
(define/public (to-hash) _kv))
(define-subclass xenomorph-base% (Struct [fields (dictify)])
(field [[_post-decode post-decode] (λ (val port ctx) val)]
[[_pre-encode pre-encode] (λ (val port) val)]) ; store as field so it can be mutated from outside
(define/overment (post-decode res . args)
(let* ([res (apply _post-decode res args)]
[res (inner res post-decode res . args)])
(unless (dict? res) (raise-result-error 'Struct:post-decode "dict" res))
res))
(define/overment (pre-encode res . args)
(let* ([res (apply _pre-encode res args)]
[res (inner res pre-encode res . args)])
(unless (dict? res) (raise-result-error 'Struct:pre-encode "dict" res))
res))
(unless (or (assocs? fields) (Struct? fields)) ; should be Versioned Struct but whatever
(raise-argument-error 'Struct "assocs or Versioned Struct" fields))
(define/augride (decode stream [parent #f] [len 0])
;; _setup and _parse-fields are separate to cooperate with VersionedStruct
(let* ([sdr (_setup stream parent len)] ; returns StructDictRes
[sdr (_parse-fields stream sdr fields)])
sdr))
(define/public-final (_setup port parent len)
(define sdr (make-object StructDictRes)) ; not mere hash
(dict-set*! sdr 'parent parent
'_startOffset (pos port)
'_currentOffset 0
'_length len)
sdr)
(define/public-final (_parse-fields port sdr fields)
(unless (assocs? fields)
(raise-argument-error '_parse-fields "assocs" fields))
(for/fold ([sdr sdr])
([(key type) (in-dict fields)])
(define val (if (procedure? type)
(type sdr)
(send type decode port sdr)))
(unless (void? val)
(dict-set! sdr key val))
(dict-set! sdr '_currentOffset (- (pos port) (· sdr _startOffset)))
sdr))
(define/augride (size [val #f] [parent #f] [include-pointers #t])
(define ctx (mhasheq 'parent parent
'val val
'pointerSize 0))
(+ (for/sum ([(key type) (in-dict fields)]
#:when (object? type))
(send type size (and val (ref val key)) ctx))
(if include-pointers (· ctx pointerSize) 0)))
(define/augride (encode port val [parent #f])
(unless (dict? val)
(raise-argument-error 'Struct:encode "dict" val))
;; check keys first, since `size` also relies on keys being valid
(unless (andmap (λ (key) (memq key (dict-keys val))) (dict-keys fields))
(raise-argument-error 'Struct:encode
(format "dict that contains superset of Struct keys: ~a" (dict-keys fields)) (dict-keys val)))
(define ctx (mhash 'pointers empty
'startOffset (pos port)
'parent parent
'val val
'pointerSize 0))
(ref-set! ctx 'pointerOffset (+ (pos port) (size val ctx #f)))
(for ([(key type) (in-dict fields)])
(send type encode port (ref val key) ctx))
(for ([ptr (in-list (· ctx pointers))])
(send (· ptr type) encode port (· ptr val) (· ptr parent)))))
(test-module
(require "number.rkt")
(define (random-pick xs) (list-ref xs (random (length xs))))
(check-exn exn:fail:contract? (λ () (+Struct 42)))
;; make random structs and make sure we can round trip
(for ([i (in-range 20)])
(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)])
(send num-type size)))
(define s (+Struct (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? (send s encode #f (send s decode bs)) bs)))

@ -1,91 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Array.coffee
|#
;describe 'Array', ->
; describe 'decode', ->
; it 'should decode fixed length', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint8 4)) '(1 2 3 4)))
; it 'should decode fixed amount of bytes', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint16be 4 'bytes)) '(258 772)))
; it 'should decode length from parent key', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint8 'len) #:parent (mhash 'len 4)) '(1 2 3 4)))
; it 'should decode amount of bytes from parent key', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint16be 'len 'bytes) #:parent (mhash 'len 4)) '(258 772)))
; it 'should decode length as number before array', ->
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint8 uint8)) '(1 2 3 4)))
; it 'should decode amount of bytes as number before array', ->
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint16be uint8 'bytes)) '(258 772)))
; it 'should decode length from function', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint8 (λ _ 4))) '(1 2 3 4)))
; it 'should decode amount of bytes from function', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint16be (λ _ 4) 'bytes)) '(258 772)))
; it 'should decode to the end of the parent if no length is given', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(check-equal? (decode (+ArrayT uint8) #:parent (mhash '_length 4 '_startOffset 0)) '(1 2 3 4)))
; 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? (decode (+ArrayT uint8) #:parent (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5)))
; it 'should decode to the end of the stream if no parent and length is given', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4))])
(check-equal? (decode (+ArrayT uint8)) '(1 2 3 4 )))
; describe 'size', ->
; it 'should use array length', ->
(check-equal? (size (+ArrayT uint8 10) '(1 2 3 4)) 4)
; it 'should add size of length field before string', ->
(check-equal? (size (+ArrayT uint8 uint8) '(1 2 3 4)) 5)
; it 'should use defined length if no value given', ->
(check-equal? (size (+ArrayT uint8 10)) 10)
; describe 'encode', ->
; it 'should encode using array length', (done) ->
(check-equal? (encode (+ArrayT uint8 10) '(1 2 3 4) #f) (bytes 1 2 3 4))
; it 'should encode length as number before array', (done) ->
(check-equal? (encode (+ArrayT uint8 uint8) '(1 2 3 4) #f) (bytes 4 1 2 3 4))
; it 'should add pointers after array if length is encoded at start', (done) ->
(check-equal? (encode (+ArrayT (+Pointer uint8 uint8) uint8) '(1 2 3 4) #f) (bytes 4 5 6 7 8 1 2 3 4))

@ -1,51 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict
racket/list
racket/match)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
|#
;describe 'Bitfield', ->
; bitfield = new Bitfield uint8, ['Jack', 'Kack', 'Lack', 'Mack', 'Nack', 'Oack', 'Pack', 'Quack']
; JACK = 1 << 0
; KACK = 1 << 1
; LACK = 1 << 2
; MACK = 1 << 3
; NACK = 1 << 4
; OACK = 1 << 5
; PACK = 1 << 6
; QUACK = 1 << 7
(define bitfield (+Bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
(match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK)
(map (λ (x) (arithmetic-shift 1 x)) (range 8)))
; it 'should have the right size', ->
(check-equal? (size bitfield) 1)
; it 'should decode', ->
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
(check-equal? (decode bitfield) (mhasheq 'Quack #t
'Nack #t
'Lack #f
'Oack #f
'Pack #t
'Mack #t
'Jack #t
'Kack #f)))
; it 'should encode', (done) ->
(check-equal? (encode bitfield (mhasheq 'Quack #t
'Nack #t
'Lack #f
'Oack #f
'Pack #t
'Mack #t
'Jack #t
'Kack #f) #f)
(bytes (bitwise-ior JACK MACK PACK NACK QUACK)))

@ -1,46 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Buffer.coffee
|#
;describe 'Buffer', ->
; describe 'decode', ->
; it 'should decode', ->
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
(define buf (+BufferT 2))
(check-equal? (decode buf) (bytes #xab #xff))
(check-equal? (decode buf) (bytes #x1f #xb6)))
; it 'should decode with parent key length', ->
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
(define buf (+BufferT 'len))
(check-equal? (decode buf #:parent (hash 'len 3)) (bytes #xab #xff #x1f))
(check-equal? (decode buf #:parent (hash 'len 1)) (bytes #xb6)))
; describe 'size', ->
; it 'should return size', ->
(check-equal? (size (+BufferT 2) (bytes #xab #xff)) 2)
; it 'should use defined length if no value given', ->x
(check-equal? (size (+BufferT 10)) 10)
; describe 'encode', ->
; it 'should encode', (done) ->
(let ([buf (+BufferT 2)])
(check-equal? (bytes-append
(encode buf (bytes #xab #xff) #f)
(encode buf (bytes #x1f #xb6) #f)) (bytes #xab #xff #x1f #xb6)))
; it 'should encode length before buffer', (done) ->
(check-equal? (encode (+BufferT uint8) (bytes #xab #xff) #f) (bytes 2 #xab #xff))

@ -1,37 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Enum.coffee
|#
;describe 'Enum', ->
; e = new Enum uint8, ['foo', 'bar', 'baz']
; it 'should have the right size', ->
; e.size().should.equal 1
(define e (+Enum uint8 '("foo" "bar" "baz")))
(check-equal? (size e) 1)
; it 'should decode', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
(check-equal? (decode e) "bar")
(check-equal? (decode e) "baz")
(check-equal? (decode e) "foo"))
; it 'should encode', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode e "bar")
(encode e "baz")
(encode e "foo")
(check-equal? (dump (current-output-port)) (bytes 1 2 0)))
; it 'should throw on unknown option', ->
(check-exn exn:fail:contract? (λ () (encode e "unknown" (open-output-bytes))))

@ -1,62 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict
"../private/generic.rkt")
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee
|#
;describe 'LazyArray', ->
; describe 'decode', ->
; it 'should decode items lazily', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(define array (+LazyArray uint8 4))
(define arr (decode array))
(check-false (Array? arr))
(check-equal? (ref arr 'len) 4)
(check-equal? (pos (current-input-port)) 4)
(check-equal? (get arr 0) 1)
(check-equal? (get arr 1) 2)
(check-equal? (get arr 2) 3)
(check-equal? (get arr 3) 4))
; it 'should be able to convert to an array', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(define array (+LazyArray uint8 4))
(define arr (decode array))
(check-equal? (LazyArray->list arr) '(1 2 3 4)))
; it 'should have an inspect method', ->
; [skipped]
; it 'should decode length as number before array', ->
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
(define array (+LazyArray uint8 uint8))
(define arr (decode array))
(check-equal? (LazyArray->list arr) '(1 2 3 4)))
;
; describe 'size', ->
; it 'should work with LazyArrays', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(define array (+LazyArray uint8 4))
(define arr (decode array))
(check-equal? (size array arr) 4))
; describe 'encode', ->
; it 'should work with LazyArrays', (done) ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
(define array (+LazyArray uint8 4))
(define arr (decode array))
(check-equal? (encode array arr #f) (bytes 1 2 3 4)))

@ -1,14 +0,0 @@
#lang racket/base
(require "array-test.rkt"
"bitfield-test.rkt"
"buffer-test.rkt"
"enum-test.rkt"
"lazy-array-test.rkt"
"number-test.rkt"
"optional-test.rkt"
"pointer-test.rkt"
"reserved-test.rkt"
"string-test.rkt"
"struct-test.rkt"
"versioned-struct-test.rkt")

@ -1,339 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
racket/class
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Number.coffee
|#
;describe 'Number', ->
; describe 'uint8', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
(check-equal? (decode uint8) #xab)
(check-equal? (decode uint8) #xff))
(check-equal? (size uint8) 1)
(let ([port (open-output-bytes)])
(encode uint8 #xab port)
(encode uint8 #xff port)
(check-equal? (dump port) (bytes #xab #xff)))
; describe 'uint16', ->
; it 'is an alias for uint16be', ->
; modified test: `uint16` is the same endianness as the platform
(check-equal? (decode uint16 (bytes 0 1)) (send (if (system-big-endian?)
uint16be
uint16le) decode (bytes 0 1)))
; describe 'uint16be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode uint16be (open-input-bytes (bytes #xab #xff))) #xabff)
(check-equal? (size uint16be) 2)
(check-equal? (encode uint16be #xabff #f) (bytes #xab #xff))
;
; describe 'uint16le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode uint16le (open-input-bytes (bytes #xff #xab))) #xabff)
(check-equal? (size uint16le) 2)
(check-equal? (encode uint16le #xabff #f) (bytes #xff #xab))
;
; describe 'uint24', ->
; it 'is an alias for uint24be', ->
;; modified test: `uint24` is the same endianness as the platform
(check-equal? (decode uint24 (bytes 0 1 2)) (send (if (system-big-endian?)
uint24be
uint24le) decode (bytes 0 1 2)))
;
; describe 'uint24be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode uint24be (open-input-bytes (bytes #xff #xab #x24))) #xffab24)
(check-equal? (size uint24be) 3)
(check-equal? (encode uint24be #xffab24 #f) (bytes #xff #xab #x24))
;
; describe 'uint24le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode uint24le (open-input-bytes (bytes #x24 #xab #xff))) #xffab24)
(check-equal? (size uint24le) 3)
(check-equal? (encode uint24le #xffab24 #f) (bytes #x24 #xab #xff))
;
; describe 'uint32', ->
; it 'is an alias for uint32be', ->
;; modified test: `uint32` is the same endianness as the platform
(check-equal? (decode uint32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
uint32be
uint32le) decode (bytes 0 1 2 3)))
;
; describe 'uint32be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode uint32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) #xffab24bf)
(check-equal? (size uint32be) 4)
(check-equal? (encode uint32be #xffab24bf #f) (bytes #xff #xab #x24 #xbf))
;
; describe 'uint32le', ->
; it 'should decode', ->
; it 'should encode', (done) ->
(check-equal? (decode uint32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) #xffab24bf)
(check-equal? (size uint32le) 4)
(check-equal? (encode uint32le #xffab24bf #f) (bytes #xbf #x24 #xab #xff))
;
; describe 'int8', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(let ([port (open-input-bytes (bytes #x7f #xff))])
(check-equal? (decode int8 port) 127)
(check-equal? (decode int8 port) -1))
(check-equal? (size int8) 1)
(let ([port (open-output-bytes)])
(encode int8 127 port)
(encode int8 -1 port)
(check-equal? (dump port) (bytes #x7f #xff)))
;
; describe 'int16', ->
; it 'is an alias for int16be', ->
; int16.should.equal int16be
;; modified test: `int16` is the same endianness as the platform
(check-equal? (decode int16 (bytes 0 1)) (send (if (system-big-endian?)
int16be
int16le) decode (bytes 0 1)))
;
; describe 'int16be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(let ([port (open-input-bytes (bytes #xff #xab))])
(check-equal? (decode int16be port) -85))
(check-equal? (size int16be) 2)
(let ([port (open-output-bytes)])
(encode int16be -85 port)
(check-equal? (dump port) (bytes #xff #xab)))
; describe 'int16le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode int16le (open-input-bytes (bytes #xab #xff))) -85)
(check-equal? (size int16le) 2)
(check-equal? (encode int16le -85 #f) (bytes #xab #xff))
;
; describe 'int24', ->
; it 'is an alias for int24be', ->
; int24.should.equal int24be
;; modified test: `int24` is the same endianness as the platform
(check-equal? (decode int24 (bytes 0 1 2)) (send (if (system-big-endian?)
int24be
int24le) decode (bytes 0 1 2)))
;
; describe 'int24be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode int24be (open-input-bytes (bytes #xff #xab #x24))) -21724)
(check-equal? (size int24be) 3)
(check-equal? (encode int24be -21724 #f) (bytes #xff #xab #x24))
;
; describe 'int24le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode int24le (open-input-bytes (bytes #x24 #xab #xff))) -21724)
(check-equal? (size int24le) 3)
(check-equal? (encode int24le -21724 #f) (bytes #x24 #xab #xff))
; describe 'int32', ->
; it 'is an alias for int32be', ->
; modified test: `int32` is the same endianness as the platform
(check-equal? (decode int32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
int32be
int32le) decode (bytes 0 1 2 3)))
;
; describe 'int32be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode int32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) -5561153)
(check-equal? (size int32be) 4)
(check-equal? (encode int32be -5561153 #f) (bytes #xff #xab #x24 #xbf))
;
; describe 'int32le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode int32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) -5561153)
(check-equal? (size int32le) 4)
(check-equal? (encode int32le -5561153 #f) (bytes #xbf #x24 #xab #xff))
;
; describe 'float', ->
; it 'is an alias for floatbe', ->
; modified test: `float` is the same endianness as the platform
(check-equal? (decode float (bytes 0 1 2 3)) (send (if (system-big-endian?)
floatbe
floatle) decode (bytes 0 1 2 3)))
;
; describe 'floatbe', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-= (decode floatbe (open-input-bytes (bytes #x43 #x7a #x8c #xcd))) 250.55 0.01)
(check-equal? (size floatbe) 4)
(check-equal? (encode floatbe 250.55 #f) (bytes #x43 #x7a #x8c #xcd))
;
; describe 'floatle', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-= (decode floatle (open-input-bytes (bytes #xcd #x8c #x7a #x43))) 250.55 0.01)
(check-equal? (size floatle) 4)
(check-equal? (encode floatle 250.55 #f) (bytes #xcd #x8c #x7a #x43))
;
; describe 'double', ->
; it 'is an alias for doublebe', ->
; modified test: `double` is the same endianness as the platform
(check-equal? (decode double (bytes 0 1 2 3 4 5 6 7)) (send (if (system-big-endian?)
doublebe
doublele) decode (bytes 0 1 2 3 4 5 6 7)))
;
; describe 'doublebe', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode doublebe (open-input-bytes (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))) 1234.56)
(check-equal? (size doublebe) 8)
(check-equal? (encode doublebe 1234.56 #f) (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))
;
; describe 'doublele', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-equal? (decode doublele (open-input-bytes (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))) 1234.56)
(check-equal? (size doublele) 8)
(check-equal? (encode doublele 1234.56 #f) (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))
;
; describe 'fixed16', ->
; it 'is an alias for fixed16be', ->
; modified test: `fixed16` is the same endianness as the platform
(check-equal? (decode fixed16 (bytes 0 1)) (send (if (system-big-endian?)
fixed16be
fixed16le) decode (bytes 0 1)))
;
; describe 'fixed16be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-= (decode fixed16be (open-input-bytes (bytes #x19 #x57))) 25.34 0.01)
(check-equal? (size fixed16be) 2)
(check-equal? (encode fixed16be 25.34 #f) (bytes #x19 #x57))
;
; describe 'fixed16le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-= (decode fixed16le (open-input-bytes (bytes #x57 #x19))) 25.34 0.01)
(check-equal? (size fixed16le) 2)
(check-equal? (encode fixed16le 25.34 #f) (bytes #x57 #x19))
;
; describe 'fixed32', ->
; it 'is an alias for fixed32be', ->
; modified test: `fixed32` is the same endianness as the platform
(check-equal? (decode fixed32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
fixed32be
fixed32le) decode (bytes 0 1 2 3)))
;
; describe 'fixed32be', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-= (decode fixed32be (open-input-bytes (bytes #x00 #xfa #x8c #xcc))) 250.55 0.01)
(check-equal? (size fixed32be) 4)
(check-equal? (encode fixed32be 250.55 #f) (bytes #x00 #xfa #x8c #xcc))
;
; describe 'fixed32le', ->
; it 'should decode', ->
; it 'should have a size', ->
; it 'should encode', (done) ->
(check-= (decode fixed32le (open-input-bytes (bytes #xcc #x8c #xfa #x00))) 250.55 0.01)
(check-equal? (size fixed32le) 4)
(check-equal? (encode fixed32le 250.55 #f) (bytes #xcc #x8c #xfa #x00))

@ -1,116 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee
|#
;describe 'Optional', ->
; describe 'decode', ->
; it 'should not decode when condition is falsy', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
(define optional (+Optional uint8 #f))
(check-equal? (decode optional) (void))
(check-equal? (pos (current-input-port)) 0))
; it 'should not decode when condition is a function and falsy', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
(define optional (+Optional uint8 (λ _ #f)))
(check-equal? (decode optional) (void))
(check-equal? (pos (current-input-port)) 0))
; it 'should decode when condition is omitted', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
(define optional (+Optional uint8))
(check-not-equal? (decode optional) (void))
(check-equal? (pos (current-input-port)) 1))
;
; it 'should decode when condition is truthy', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
(define optional (+Optional uint8 #t))
(check-not-equal? (decode optional) (void))
(check-equal? (pos (current-input-port)) 1))
; it 'should decode when condition is a function and truthy', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
(define optional (+Optional uint8 (λ _ #t)))
(check-not-equal? (decode optional) (void))
(check-equal? (pos (current-input-port)) 1))
; describe 'size', ->
(check-equal? (size (+Optional uint8 #f)) 0)
;
; it 'should return 0 when condition is a function and falsy', ->
(check-equal? (size (+Optional uint8 (λ _ #f))) 0)
; it 'should return given type size when condition is omitted', ->
(check-equal? (size (+Optional uint8)) 1)
; it 'should return given type size when condition is truthy', ->
(check-equal? (size (+Optional uint8 #t)) 1)
; it 'should return given type size when condition is a function and truthy', ->
(check-equal? (size (+Optional uint8 (λ _ #t))) 1)
; describe 'encode', ->
; it 'should not encode when condition is falsy', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define optional (+Optional uint8 #f))
(encode optional 128)
(check-equal? (dump (current-output-port)) (bytes)))
; it 'should not encode when condition is a function and falsy', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define optional (+Optional uint8 (λ _ #f)))
(encode optional 128)
(check-equal? (dump (current-output-port)) (bytes)))
;
; it 'should encode when condition is omitted', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define optional (+Optional uint8))
(encode optional 128)
(check-equal? (dump (current-output-port)) (bytes 128)))
; it 'should encode when condition is truthy', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define optional (+Optional uint8 #t))
(encode optional 128)
(check-equal? (dump (current-output-port)) (bytes 128)))
; it 'should encode when condition is a function and truthy', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define optional (+Optional uint8 (λ _ #t)))
(encode optional 128)
(check-equal? (dump (current-output-port)) (bytes 128)))

@ -1,239 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/js
sugar/unstable/dict
racket/class
"../private/helper.rkt")
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
|#
;describe 'Pointer', ->
; describe 'decode', ->
; it 'should handle null pointers', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
(check-false (decode (+Pointer uint8 uint8) #:parent (mhash '_startOffset 50))))
; it 'should use local offsets from start of parent by default', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
(check-equal? (decode (+Pointer uint8 uint8) #:parent (mhash '_startOffset 0)) 53))
; it 'should support immediate offsets', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'immediate))) 53))
; it '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 (+Pointer uint8 uint8 (mhash 'type 'parent))
#:parent (mhash 'parent (mhash '_startOffset 2))) 53))
; it '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 (+Pointer uint8 uint8 (mhash 'type 'global))
#:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
53))
; it '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 (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx parent ptr))))
#:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
53))
; it 'should support returning pointer if there is no decode type', ->
(parameterize ([current-input-port (open-input-bytes (bytes 4))])
(check-equal? (decode (+Pointer uint8 'void)
#:parent (mhash '_startOffset 0)) 4))
; it 'should support decoding pointers lazily', ->
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
(define res (decode (+Struct (dictify 'ptr (+Pointer uint8 uint8 (mhasheq 'lazy #t))))))
(check-true (LazyThunk? (hash-ref (get-field _kv res) 'ptr)))
(check-equal? (· res ptr) 53))
; describe 'size', ->
(let ([ctx (mhash 'pointerSize 0)])
(check-equal? (size (+Pointer uint8 uint8) 10 ctx) 1)
(check-equal? (· ctx pointerSize) 1))
; it 'should add to immediate pointerSize', ->
(let ([ctx (mhash 'pointerSize 0)])
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'immediate)) 10 ctx) 1)
(check-equal? (· ctx pointerSize) 1))
; it 'should add to parent pointerSize', ->
(let ([ctx (mhash 'parent (mhash 'pointerSize 0))])
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'parent)) 10 ctx) 1)
(check-equal? (· ctx parent pointerSize) 1))
; it 'should add to global pointerSize', ->
(let ([ctx (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'global)) 10 ctx) 1)
(check-equal? (· ctx parent parent parent pointerSize) 1))
; it 'should handle void pointers', ->
(let ([ctx (mhash 'pointerSize 0)])
(check-equal? (size (+Pointer uint8 'void) (+VoidPointer uint8 50) ctx) 1)
(check-equal? (· ctx pointerSize) 1))
; it 'should throw if no type and not a void pointer', ->
(let ([ctx (mhash 'pointerSize 0)])
(check-exn exn:fail:contract? (λ () (size (+Pointer uint8 'void) 30 ctx))))
; it 'should return a fixed size without a value', ->
(check-equal? (size (+Pointer uint8 uint8)) 1)
; describe 'encode', ->
; it 'should handle null pointers', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0
'startOffset 0
'pointerOffset 0
'pointers null))
(encode (+Pointer uint8 uint8) #f #:parent ctx)
(check-equal? (· ctx pointerSize) 0)
(check-equal? (dump (current-output-port)) (bytes 0)))
; it 'should handle local offsets', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0
'startOffset 0
'pointerOffset 1
'pointers null))
(encode (+Pointer uint8 uint8) 10 #:parent ctx)
(check-equal? (· ctx pointerOffset) 2)
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
'val 10
'parent ctx)))
(check-equal? (dump (current-output-port)) (bytes 1)))
; it 'should handle immediate offsets', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0
'startOffset 0
'pointerOffset 1
'pointers null))
(encode (+Pointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent ctx)
(check-equal? (· ctx pointerOffset) 2)
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
'val 10
'parent ctx)))
(check-equal? (dump (current-output-port)) (bytes 0)))
; it 'should handle offsets relative to parent', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'parent (mhash 'pointerSize 0
'startOffset 3
'pointerOffset 5
'pointers null)))
(encode (+Pointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent ctx)
(check-equal? (· ctx parent pointerOffset) 6)
(check-equal? (· ctx parent pointers) (list (mhasheq 'type uint8
'val 10
'parent ctx)))
(check-equal? (dump (current-output-port)) (bytes 2)))
; it 'should handle global offsets', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'parent
(mhash 'parent
(mhash 'parent (mhash 'pointerSize 0
'startOffset 3
'pointerOffset 5
'pointers null)))))
(encode (+Pointer uint8 uint8 (mhash 'type 'global)) 10 #:parent ctx)
(check-equal? (· ctx parent parent parent pointerOffset) 6)
(check-equal? (· ctx parent parent parent pointers) (list (mhasheq 'type uint8
'val 10
'parent ctx)))
(check-equal? (dump (current-output-port)) (bytes 5)))
; it 'should support offsets relative to a property on the parent', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0
'startOffset 0
'pointerOffset 10
'pointers null
'val (mhash 'ptr 4)))
(encode (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx ptr)))) 10 #:parent ctx)
(check-equal? (· ctx pointerOffset) 11)
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
'val 10
'parent ctx)))
(check-equal? (dump (current-output-port)) (bytes 6)))
; it 'should support void pointers', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0
'startOffset 0
'pointerOffset 1
'pointers null))
(encode (+Pointer uint8 'void) (+VoidPointer uint8 55) #:parent ctx)
(check-equal? (· ctx pointerOffset) 2)
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
'val 55
'parent ctx)))
(check-equal? (dump (current-output-port)) (bytes 1)))
; it 'should throw if not a void pointer instance', ->
(parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0
'startOffset 0
'pointerOffset 1
'pointers null))
(check-exn exn:fail:contract? (λ () (encode (+Pointer uint8 'void) 44 #:parent ctx))))

@ -1,35 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Reserved.coffee
|#
;describe 'Reserved', ->
; it 'should have a default count of 1', ->
(check-equal? (size (+Reserved uint8)) 1)
; it 'should allow custom counts and types', ->
(check-equal? (size (+Reserved uint16be 10)) 20)
; it 'should decode', ->
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
(define reserved (+Reserved uint16be))
(check-equal? (decode reserved) (void))
(check-equal? (pos (current-input-port)) 2))
; it 'should encode', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define reserved (+Reserved uint16be))
(encode reserved #f)
(check-equal? (dump (current-output-port)) (bytes 0 0)))

@ -1,131 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/String.coffee
|#
;describe 'String', ->
; describe 'decode', ->
; it 'should decode fixed length', ->
(parameterize ([current-input-port (open-input-bytes #"testing")])
(check-equal? (decode (+StringT 7)) "testing"))
; it 'should decode length from parent key', ->
(parameterize ([current-input-port (open-input-bytes #"testing")])
(check-equal? (decode (+StringT 'len) #:parent (mhash 'len 7)) "testing"))
; it 'should decode length as number before string', ->
(parameterize ([current-input-port (open-input-bytes #"\x07testing")])
(check-equal? (decode (+StringT uint8) #:parent (mhash 'len 7)) "testing"))
;; it 'should decode utf8', ->
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
(check-equal? (decode (+StringT 4 'utf8)) "🍻"))
;; it 'should decode encoding computed from function', ->
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
(check-equal? (decode (+StringT 4 (λ _ 'utf8))) "🍻"))
; it 'should decode null-terminated string and read past terminator', ->
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻\x00"))])
(check-equal? (decode (+StringT #f 'utf8)) "🍻")
(check-equal? (pos (current-input-port)) 5))
; it 'should decode remainder of buffer when null-byte missing', ->
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
(check-equal? (decode (+StringT #f 'utf8)) "🍻"))
; describe 'size', ->
; it 'should use string length', ->
(check-equal? (size (+StringT 7) "testing") 7)
; it 'should use correct encoding', ->
(check-equal? (size (+StringT 10 'utf8) "🍻") 4)
; it 'should use encoding from function', ->
(check-equal? (size (+StringT 10 (λ _ 'utf8)) "🍻") 4)
; it 'should add size of length field before string', ->
(check-equal? (size (+StringT uint8 'utf8) "🍻") 5)
; todo
; it 'should work with utf16be encoding', ->
; it 'should take null-byte into account', ->
(check-equal? (size (+StringT #f 'utf8) "🍻") 5)
; it 'should use defined length if no value given', ->
(check-equal? (size (+StringT 10)) 10)
;
; describe 'encode', ->
; it 'should encode using string length', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode (+StringT 7) "testing")
(check-equal? (dump (current-output-port)) #"testing"))
; it 'should encode length as number before string', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode (+StringT uint8) "testing")
(check-equal? (dump (current-output-port)) #"\x07testing"))
; it 'should encode length as number before string utf8', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode (+StringT uint8 'utf8) "testing 😜")
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "\x0ctesting 😜")))
; it 'should encode utf8', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode (+StringT 4 'utf8) "🍻" )
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻")))
; it 'should encode encoding computed from function', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode (+StringT 4 (λ _ 'utf8)) "🍻")
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻")))
; it 'should encode null-terminated string', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(encode (+StringT #f 'utf8) "🍻" )
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻\x00")))

@ -1,126 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
racket/class
sugar/unstable/dict
sugar/unstable/js
"../private/generic.rkt")
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
|#
;describe 'Struct', ->
; describe 'decode', ->
; it 'should decode into an object', ->
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
(check-equal?
(dump (decode (+Struct (dictify 'name (+StringT uint8)
'age uint8))))
(hasheq 'name "roxyb" 'age 21)))
; it 'should support process hook', ->
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
(define struct (+Struct (dictify 'name (+StringT uint8)
'age uint8)))
(set-field! post-decode struct (λ (o . _) (ref-set! o 'canDrink (>= (· o age) 21)) o))
(check-equal? (dump (decode struct))
(hasheq 'name "roxyb" 'age 32 'canDrink #t)))
; it 'should support function keys', ->
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
(define struct (+Struct (dictify 'name (+StringT uint8)
'age uint8
'canDrink (λ (o) (>= (ref o 'age) 21)))))
(check-equal? (dump (decode struct))
(hasheq 'name "roxyb" 'age 32 'canDrink #t)))
;
; describe 'size', ->
; it 'should compute the correct size', ->
(check-equal? (size (+Struct (dictify
'name (+StringT uint8)
'age uint8))
(hasheq 'name "roxyb" 'age 32)) 7)
; it 'should compute the correct size with pointers', ->
(check-equal? (size (+Struct (dictify
'name (+StringT uint8)
'age uint8
'ptr (+Pointer uint8 (+StringT uint8))))
(mhash 'name "roxyb" 'age 21 'ptr "hello")) 14)
; it 'should get the correct size when no value is given', ->
(check-equal? (size (+Struct (dictify
'name (+StringT 4)
'age uint8))) 5)
; it 'should throw when getting non-fixed length size and no value is given', ->
(check-exn exn:fail:contract? (λ () (size (+Struct (dictify 'name (+StringT uint8)
'age uint8)))))
;
; describe 'encode', ->
; it 'should encode objects to buffers', (done) ->
; stream = new EncodeStream
; stream.pipe concat (buf) ->
; buf.should.deep.equal new Buffer '\x05roxyb\x15'
; done()
;
; struct = new Struct
; name: new StringT uint8
; age: uint8
;
; struct.encode stream,
; name: 'roxyb'
; age: 21
;
; stream.end()
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
(check-equal? (dump (decode (+Struct (dictify 'name (+StringT uint8)
'age uint8))))
(hasheq 'name "roxyb" 'age 21)))
; it 'should support preEncode hook', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define struct (+Struct (dictify 'nameLength uint8
'name (+StringT 'nameLength)
'age uint8)))
(set-field! pre-encode struct (λ (val port) (ref-set! val 'nameLength (length (ref val 'name))) val))
(encode struct (mhasheq 'name "roxyb" 'age 21))
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15"))
; it 'should encode pointer data after structure', (done) ->
(parameterize ([current-output-port (open-output-bytes)])
(define struct (+Struct (dictify 'name (+StringT uint8)
'age uint8
'ptr (+Pointer uint8 (+StringT uint8)))))
(encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello"))

@ -1,21 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
racket/class)
(define Person
(make-object Struct
(list (cons 'name (make-object StringT uint8 'utf8))
(cons 'age uint8))))
;; decode a person from a port
(define ip (open-input-bytes #"\4MikeA"))
(define x (send Person decode ip))
(module+ test
(check-equal? (dict-ref x 'name) "Mike")
(check-equal? (dict-ref x 'age) 65))
;; encode a person from a hash
(module+ test
(check-equal? (send Person encode #f (hasheq 'name "Mike" 'age 65)) #"\4MikeA"))

@ -1,344 +0,0 @@
#lang racket/base
(require rackunit
xenomorph
racket/class
"../private/generic.rkt"
sugar/unstable/dict)
#|
approximates
https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffee
|#
;describe 'VersionedStruct', ->
; describe 'decode', ->
; it 'should get version from number type', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
'age 21
'version 0)))
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 🤘\x15\x00"))])
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘"
'age 21
'version 1
'gender 0))))
; it 'should throw for unknown version', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")])
(check-exn exn:fail:contract? (λ () (decode struct)))))
;
; it 'should support common header block', ->
(let ([struct (+VersionedStruct uint8
(dictify
'header (dictify 'age uint8
'alive uint8)
0 (dictify 'name (+StringT uint8 'ascii))
1 (dictify 'name (+StringT uint8 'utf8)
'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
'age 21
'alive 1
'version 0)))
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 🤘\x00"))])
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘"
'age 21
'version 1
'alive 1
'gender 0))))
; it 'should support parent version key', ->
(let ([struct (+VersionedStruct 'version
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb"
'age 21
'version 0)))
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))])
(check-equal? (dump (decode struct #:parent (mhash 'version 1))) (hasheq 'name "roxyb 🤘"
'age 21
'version 1
'gender 0))))
;
; it 'should support sub versioned structs', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8))
1 (dictify 'name (+StringT uint8)
'isDessert uint8)))))])
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb"
'age 21
'version 0)))
(parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")])
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "pasta"
'version 0)))
(parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")])
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "ice cream"
'isDessert 1
'version 1))))
;
; it 'should support process hook', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(set-field! post-decode struct (λ (o stream ctx) (ref-set! o 'processed "true") o))
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
'processed "true"
'age 21
'version 0))))
;
; describe 'size', ->
; it 'should compute the correct size', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(check-equal? (size struct (mhasheq 'name "roxyb"
'age 21
'version 0)) 8)
(check-equal? (size struct (mhasheq 'name "roxyb 🤘"
'gender 0
'age 21
'version 1)) 14))
;
; it 'should throw for unknown version', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(check-exn exn:fail:contract? (λ () (size struct (mhasheq 'name "roxyb"
'age 21
'version 5)))))
;
; it 'should support common header block', ->
(let ([struct (+VersionedStruct uint8
(dictify
'header (dictify 'age uint8
'alive uint8)
0 (dictify 'name (+StringT uint8 'ascii))
1 (dictify 'name (+StringT uint8 'utf8)
'gender uint8)))])
(check-equal? (size struct (mhasheq 'name "roxyb"
'age 21
'alive 1
'version 0)) 9)
(check-equal? (size struct (mhasheq 'name "roxyb 🤘"
'gender 0
'age 21
'alive 1
'version 1)) 15))
; it 'should compute the correct size with pointers', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'ptr (+Pointer uint8 (+StringT uint8)))))])
(check-equal? (size struct (mhasheq 'name "roxyb"
'age 21
'version 1
'ptr "hello")) 15))
;
; it 'should throw if no value is given', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))])
(check-exn exn:fail:contract? (λ () (size struct))))
; describe 'encode', ->
; it 'should encode objects to buffers', (done) ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))]
[port (open-output-bytes)])
(encode struct (mhasheq 'name "roxyb"
'age 21
'version 0) port)
(encode struct (mhasheq 'name "roxyb 🤘"
'age 21
'gender 0
'version 1) port)
(check-equal? (dump port) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))
;
; it 'should throw for unknown version', ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))]
[port (open-output-bytes)])
(check-exn exn:fail:contract? (λ () (encode struct port (mhasheq 'name "roxyb"
'age 21
'version 5)))))
; it 'should support common header block', (done) ->
(let ([struct (+VersionedStruct uint8
(dictify
'header (dictify 'age uint8
'alive uint8)
0 (dictify 'name (+StringT uint8 'ascii))
1 (dictify 'name (+StringT uint8 'utf8)
'gender uint8)))]
[stream (open-output-bytes)])
(encode struct (mhasheq 'name "roxyb"
'age 21
'alive 1
'version 0) stream)
(encode struct (mhasheq 'name "roxyb 🤘"
'gender 0
'age 21
'alive 1
'version 1) stream)
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x15\x01\x05roxyb\x01\x15\x01\x0aroxyb 🤘\x00")))
; it 'should encode pointer data after structure', (done) ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'ptr (+Pointer uint8 (+StringT uint8)))))]
[stream (open-output-bytes)])
(encode struct (mhasheq 'version 1
'name "roxyb"
'age 21
'ptr "hello") stream)
(check-equal? (dump stream) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello")))
; it 'should support preEncode hook', (done) ->
(let ([struct (+VersionedStruct uint8
(dictify
0 (dictify 'name (+StringT uint8 'ascii)
'age uint8)
1 (dictify 'name (+StringT uint8 'utf8)
'age uint8
'gender uint8)))]
[stream (open-output-bytes)])
(set-field! pre-encode struct (λ (val port) (ref-set! val 'version (if (ref val 'gender) 1 0)) val))
(encode struct (mhasheq 'name "roxyb"
'age 21
'version 0) stream)
(encode struct (mhasheq 'name "roxyb 🤘"
'age 21
'gender 0) stream)
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))

@ -1,15 +0,0 @@
#lang racket/base
(require racket/class
"number.rkt"
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
(define (resolve-length len-arg [stream #f] [parent #f])
(cond
[(not len-arg) #f]
[(number? len-arg) len-arg]
[(procedure? len-arg) (len-arg parent)]
[(and parent (key? len-arg)) (ref parent len-arg)] ; treat as key into RStruct parent
[(and stream (NumberT? len-arg)) (send len-arg decode stream)]
[else (raise-argument-error 'resolveLength "fixed-size argument" len-arg)]))

@ -1,155 +0,0 @@
#lang racket/base
(require racket/class
racket/list
sugar/unstable/class
sugar/unstable/dict
sugar/unstable/js
racket/dict
"struct.rkt"
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee
|#
(define-subclass Struct (VersionedStruct type [versions (dictify)])
(unless (for/or ([proc (list integer? procedure? xenomorph-base%? symbol?)])
(proc type))
(raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" type))
(unless (and (dict? versions) (andmap (λ (val) (or (dict? val) (Struct? val))) (map cdr versions)))
(raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions))
(inherit _setup _parse-fields post-decode)
(inherit-field fields)
(field [forced-version #f]
[versionGetter void]
[versionSetter void])
(when (or (key? type) (procedure? type))
(set-field! versionGetter this (if (procedure? type)
type
(λ (parent) (ref parent type))))
(set-field! versionSetter this (if (procedure? type)
type
(λ (parent version) (ref-set! parent type version)))))
(define/override (decode stream [parent #f] [length 0])
(define res (_setup stream parent length))
(ref-set! res 'version
(cond
[forced-version] ; for testing purposes: pass an explicit version
[(or (key? type) (procedure? type))
(unless parent
(raise-argument-error 'VersionedStruct:decode "valid parent" parent))
(versionGetter parent)]
[else (send type decode stream)]))
(when (ref versions 'header)
(_parse-fields stream res (ref versions 'header)))
(define fields (or (ref versions (ref res 'version)) (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions)))))
(cond
[(VersionedStruct? fields) (send fields decode stream parent)]
[else
(_parse-fields stream res fields)
res]))
(define/public-final (force-version! version)
(set! forced-version version))
(define/override (encode stream val [parent #f])
(unless (hash? val)
(raise-argument-error 'VersionedStruct:encode "hash" val))
(define ctx (mhash 'pointers empty
'startOffset (pos stream)
'parent parent
'val val
'pointerSize 0))
(ref-set! ctx 'pointerOffset (+ (pos stream) (size val ctx #f)))
(when (not (or (key? type) (procedure? type)))
(send type encode stream (or forced-version (· val version))))
(when (ref versions 'header)
(for ([(key type) (in-dict (ref versions 'header))])
(send type encode stream (ref val key) ctx)))
(define fields (or (ref versions (or forced-version (· val version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
(unless (andmap (λ (key) (member key (ref-keys val))) (ref-keys fields))
(raise-argument-error 'VersionedStruct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
(for ([(key type) (in-dict fields)])
(send type encode stream (ref val key) ctx))
(for ([ptr (in-list (ref ctx 'pointers))])
(send (ref ptr 'type) encode stream (ref ptr 'val) (ref ptr 'parent))))
(define/override (size [val #f] [parent #f] [includePointers #t])
(unless (or val forced-version)
(raise-argument-error 'VersionedStruct:size "value" val))
(define ctx (mhash 'parent parent
'val val
'pointerSize 0))
(+ (if (not (or (key? type) (procedure? type)))
(send type size (or forced-version (ref val 'version)) ctx)
0)
(for/sum ([(key type) (in-dict (or (ref versions 'header) empty))])
(send type size (and val (ref val key)) ctx))
(let ([fields (or (ref versions (or forced-version (ref val 'version)))
(raise-argument-error 'VersionedStruct:encode "valid version key" version))])
(for/sum ([(key type) (in-dict fields)])
(send type size (and val (ref val key)) ctx)))
(if includePointers (ref ctx 'pointerSize) 0))))
#;(test-module
(require "number.rkt")
(define (random-pick xs) (list-ref xs (random (length xs))))
(check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42)))
;; make random versioned structs and make sure we can round trip
#;(for ([i (in-range 1)])
(define field-types (for/list ([i (in-range 1)])
(random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
(define num-versions 20)
(define which-struct (random num-versions))
(define struct-versions (for/list ([v (in-range num-versions)])
(cons v (for/list ([num-type (in-list field-types)])
(cons (gensym) num-type)))))
(define vs (+VersionedStruct which-struct struct-versions))
(define struct-size (for/sum ([num-type (in-list (map cdr (ref struct-versions which-struct)))])
(send num-type size)))
(define bs (apply bytes (for/list ([i (in-range struct-size)])
(random 256))))
(check-equal? (send vs encode #f (send vs decode bs)) bs))
(define s (+Struct (dictify 'a uint8 'b uint8 'c uint8)))
(check-equal? (send s size) 3)
(define vs (+VersionedStruct uint8 (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s))))
(send vs force-version! 1)
(check-equal? (send vs size) 6)
#|
(define s2 (+Struct (dictify 'a vs)))
(check-equal? (send s2 size) 6)
(define vs2 (+VersionedStruct (λ (p) 2) (dictify 1 vs 2 vs)))
(check-equal? (send vs2 size) 6)
|#
)
Loading…
Cancel
Save