reorg
parent
6008236b1e
commit
b61161ba36
@ -1,45 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require "stream.rkt")
|
||||
(provide (all-defined-out))
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
#|
|
||||
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/override (size . _) (send type size))
|
||||
|
||||
(define/augment (encode stream flag-hash [ctx #f])
|
||||
(define bitfield-integer (for/sum ([(flag i) (in-indexed flags)]
|
||||
#:when (and flag (ref flag-hash flag)))
|
||||
(arithmetic-shift 1 i)))
|
||||
(send type encode stream bitfield-integer)))
|
||||
|
||||
|
||||
(test-module
|
||||
(require "number.rkt" "stream.rkt")
|
||||
(define bfer (+Bitfield uint16be '(bold italic underline #f shadow condensed extended)))
|
||||
(define bf (send bfer decode (+DecodeStream #"\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))
|
||||
|
||||
(define os (+EncodeStream))
|
||||
(send bfer encode os bf)
|
||||
(check-equal? (send os dump) #"\0\25"))
|
||||
(r+p "private/bitfield.rkt")
|
||||
@ -1,53 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require "number.rkt" "utils.rkt")
|
||||
(provide (all-defined-out))
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
#|
|
||||
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 RestructureBase (RBuffer [len #xffff])
|
||||
|
||||
(define/override (decode stream [parent #f])
|
||||
(define decoded-len (resolve-length len stream parent))
|
||||
(send stream readBuffer decoded-len))
|
||||
|
||||
(define/override (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/override (encode stream buf [parent #f])
|
||||
(unless (bytes? buf)
|
||||
(raise-argument-error 'Buffer:encode "bytes" buf))
|
||||
(when (NumberT? len)
|
||||
(send len encode stream (length buf)))
|
||||
(send stream writeBuffer buf)))
|
||||
|
||||
(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))
|
||||
(r+p "private/buffer.rkt")
|
||||
@ -1,23 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require "stream.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
|
||||
|#
|
||||
|
||||
(define-subclass Streamcoder (Enum type [options empty])
|
||||
|
||||
(define/augment (decode stream . _)
|
||||
(define index (send type decode stream))
|
||||
(or (list-ref options index) index))
|
||||
|
||||
(define/override (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)))
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
(r+p "private/enum.rkt")
|
||||
@ -0,0 +1 @@
|
||||
#lang br
|
||||
@ -1,29 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require "stream.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
|
||||
|#
|
||||
|
||||
(define-subclass Streamcoder (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/override (size [val #f] [parent #f])
|
||||
(if (resolve-condition parent)
|
||||
(send type size val parent)
|
||||
0))
|
||||
|
||||
(define/augment (encode stream val parent)
|
||||
(when (resolve-condition parent)
|
||||
(send type encode stream val parent))))
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
(r+p "private/optional.rkt")
|
||||
@ -1,98 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require racket/undefined)
|
||||
(provide (all-defined-out))
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
#|
|
||||
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 object% (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/public (decode stream [ctx #f])
|
||||
(define offset (send offset-type decode stream ctx))
|
||||
(cond
|
||||
[(and allow-null (= offset null-value)) #f] ; handle null pointers
|
||||
[else
|
||||
(define relative (+ (caseq pointer-style
|
||||
[(local) (· ctx _startOffset)]
|
||||
[(immediate) (- (· stream pos) (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 (· stream pos))
|
||||
(send stream pos ptr)
|
||||
(set! val (send type decode stream ctx))
|
||||
(send stream pos orig-pos)
|
||||
val]))
|
||||
(if lazy
|
||||
(LazyThunk decode-value)
|
||||
(decode-value))]
|
||||
[else ptr])]))
|
||||
|
||||
|
||||
(define/public (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/public (encode stream val [ctx #f])
|
||||
(if (not val)
|
||||
(send offset-type encode stream 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) (+ (· stream pos) (send offset-type size val parent))]
|
||||
[(global) 0])
|
||||
(relative-getter-or-0 (· parent val)))])
|
||||
|
||||
(send offset-type encode stream (- (· 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))
|
||||
(r+p "private/pointer.rkt")
|
||||
@ -0,0 +1,45 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(require "stream.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/override (size . _) (send type size))
|
||||
|
||||
(define/augment (encode stream flag-hash [ctx #f])
|
||||
(define bitfield-integer (for/sum ([(flag i) (in-indexed flags)]
|
||||
#:when (and flag (ref flag-hash flag)))
|
||||
(arithmetic-shift 1 i)))
|
||||
(send type encode stream bitfield-integer)))
|
||||
|
||||
|
||||
(test-module
|
||||
(require "number.rkt" "stream.rkt")
|
||||
(define bfer (+Bitfield uint16be '(bold italic underline #f shadow condensed extended)))
|
||||
(define bf (send bfer decode (+DecodeStream #"\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))
|
||||
|
||||
(define os (+EncodeStream))
|
||||
(send bfer encode os bf)
|
||||
(check-equal? (send os dump) #"\0\25"))
|
||||
@ -0,0 +1,53 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(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 RestructureBase (RBuffer [len #xffff])
|
||||
|
||||
(define/override (decode stream [parent #f])
|
||||
(define decoded-len (resolve-length len stream parent))
|
||||
(send stream readBuffer decoded-len))
|
||||
|
||||
(define/override (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/override (encode stream buf [parent #f])
|
||||
(unless (bytes? buf)
|
||||
(raise-argument-error 'Buffer:encode "bytes" buf))
|
||||
(when (NumberT? len)
|
||||
(send len encode stream (length buf)))
|
||||
(send stream writeBuffer buf)))
|
||||
|
||||
(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))
|
||||
@ -0,0 +1,23 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(require "stream.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
|
||||
|#
|
||||
|
||||
(define-subclass Streamcoder (Enum type [options empty])
|
||||
|
||||
(define/augment (decode stream . _)
|
||||
(define index (send type decode stream))
|
||||
(or (list-ref options index) index))
|
||||
|
||||
(define/override (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)))
|
||||
|
||||
@ -0,0 +1,29 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(require "stream.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
|
||||
|#
|
||||
|
||||
(define-subclass Streamcoder (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/override (size [val #f] [parent #f])
|
||||
(if (resolve-condition parent)
|
||||
(send type size val parent)
|
||||
0))
|
||||
|
||||
(define/augment (encode stream val parent)
|
||||
(when (resolve-condition parent)
|
||||
(send type encode stream val parent))))
|
||||
|
||||
@ -0,0 +1,98 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(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 object% (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/public (decode stream [ctx #f])
|
||||
(define offset (send offset-type decode stream ctx))
|
||||
(cond
|
||||
[(and allow-null (= offset null-value)) #f] ; handle null pointers
|
||||
[else
|
||||
(define relative (+ (caseq pointer-style
|
||||
[(local) (· ctx _startOffset)]
|
||||
[(immediate) (- (· stream pos) (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 (· stream pos))
|
||||
(send stream pos ptr)
|
||||
(set! val (send type decode stream ctx))
|
||||
(send stream pos orig-pos)
|
||||
val]))
|
||||
(if lazy
|
||||
(LazyThunk decode-value)
|
||||
(decode-value))]
|
||||
[else ptr])]))
|
||||
|
||||
|
||||
(define/public (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/public (encode stream val [ctx #f])
|
||||
(if (not val)
|
||||
(send offset-type encode stream 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) (+ (· stream pos) (send offset-type size val parent))]
|
||||
[(global) 0])
|
||||
(relative-getter-or-0 (· parent val)))])
|
||||
|
||||
(send offset-type encode stream (- (· 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,4 +1,4 @@
|
||||
#lang restructure/racket
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(provide type-sizes get-type-size)
|
||||
|
||||
(define-values (int-keys byte-values) (for*/lists (int-keys byte-values)
|
||||
@ -0,0 +1,215 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(require racket/private/generic-methods)
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; helper class
|
||||
(define-subclass object% (PortWrapper _port)
|
||||
(unless (port? _port)
|
||||
(raise-argument-error 'PortWrapper:constructor "port" _port))
|
||||
(define/public (pos [where #f])
|
||||
(when where (file-position _port where))
|
||||
(file-position _port))
|
||||
(define/public (dump) (void)))
|
||||
|
||||
(test-module
|
||||
(check-not-exn (λ () (make-object PortWrapper (open-input-bytes #"Foo"))))
|
||||
(check-not-exn (λ () (make-object PortWrapper (open-output-bytes))))
|
||||
(check-exn exn:fail? (λ () (make-object PortWrapper -42))))
|
||||
|
||||
#| approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/EncodeStream.coffee
|
||||
|#
|
||||
|
||||
;; basically just a wrapper for a Racket output port
|
||||
(define-subclass* PortWrapper (EncodeStream [maybe-output-port (open-output-bytes)])
|
||||
|
||||
(unless (output-port? maybe-output-port)
|
||||
(raise-argument-error 'EncodeStream:constructor "output port" maybe-output-port))
|
||||
|
||||
(super-make-object maybe-output-port)
|
||||
(inherit-field _port)
|
||||
|
||||
(define/override-final (dump) (get-output-bytes _port))
|
||||
|
||||
(define/public-final (write val)
|
||||
(unless (bytes? val)
|
||||
(raise-argument-error 'EncodeStream:write "bytes" val))
|
||||
(write-bytes val _port)
|
||||
(void))
|
||||
|
||||
(define/public-final (writeBuffer buffer)
|
||||
(write buffer))
|
||||
|
||||
(define/public-final (writeUInt8 int)
|
||||
(write (bytes int)))
|
||||
|
||||
(define/public (writeString string [encoding 'ascii])
|
||||
;; todo: handle encodings correctly.
|
||||
;; right now just utf8 and ascii are correct
|
||||
(caseq encoding
|
||||
[(utf16le ucs2 utf8 ascii) (writeBuffer (string->bytes/utf-8 string))
|
||||
(when (eq? encoding 'utf16le)
|
||||
(error 'swap-bytes-unimplemented))]
|
||||
[else (error 'unsupported-string-encoding)]))
|
||||
|
||||
(define/public (fill val len)
|
||||
(write (make-bytes len val))))
|
||||
|
||||
(test-module
|
||||
(define es (+EncodeStream))
|
||||
(check-true (EncodeStream? es))
|
||||
(send es write #"AB")
|
||||
(check-equal? (· es pos) 2)
|
||||
(send es write #"C")
|
||||
(check-equal? (· es pos) 3)
|
||||
(send es write #"D")
|
||||
(check-equal? (· es pos) 4)
|
||||
(check-exn exn:fail? (λ () (send es write -42)))
|
||||
(check-exn exn:fail? (λ () (send es write 1)))
|
||||
(define op (open-output-bytes))
|
||||
(define es2 (+EncodeStream op))
|
||||
(send es2 write #"FOOBAR")
|
||||
(check-equal? (send es2 dump) #"FOOBAR")
|
||||
(check-equal? (send es2 dump) #"FOOBAR") ; dump can repeat
|
||||
(check-equal? (get-output-bytes op) #"FOOBAR")
|
||||
(define es3 (+EncodeStream))
|
||||
(send es3 fill 0 10)
|
||||
(check-equal? (send es3 dump) (make-bytes 10 0)))
|
||||
|
||||
|
||||
#| approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee
|
||||
|#
|
||||
|
||||
;; basically just a wrapper for a Racket port
|
||||
;; but needs to start with a buffer so length can be found
|
||||
|
||||
(require "sizes.rkt")
|
||||
(define-macro (define-reader ID)
|
||||
#'(define/public (ID)
|
||||
(define bs (*ref type-sizes (string->symbol (string-downcase (string-replace (symbol->string 'ID) "read" "")))))
|
||||
(readBuffer bs)))
|
||||
|
||||
(define countable<%>
|
||||
(interface* ()
|
||||
([(generic-property gen:countable)
|
||||
(generic-method-table gen:countable
|
||||
(define (length o) (get-field length_ o)))])))
|
||||
|
||||
(define DecodeStreamT
|
||||
(class* PortWrapper
|
||||
(countable<%>)
|
||||
(init-field [buffer #""])
|
||||
(unless (bytes? buffer) ; corresponds to a Node Buffer, not a restructure BufferT object
|
||||
(raise-argument-error 'DecodeStream:constructor "bytes" buffer))
|
||||
(super-make-object (open-input-bytes buffer))
|
||||
(inherit-field _port)
|
||||
|
||||
(field [_pos 0]
|
||||
[length_ (length buffer)])
|
||||
|
||||
(define/override (pos [where #f])
|
||||
(when where
|
||||
(set! _pos (super pos where)))
|
||||
_pos)
|
||||
|
||||
(define/public (count-nonzero-chars)
|
||||
;; helper function for String
|
||||
;; counts nonzero chars from current position
|
||||
(length (car (regexp-match-peek "[^\u0]*" _port))))
|
||||
|
||||
(public [-length length])
|
||||
(define (-length) length_)
|
||||
|
||||
(define/public (readString length__ [encoding 'ascii])
|
||||
(define proc (caseq encoding
|
||||
[(utf16le) (error 'bah)]
|
||||
[(ucs2) (error 'bleh)]
|
||||
[(utf8) bytes->string/utf-8]
|
||||
[(ascii) bytes->string/latin-1]
|
||||
[else identity]))
|
||||
(define start (pos))
|
||||
(define stop (+ start length__))
|
||||
(proc (subbytes buffer start (pos stop))))
|
||||
|
||||
(define/public-final (readBuffer count)
|
||||
(unless (index? count)
|
||||
(raise-argument-error 'DecodeStream:read "positive integer" count))
|
||||
(define bytes-remaining (- length_ (pos)))
|
||||
(when (> count bytes-remaining)
|
||||
(raise-argument-error 'DecodeStream:read (format "byte count not more than bytes remaining = ~a" bytes-remaining) count))
|
||||
(increment-field! _pos this count) ; don't use `pos` method here because `read-bytes` will increment the port position
|
||||
(define bs (read-bytes count _port))
|
||||
(unless (= _pos (file-position _port)) (raise-result-error 'DecodeStream "positions askew" (list _pos (file-position _port))))
|
||||
bs)
|
||||
|
||||
(define/public (read count) (readBuffer count))
|
||||
|
||||
(define/public (readUInt8) (bytes-ref (readBuffer 1) 0))
|
||||
(define/public (readUInt16BE) (+ (arithmetic-shift (readUInt8) 8) (readUInt8)))
|
||||
(define/public (readInt16BE) (unsigned->signed (readUInt16BE) 16))
|
||||
(define/public (readUInt16LE) (+ (readUInt8) (arithmetic-shift (readUInt8) 8)))
|
||||
(define/public (readUInt24BE) (+ (arithmetic-shift (readUInt16BE) 8) (readUInt8)))
|
||||
(define/public (readUInt24LE) (+ (readUInt16LE) (arithmetic-shift (readUInt8) 16)))
|
||||
(define/public (readInt24BE) (unsigned->signed (readUInt24BE) 24))
|
||||
(define/public (readInt24LE) (unsigned->signed (readUInt24LE) 24))
|
||||
|
||||
(define/override-final (dump)
|
||||
(define current-position (port-position _port))
|
||||
(set-port-position! _port 0)
|
||||
(define bs (port->bytes _port))
|
||||
(set-port-position! _port current-position)
|
||||
bs)))
|
||||
|
||||
(define-subclass DecodeStreamT (DecodeStream))
|
||||
|
||||
(test-module
|
||||
(define ds (+DecodeStream #"ABCD"))
|
||||
(check-true (DecodeStream? ds))
|
||||
(check-equal? (length ds) 4)
|
||||
(check-equal? (send ds dump) #"ABCD")
|
||||
(check-equal? (send ds dump) #"ABCD") ; dump can repeat
|
||||
(check-equal? (send ds readUInt16BE) 16706)
|
||||
(check-equal? (send ds dump) #"ABCD")
|
||||
(check-equal? (· ds pos) 2)
|
||||
(check-equal? (send ds readUInt8) 67)
|
||||
(check-equal? (· ds pos) 3)
|
||||
(check-equal? (send ds readUInt8) 68)
|
||||
(check-equal? (· ds pos) 4)
|
||||
(check-exn exn:fail? (λ () (send ds read -42)))
|
||||
(check-exn exn:fail? (λ () (send ds read 1))))
|
||||
|
||||
|
||||
;; Streamcoder is a helper class that checks / converts stream arguments before decode / encode
|
||||
;; not a subclass of DecodeStream or EncodeStream, however.
|
||||
(define-subclass RestructureBase (Streamcoder)
|
||||
(define/overment (decode x [parent #f])
|
||||
(when parent (unless (indexable? parent)
|
||||
(raise-argument-error 'Streamcoder:decode "hash or indexable" x)))
|
||||
(define stream (if (bytes? x) (+DecodeStream x) x))
|
||||
(unless (DecodeStream? stream)
|
||||
(raise-argument-error 'Streamcoder:decode "bytes or DecodeStream" x))
|
||||
(inner (void) decode stream parent))
|
||||
|
||||
(define/overment (encode x [val #f] [parent #f])
|
||||
(define stream (cond
|
||||
[(output-port? x) (+EncodeStream x)]
|
||||
[(not x) (+EncodeStream)]
|
||||
[else x]))
|
||||
(unless (EncodeStream? stream)
|
||||
(raise-argument-error 'Streamcoder:encode "output port or EncodeStream" x))
|
||||
(inner (void) encode stream val parent)
|
||||
(when (not x) (send stream dump))))
|
||||
|
||||
(test-module
|
||||
(define-subclass Streamcoder (Dummy)
|
||||
(define/augment (decode stream . args) "foo")
|
||||
(define/augment (encode stream val parent) "bar")
|
||||
(define/override (size) 42))
|
||||
|
||||
(define d (+Dummy))
|
||||
(check-true (Dummy? d))
|
||||
(check-exn exn:fail:contract? (λ () (send d decode 42)))
|
||||
(check-not-exn (λ () (send d decode #"foo")))
|
||||
(check-exn exn:fail:contract? (λ () (send d encode 42 21)))
|
||||
(check-not-exn (λ () (send d encode (open-output-bytes) 42))))
|
||||
@ -1,4 +1,4 @@
|
||||
#lang restructure/racket
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(provide (all-defined-out) (rename-out [resolveLength resolve-length]))
|
||||
(require "number.rkt")
|
||||
|
||||
@ -0,0 +1,155 @@
|
||||
#lang reader (submod "racket.rkt" reader)
|
||||
(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? RestructureBase? 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 process)
|
||||
(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)
|
||||
(process res stream)
|
||||
res]))
|
||||
|
||||
(define/public-final (force-version! version)
|
||||
(set! forced-version version))
|
||||
|
||||
(define/override (encode stream val [parent #f])
|
||||
(unless (hash? val)
|
||||
(raise-argument-error 'Struct:encode "hash" val))
|
||||
|
||||
(send this preEncode val stream) ; preEncode goes first, because it might bring input hash into compliance
|
||||
|
||||
(define ctx (mhash 'pointers empty
|
||||
'startOffset (· stream pos)
|
||||
'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(ref-set! ctx 'pointerOffset (+ (· stream pos) (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 (mhash)] [parent #f] [includePointers #t])
|
||||
(unless (or val forced-version)
|
||||
(error 'VersionedStruct-cannot-compute-size))
|
||||
|
||||
(define ctx (mhash 'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(define size 0)
|
||||
(when (not (or (key? type) (procedure? type)))
|
||||
(increment! size (send type size (or forced-version (ref val 'version)) ctx)))
|
||||
|
||||
(when (ref versions 'header)
|
||||
(increment! size
|
||||
(for/sum ([(key type) (in-dict (ref versions 'header))])
|
||||
(send type size (ref val key) ctx))))
|
||||
|
||||
(define fields (or (ref versions (or forced-version (ref val 'version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
|
||||
|
||||
(increment! size
|
||||
(for/sum ([(key type) (in-dict fields)])
|
||||
(send type size (ref val key) ctx)))
|
||||
|
||||
(when includePointers
|
||||
(increment! size (ref ctx 'pointerSize)))
|
||||
|
||||
size))
|
||||
|
||||
#;(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)
|
||||
|#
|
||||
)
|
||||
|
||||
|
||||
@ -1,215 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require racket/private/generic-methods)
|
||||
(provide (all-defined-out))
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
;; helper class
|
||||
(define-subclass object% (PortWrapper _port)
|
||||
(unless (port? _port)
|
||||
(raise-argument-error 'PortWrapper:constructor "port" _port))
|
||||
(define/public (pos [where #f])
|
||||
(when where (file-position _port where))
|
||||
(file-position _port))
|
||||
(define/public (dump) (void)))
|
||||
|
||||
(test-module
|
||||
(check-not-exn (λ () (make-object PortWrapper (open-input-bytes #"Foo"))))
|
||||
(check-not-exn (λ () (make-object PortWrapper (open-output-bytes))))
|
||||
(check-exn exn:fail? (λ () (make-object PortWrapper -42))))
|
||||
|
||||
#| approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/EncodeStream.coffee
|
||||
|#
|
||||
|
||||
;; basically just a wrapper for a Racket output port
|
||||
(define-subclass* PortWrapper (EncodeStream [maybe-output-port (open-output-bytes)])
|
||||
|
||||
(unless (output-port? maybe-output-port)
|
||||
(raise-argument-error 'EncodeStream:constructor "output port" maybe-output-port))
|
||||
|
||||
(super-make-object maybe-output-port)
|
||||
(inherit-field _port)
|
||||
|
||||
(define/override-final (dump) (get-output-bytes _port))
|
||||
|
||||
(define/public-final (write val)
|
||||
(unless (bytes? val)
|
||||
(raise-argument-error 'EncodeStream:write "bytes" val))
|
||||
(write-bytes val _port)
|
||||
(void))
|
||||
|
||||
(define/public-final (writeBuffer buffer)
|
||||
(write buffer))
|
||||
|
||||
(define/public-final (writeUInt8 int)
|
||||
(write (bytes int)))
|
||||
|
||||
(define/public (writeString string [encoding 'ascii])
|
||||
;; todo: handle encodings correctly.
|
||||
;; right now just utf8 and ascii are correct
|
||||
(caseq encoding
|
||||
[(utf16le ucs2 utf8 ascii) (writeBuffer (string->bytes/utf-8 string))
|
||||
(when (eq? encoding 'utf16le)
|
||||
(error 'swap-bytes-unimplemented))]
|
||||
[else (error 'unsupported-string-encoding)]))
|
||||
|
||||
(define/public (fill val len)
|
||||
(write (make-bytes len val))))
|
||||
|
||||
(test-module
|
||||
(define es (+EncodeStream))
|
||||
(check-true (EncodeStream? es))
|
||||
(send es write #"AB")
|
||||
(check-equal? (· es pos) 2)
|
||||
(send es write #"C")
|
||||
(check-equal? (· es pos) 3)
|
||||
(send es write #"D")
|
||||
(check-equal? (· es pos) 4)
|
||||
(check-exn exn:fail? (λ () (send es write -42)))
|
||||
(check-exn exn:fail? (λ () (send es write 1)))
|
||||
(define op (open-output-bytes))
|
||||
(define es2 (+EncodeStream op))
|
||||
(send es2 write #"FOOBAR")
|
||||
(check-equal? (send es2 dump) #"FOOBAR")
|
||||
(check-equal? (send es2 dump) #"FOOBAR") ; dump can repeat
|
||||
(check-equal? (get-output-bytes op) #"FOOBAR")
|
||||
(define es3 (+EncodeStream))
|
||||
(send es3 fill 0 10)
|
||||
(check-equal? (send es3 dump) (make-bytes 10 0)))
|
||||
|
||||
|
||||
#| approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee
|
||||
|#
|
||||
|
||||
;; basically just a wrapper for a Racket port
|
||||
;; but needs to start with a buffer so length can be found
|
||||
|
||||
(require "sizes.rkt")
|
||||
(define-macro (define-reader ID)
|
||||
#'(define/public (ID)
|
||||
(define bs (*ref type-sizes (string->symbol (string-downcase (string-replace (symbol->string 'ID) "read" "")))))
|
||||
(readBuffer bs)))
|
||||
|
||||
(define countable<%>
|
||||
(interface* ()
|
||||
([(generic-property gen:countable)
|
||||
(generic-method-table gen:countable
|
||||
(define (length o) (get-field length_ o)))])))
|
||||
|
||||
(define DecodeStreamT
|
||||
(class* PortWrapper
|
||||
(countable<%>)
|
||||
(init-field [buffer #""])
|
||||
(unless (bytes? buffer) ; corresponds to a Node Buffer, not a restructure BufferT object
|
||||
(raise-argument-error 'DecodeStream:constructor "bytes" buffer))
|
||||
(super-make-object (open-input-bytes buffer))
|
||||
(inherit-field _port)
|
||||
|
||||
(field [_pos 0]
|
||||
[length_ (length buffer)])
|
||||
|
||||
(define/override (pos [where #f])
|
||||
(when where
|
||||
(set! _pos (super pos where)))
|
||||
_pos)
|
||||
|
||||
(define/public (count-nonzero-chars)
|
||||
;; helper function for String
|
||||
;; counts nonzero chars from current position
|
||||
(length (car (regexp-match-peek "[^\u0]*" _port))))
|
||||
|
||||
(public [-length length])
|
||||
(define (-length) length_)
|
||||
|
||||
(define/public (readString length__ [encoding 'ascii])
|
||||
(define proc (caseq encoding
|
||||
[(utf16le) (error 'bah)]
|
||||
[(ucs2) (error 'bleh)]
|
||||
[(utf8) bytes->string/utf-8]
|
||||
[(ascii) bytes->string/latin-1]
|
||||
[else identity]))
|
||||
(define start (pos))
|
||||
(define stop (+ start length__))
|
||||
(proc (subbytes buffer start (pos stop))))
|
||||
|
||||
(define/public-final (readBuffer count)
|
||||
(unless (index? count)
|
||||
(raise-argument-error 'DecodeStream:read "positive integer" count))
|
||||
(define bytes-remaining (- length_ (pos)))
|
||||
(when (> count bytes-remaining)
|
||||
(raise-argument-error 'DecodeStream:read (format "byte count not more than bytes remaining = ~a" bytes-remaining) count))
|
||||
(increment-field! _pos this count) ; don't use `pos` method here because `read-bytes` will increment the port position
|
||||
(define bs (read-bytes count _port))
|
||||
(unless (= _pos (file-position _port)) (raise-result-error 'DecodeStream "positions askew" (list _pos (file-position _port))))
|
||||
bs)
|
||||
|
||||
(define/public (read count) (readBuffer count))
|
||||
|
||||
(define/public (readUInt8) (bytes-ref (readBuffer 1) 0))
|
||||
(define/public (readUInt16BE) (+ (arithmetic-shift (readUInt8) 8) (readUInt8)))
|
||||
(define/public (readInt16BE) (unsigned->signed (readUInt16BE) 16))
|
||||
(define/public (readUInt16LE) (+ (readUInt8) (arithmetic-shift (readUInt8) 8)))
|
||||
(define/public (readUInt24BE) (+ (arithmetic-shift (readUInt16BE) 8) (readUInt8)))
|
||||
(define/public (readUInt24LE) (+ (readUInt16LE) (arithmetic-shift (readUInt8) 16)))
|
||||
(define/public (readInt24BE) (unsigned->signed (readUInt24BE) 24))
|
||||
(define/public (readInt24LE) (unsigned->signed (readUInt24LE) 24))
|
||||
|
||||
(define/override-final (dump)
|
||||
(define current-position (port-position _port))
|
||||
(set-port-position! _port 0)
|
||||
(define bs (port->bytes _port))
|
||||
(set-port-position! _port current-position)
|
||||
bs)))
|
||||
|
||||
(define-subclass DecodeStreamT (DecodeStream))
|
||||
|
||||
(test-module
|
||||
(define ds (+DecodeStream #"ABCD"))
|
||||
(check-true (DecodeStream? ds))
|
||||
(check-equal? (length ds) 4)
|
||||
(check-equal? (send ds dump) #"ABCD")
|
||||
(check-equal? (send ds dump) #"ABCD") ; dump can repeat
|
||||
(check-equal? (send ds readUInt16BE) 16706)
|
||||
(check-equal? (send ds dump) #"ABCD")
|
||||
(check-equal? (· ds pos) 2)
|
||||
(check-equal? (send ds readUInt8) 67)
|
||||
(check-equal? (· ds pos) 3)
|
||||
(check-equal? (send ds readUInt8) 68)
|
||||
(check-equal? (· ds pos) 4)
|
||||
(check-exn exn:fail? (λ () (send ds read -42)))
|
||||
(check-exn exn:fail? (λ () (send ds read 1))))
|
||||
|
||||
|
||||
;; Streamcoder is a helper class that checks / converts stream arguments before decode / encode
|
||||
;; not a subclass of DecodeStream or EncodeStream, however.
|
||||
(define-subclass RestructureBase (Streamcoder)
|
||||
(define/overment (decode x [parent #f])
|
||||
(when parent (unless (indexable? parent)
|
||||
(raise-argument-error 'Streamcoder:decode "hash or indexable" x)))
|
||||
(define stream (if (bytes? x) (+DecodeStream x) x))
|
||||
(unless (DecodeStream? stream)
|
||||
(raise-argument-error 'Streamcoder:decode "bytes or DecodeStream" x))
|
||||
(inner (void) decode stream parent))
|
||||
|
||||
(define/overment (encode x [val #f] [parent #f])
|
||||
(define stream (cond
|
||||
[(output-port? x) (+EncodeStream x)]
|
||||
[(not x) (+EncodeStream)]
|
||||
[else x]))
|
||||
(unless (EncodeStream? stream)
|
||||
(raise-argument-error 'Streamcoder:encode "output port or EncodeStream" x))
|
||||
(inner (void) encode stream val parent)
|
||||
(when (not x) (send stream dump))))
|
||||
|
||||
(test-module
|
||||
(define-subclass Streamcoder (Dummy)
|
||||
(define/augment (decode stream . args) "foo")
|
||||
(define/augment (encode stream val parent) "bar")
|
||||
(define/override (size) 42))
|
||||
|
||||
(define d (+Dummy))
|
||||
(check-true (Dummy? d))
|
||||
(check-exn exn:fail:contract? (λ () (send d decode 42)))
|
||||
(check-not-exn (λ () (send d decode #"foo")))
|
||||
(check-exn exn:fail:contract? (λ () (send d encode 42 21)))
|
||||
(check-not-exn (λ () (send d encode (open-output-bytes) 42))))
|
||||
(r+p "private/stream.rkt")
|
||||
@ -1,6 +1,6 @@
|
||||
#lang racket/base
|
||||
(require rackunit restructure restructure/racket)
|
||||
(provide (all-from-out rackunit restructure restructure/racket))
|
||||
(require rackunit restructure "../private/racket.rkt")
|
||||
(provide (all-from-out rackunit restructure "../private/racket.rkt"))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
#:language 'restructure/test/racket)
|
||||
@ -1,155 +1,3 @@
|
||||
#lang restructure/racket
|
||||
(require racket/dict "struct.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
|
||||
(define-subclass Struct (VersionedStruct type [versions (dictify)])
|
||||
|
||||
(unless ((disjoin integer? procedure? RestructureBase? 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 process)
|
||||
(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)
|
||||
(process res stream)
|
||||
res]))
|
||||
|
||||
(define/public-final (force-version! version)
|
||||
(set! forced-version version))
|
||||
|
||||
(define/override (encode stream val [parent #f])
|
||||
(unless (hash? val)
|
||||
(raise-argument-error 'Struct:encode "hash" val))
|
||||
|
||||
(send this preEncode val stream) ; preEncode goes first, because it might bring input hash into compliance
|
||||
|
||||
(define ctx (mhash 'pointers empty
|
||||
'startOffset (· stream pos)
|
||||
'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(ref-set! ctx 'pointerOffset (+ (· stream pos) (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 (mhash)] [parent #f] [includePointers #t])
|
||||
(unless (or val forced-version)
|
||||
(error 'VersionedStruct-cannot-compute-size))
|
||||
|
||||
(define ctx (mhash 'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(define size 0)
|
||||
(when (not (or (key? type) (procedure? type)))
|
||||
(increment! size (send type size (or forced-version (ref val 'version)) ctx)))
|
||||
|
||||
(when (ref versions 'header)
|
||||
(increment! size
|
||||
(for/sum ([(key type) (in-dict (ref versions 'header))])
|
||||
(send type size (ref val key) ctx))))
|
||||
|
||||
(define fields (or (ref versions (or forced-version (ref val 'version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
|
||||
|
||||
(increment! size
|
||||
(for/sum ([(key type) (in-dict fields)])
|
||||
(send type size (ref val key) ctx)))
|
||||
|
||||
(when includePointers
|
||||
(increment! size (ref ctx 'pointerSize)))
|
||||
|
||||
size))
|
||||
|
||||
#;(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)
|
||||
|#
|
||||
)
|
||||
|
||||
#lang reader (submod "private/racket.rkt" reader)
|
||||
|
||||
(r+p "private/versioned-struct.rkt")
|
||||
Loading…
Reference in New Issue