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

glory

Browse Source
main
Matthew Butterick 6 years ago
parent 57e70b5802
commit 1b8557373b
29 changed files with 987 additions and 1054 deletions
Show Stats Download Patch File Download Diff File

81
xenomorph/xenomorph/array.rkt
Unescape Escape View File

@ -1,5 +1,84 @@
#lang racket/base
(require "private/racket.rkt")
(require "number.rkt" "utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
|#
(r+p "private/array.rkt")
(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)])
(unless (= item-count max-items)
(raise-argument-error 'Array:encode (format "list or countable with ~a items" max-items) items))
(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-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))

5
xenomorph/xenomorph/base.rkt
Unescape Escape View File

@ -1,5 +0,0 @@
#lang racket/base
(require "private/racket.rkt")
(r+p "private/base.rkt")

41
xenomorph/xenomorph/bitfield.rkt
Unescape Escape View File

@ -1,5 +1,44 @@
#lang racket/base
(require "private/racket.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
|#
(r+p "private/bitfield.rkt")
(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"))

53
xenomorph/xenomorph/buffer.rkt
Unescape Escape View File

@ -1,5 +1,56 @@
#lang racket/base
(require "private/racket.rkt")
(require "number.rkt" "utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
|#
(r+p "private/buffer.rkt")
#|
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))

20
xenomorph/xenomorph/enum.rkt
Unescape Escape View File

@ -1,5 +1,23 @@
#lang racket/base
(require "private/racket.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)))
(r+p "private/enum.rkt")

74
xenomorph/xenomorph/lazy-array.rkt
Unescape Escape View File

@ -1,5 +1,77 @@
#lang racket/base
(require "private/racket.rkt")
(require "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)))
(r+p "private/lazy-array.rkt")

2
xenomorph/xenomorph/main.rkt
Unescape Escape View File

@ -1,9 +1,7 @@
#lang racket/base
(require "private/racket.rkt")
(r+p "array.rkt"
"base.rkt"
"bitfield.rkt"
"buffer.rkt"
"enum.rkt"

186
xenomorph/xenomorph/number.rkt
Unescape Escape View File

@ -1,5 +1,189 @@
#lang racket/base
(require "private/racket.rkt")
(require "sizes.rkt" (for-syntax "sizes.rkt" racket/match))
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
|#
(r+p "private/number.rkt")
(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) identity 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 empty] [n val])
([i (in-range _size)])
(values (cons (bitwise-and n #xff) bs) (arithmetic-shift n -8))))
(apply bytes ((if (eq? endian 'be) identity 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-macro (make-int-types)
(with-pattern ([((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 ...) (suffix-id #'(ID ...) #:context caller-stx)])
#'(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)))

25
xenomorph/xenomorph/optional.rkt
Unescape Escape View File

@ -1,5 +1,28 @@
#lang racket/base
(require "private/racket.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))))
(r+p "private/optional.rkt")

99
xenomorph/xenomorph/pointer.rkt
Unescape Escape View File

@ -1,5 +1,102 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/undefined)
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
|#
(r+p "private/pointer.rkt")
(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))

84
xenomorph/xenomorph/private/array.rkt
Unescape Escape View File

@ -1,84 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require "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)])
(unless (= item-count max-items)
(raise-argument-error 'Array:encode (format "list or countable with ~a items" max-items) items))
(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-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))

44
xenomorph/xenomorph/private/bitfield.rkt
Unescape Escape View File

@ -1,44 +0,0 @@
#lang racket/base
(require "racket.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"))

56
xenomorph/xenomorph/private/buffer.rkt
Unescape Escape View File

@ -1,56 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require "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))

23
xenomorph/xenomorph/private/enum.rkt
Unescape Escape View File

@ -1,23 +0,0 @@
#lang racket/base
(require "racket.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)))

77
xenomorph/xenomorph/private/lazy-array.rkt
Unescape Escape View File

@ -1,77 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require "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)))

189
xenomorph/xenomorph/private/number.rkt
Unescape Escape View File

@ -1,189 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require "sizes.rkt" (for-syntax "sizes.rkt" racket/match))
(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) identity 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 empty] [n val])
([i (in-range _size)])
(values (cons (bitwise-and n #xff) bs) (arithmetic-shift n -8))))
(apply bytes ((if (eq? endian 'be) identity 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-macro (make-int-types)
(with-pattern ([((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 ...) (suffix-id #'(ID ...) #:context caller-stx)])
#'(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)))

28
xenomorph/xenomorph/private/optional.rkt
Unescape Escape View File

@ -1,28 +0,0 @@
#lang racket/base
(require "racket.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))))

102
xenomorph/xenomorph/private/pointer.rkt
Unescape Escape View File

@ -1,102 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require racket/undefined)
(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))

22
xenomorph/xenomorph/private/reserved.rkt
Unescape Escape View File

@ -1,22 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require "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)))

106
xenomorph/xenomorph/private/string.rkt
Unescape Escape View File

@ -1,106 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require "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 identity]))
(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))))

154
xenomorph/xenomorph/private/struct.rkt
Unescape Escape View File

@ -1,154 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require racket/dict racket/private/generic-methods racket/struct)
(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 ((disjoin assocs? 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)))

147
xenomorph/xenomorph/private/versioned-struct.rkt
Unescape Escape View File

@ -1,147 +0,0 @@
#lang racket/base
(require "racket.rkt")
(require racket/dict "struct.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee
|#
(define-subclass Struct (VersionedStruct type [versions (dictify)])
(unless ((disjoin integer? procedure? xenomorph-base%? symbol?) 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)
|#
)

19
xenomorph/xenomorph/reserved.rkt
Unescape Escape View File

@ -1,5 +1,22 @@
#lang racket/base
(require "private/racket.rkt")
(require "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)))
(r+p "private/reserved.rkt")

2
xenomorph/xenomorph/private/sizes.rkt → xenomorph/xenomorph/sizes.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base
(require "racket.rkt")
(require "private/racket.rkt")
(provide type-sizes get-type-size)
(define-values (int-keys byte-values) (for*/lists (int-keys byte-values)

2
xenomorph/xenomorph/private/~stream.rkt → xenomorph/xenomorph/stream.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base
(require "racket.rkt")
(require "private/racket.rkt")
(require racket/generic racket/private/generic-methods)
(provide (all-defined-out))

103
xenomorph/xenomorph/string.rkt
Unescape Escape View File

@ -1,5 +1,106 @@
#lang racket/base
(require "private/racket.rkt")
(require "number.rkt" "utils.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/String.coffee
|#
(r+p "private/string.rkt")
(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 identity]))
(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))))

151
xenomorph/xenomorph/struct.rkt
Unescape Escape View File

@ -1,5 +1,154 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/dict racket/private/generic-methods racket/struct)
(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 ((disjoin assocs? 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)))
(r+p "private/struct.rkt")

2
xenomorph/xenomorph/private/utils.rkt → xenomorph/xenomorph/utils.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base
(require "racket.rkt")
(require "private/racket.rkt")
(provide (all-defined-out))
(require "number.rkt")

144
xenomorph/xenomorph/versioned-struct.rkt
Unescape Escape View File

@ -1,5 +1,147 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/dict "struct.rkt")
(provide (all-defined-out))
#|
approximates
https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee
|#
(define-subclass Struct (VersionedStruct type [versions (dictify)])
(unless ((disjoin integer? procedure? xenomorph-base%? symbol?) 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)
|#
)
(r+p "private/versioned-struct.rkt")
Write Preview
Loading…
Cancel
Save