diff --git a/pitfall/restructure/main.rkt b/pitfall/restructure/main.rkt index 682daae9..ada05442 100644 --- a/pitfall/restructure/main.rkt +++ b/pitfall/restructure/main.rkt @@ -5,6 +5,7 @@ "struct.rkt" "string.rkt" "array.rkt" + "lazy-array.rkt" "bitfield.rkt" "stream.rkt" "buffer.rkt" diff --git a/pitfall/restructure/stream.rkt b/pitfall/restructure/stream.rkt index 5ae95644..5087579c 100644 --- a/pitfall/restructure/stream.rkt +++ b/pitfall/restructure/stream.rkt @@ -6,10 +6,9 @@ (define-subclass object% (PortWrapper _port) (unless (port? _port) (raise-argument-error 'PortWrapper:constructor "port" _port)) - (define/public-final (pos [where #f]) - (when where - (set-port-position! _port where)) - (port-position _port)) + (define/public (pos [where #f]) + (when where (file-position _port where)) + (file-position _port)) (define/public (dump) (void))) (test-module @@ -87,27 +86,42 @@ https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee (super-make-object (open-input-bytes buffer)) (inherit-field _port) - (field [pos 0] + (field [_pos 0] [length_ (length buffer)]) - (define/public (readString length [encoding 'ascii]) + (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])) - (proc (subbytes buffer pos (increment-field! pos this length)))) + (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_ (port-position _port))) + (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) + (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)))) + (unless (= _pos (file-position _port)) (raise-result-error 'DecodeStream "positions askew" (list _pos (file-position _port)))) bs) (define/public (read count) (readBuffer count)) diff --git a/pitfall/restructure/string-test.rkt b/pitfall/restructure/string-test.rkt new file mode 100644 index 00000000..8fc0397c --- /dev/null +++ b/pitfall/restructure/string-test.rkt @@ -0,0 +1,198 @@ +#lang restructure/racket +(require "string.rkt" "number.rkt" "buffer.rkt" "stream.rkt" rackunit) + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/test/String.coffee +|# + +;describe 'String', -> +; describe 'decode', -> +; it 'should decode fixed length', -> +; stream = new DecodeStream new Buffer 'testing' +; string = new StringT 7 +; string.decode(stream).should.equal 'testing' + +(let ([stream (+DecodeStream (+Buffer "testing"))] + [string (+StringT 7)]) + (check-equal? (send string decode stream) "testing")) + +; +; it 'should decode length from parent key', -> +; stream = new DecodeStream new Buffer 'testing' +; string = new StringT 'len' +; string.decode(stream, len: 7).should.equal 'testing' + +(let ([stream (+DecodeStream (+Buffer "testing"))] + [string (+StringT 'len)]) + (check-equal? (send string decode stream (mhash 'len 7)) "testing")) + + +; +; it 'should decode length as number before string', -> +; stream = new DecodeStream new Buffer '\x07testing' +; string = new StringT uint8 +; string.decode(stream).should.equal 'testing' + +; octal \7 will print as \a +(let ([stream (+DecodeStream (+Buffer "\7testing"))] + [string (+StringT uint8)]) + (check-equal? (send string decode stream (mhash 'len 7)) "testing")) + +; +; it 'should decode utf8', -> +; stream = new DecodeStream new Buffer '馃嵒' +; string = new StringT 4, 'utf8' +; string.decode(stream).should.equal '馃嵒' + +(let ([stream (+DecodeStream (+Buffer "馃嵒"))] + [string (+StringT 4 'utf8)]) + (check-equal? (send string decode stream) "馃嵒")) +; +; it 'should decode encoding computed from function', -> +; stream = new DecodeStream new Buffer '馃嵒' +; string = new StringT 4, -> 'utf8' +; string.decode(stream).should.equal '馃嵒' + +(let ([stream (+DecodeStream (+Buffer "馃嵒"))] + [string (+StringT 4 (位 _ 'utf8))]) + (check-equal? (send string decode stream) "馃嵒")) + +; +; it 'should decode null-terminated string and read past terminator', -> +; stream = new DecodeStream new Buffer '馃嵒\x00' +; string = new StringT null, 'utf8' +; string.decode(stream).should.equal '馃嵒' +; stream.pos.should.equal 5 + +(let ([stream (+DecodeStream (+Buffer "馃嵒\0"))] + [string (+StringT #f 'utf8)]) + (check-equal? (send string decode stream) "馃嵒") + (check-equal? (send stream pos) 5)) + +; +; it 'should decode remainder of buffer when null-byte missing', -> +; stream = new DecodeStream new Buffer '馃嵒' +; string = new StringT null, 'utf8' +; string.decode(stream).should.equal '馃嵒' + +(let ([stream (+DecodeStream (+Buffer "馃嵒"))] + [string (+StringT #f 'utf8)]) + (check-equal? (send string decode stream) "馃嵒")) + +; +; describe 'size', -> +; it 'should use string length', -> +; string = new StringT 7 +; string.size('testing').should.equal 7 + +(let ([string (+StringT 7)]) + (check-equal? (send string size "testing") 7)) + +; +; it 'should use correct encoding', -> +; string = new StringT 10, 'utf8' +; string.size('馃嵒').should.equal 4 + +(let ([string (+StringT 10 'utf8)]) + (check-equal? (send string size "馃嵒") 4)) + +; +; it 'should use encoding from function', -> +; string = new StringT 10, -> 'utf8' +; string.size('馃嵒').should.equal 4 + +(let ([string (+StringT 10 (位 _ 'utf8))]) + (check-equal? (send string size "馃嵒") 4)) + +; +; it 'should add size of length field before string', -> +; string = new StringT uint8, 'utf8' +; string.size('馃嵒').should.equal 5 + +(let ([string (+StringT uint8 'utf8)]) + (check-equal? (send string size "馃嵒") 5)) + +; todo +; it 'should work with utf16be encoding', -> +; string = new StringT 10, 'utf16be' +; string.size('馃嵒').should.equal 4 + + +; +; it 'should take null-byte into account', -> +; string = new StringT null, 'utf8' +; string.size('馃嵒').should.equal 5 + +(let ([string (+StringT #f 'utf8)]) + (check-equal? (send string size "馃嵒") 5)) + +; +; it 'should use defined length if no value given', -> +; array = new StringT 10 +; array.size().should.equal 10 + +(let ([string (+StringT 10)]) + (check-equal? (send string size) 10)) + +; +; describe 'encode', -> +; it 'should encode using string length', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer 'testing' +; done() +; +; string = new StringT 7 +; string.encode(stream, 'testing') +; stream.end() +; +; it 'should encode length as number before string', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '\x07testing' +; done() +; +; string = new StringT uint8 +; string.encode(stream, 'testing') +; stream.end() +; +; it 'should encode length as number before string utf8', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '\x0ctesting 馃槣', 'utf8' +; done() +; +; string = new StringT uint8, 'utf8' +; string.encode(stream, 'testing 馃槣') +; stream.end() +; +; it 'should encode utf8', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '馃嵒' +; done() +; +; string = new StringT 4, 'utf8' +; string.encode(stream, '馃嵒') +; stream.end() +; +; it 'should encode encoding computed from function', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '馃嵒' +; done() +; +; string = new StringT 4, -> 'utf8' +; string.encode(stream, '馃嵒') +; stream.end() +; +; it 'should encode null-terminated string', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '馃嵒\x00' +; done() +; +; string = new StringT null, 'utf8' +; string.encode(stream, '馃嵒') +; stream.end() \ No newline at end of file diff --git a/pitfall/restructure/string.rkt b/pitfall/restructure/string.rkt index dff01236..8c8017fb 100644 --- a/pitfall/restructure/string.rkt +++ b/pitfall/restructure/string.rkt @@ -1,5 +1,5 @@ #lang restructure/racket -(require "number.rkt" "utils.rkt" "stream.rkt") +(require "number.rkt" (prefix-in utils- "utils.rkt") "stream.rkt") (provide (all-defined-out)) #| @@ -7,41 +7,66 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/String.coffee |# -(struct $codec (encoder decoder) #:transparent) +(define (byteLength val encoding) + (define encoder + (caseq encoding + [(ascii utf8) string->bytes/utf-8])) + (bytes-length (encoder val))) -(define-subclass Streamcoder (String [strlen #f] [encoding 'ascii]) - (field [codec (caseq encoding - [(latin-1 ascii) ($codec string->bytes/latin-1 bytes->string/latin-1)] - [(utf-8 utf8) ($codec string->bytes/utf-8 bytes->string/utf-8)])]) +(define-subclass Streamcoder (StringT [length_ #f] [encoding_ 'ascii]) (define/augment (decode stream [parent #f]) - (define count (if strlen - (resolveLength strlen stream parent) - (send stream length))) - (define bytes (send stream read count)) - (($codec-decoder codec) bytes)) - - (define/augment (encode stream val [parent #f]) - (define bytes (($codec-encoder codec) (format "~a" val))) + (define length__ + (cond + [length_ (utils-resolveLength length_ stream parent)] + [else (send stream count-nonzero-chars)])) + (define encoding__ + (cond + [(procedure? encoding_) (or (encoding_ parent) 'ascii)] + [else encoding_])) + (define string (send stream readString length__ encoding__)) + (when (and (not length_) (< (send stream pos) (send stream length))) + (send stream pos (add1 (send stream pos)))) + string) - (when (Number? strlen) ;; length-prefixed string - (send strlen encode stream (bytes-length bytes))) + + #;(define/augment (encode stream val [parent #f]) + (define bytes (($codec-encoder codec) (format "~a" val))) + + (when (Number? length_) ;; length-prefixed string + (send length_ encode stream (bytes-length bytes))) + + (send stream write bytes)) + + (define/override (size [val #f] [parent #f]) + ;; Use the defined value if no value was given + (cond + [(not val) (utils-resolveLength length_ #f parent)] + [else + (define encoding__ + (cond + [(procedure? encoding_) (or (encoding_ (and parent (路聽parent val)) 'ascii))] + [else encoding_])) + (when (eq? encoding__ 'utf16be) + (set! encoding__ 'utf16le)) + (define size (byteLength val encoding__)) + (when (NumberT? length_) + (increment! size (send length_ size))) + (when (not length_) + (increment! size)) + size])) - (send stream write bytes)) - - (define/override (size [str-in #f]) - (define str (or str-in (make-string strlen #\x))) - (define es (+EncodeStream)) - (encode es str) - (bytes-length (send es dump)))) - - -(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)) \ No newline at end of file + + ) + +(define-values (String? +String) (values StringT? +StringT)) + +#;(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)) \ No newline at end of file diff --git a/pitfall/restructure/struct copy.rkt b/pitfall/restructure/struct copy.rkt new file mode 100644 index 00000000..b8ee16b5 --- /dev/null +++ b/pitfall/restructure/struct copy.rkt @@ -0,0 +1,196 @@ +#lang restructure/racket +(require racket/dict "stream.rkt") +(provide (all-defined-out)) + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee +|# + +(define-subclass Streamcoder (Struct [fields (dictify)]) + (inherit-field res) + + (unless ((disjoin assocs? VersionedStruct?) fields) + (raise-argument-error 'Struct "assocs or Versioned Struct" fields)) + + (define/augride (decode stream [parent #f] [length 0]) + (set! res (_setup stream parent length)) + (_parseFields stream res fields) + (send this process res stream) + res) + + (define/augride (encode stream input-hash [parent #f]) + + (unless (hash? input-hash) + (raise-argument-error 'Struct:encode "hash" input-hash)) + + (send this preEncode input-hash stream) ; preEncode goes first, because it might bring input hash into compliance + + (unless (andmap (位 (key) (member key (hash-keys input-hash))) (dict-keys fields)) + (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys input-hash))) + + (cond + [(dict? fields) + (for* ([(key type) (in-dict fields)]) + (send type encode stream (hash-ref input-hash key)))] + [else (send fields encode stream input-hash parent)])) + + (define/public-final (_setup stream parent length) + (define res (mhasheq)) + (hash-set*! res 'parent parent + '_startOffset (路 stream pos) + '_currentOffset 0 + '_length length) + res) + + (define/public-final (_parseFields stream res fields) + (unless (assocs? fields) + (raise-argument-error '_parseFields "assocs" fields)) + (for ([(key type) (in-dict fields)]) + (report key) + (define val + (if (procedure? type) + (type res) + (send type decode stream this))) + (hash-set! res key val) + (hash-set! res '_currentOffset (- (路 stream pos) (路 res _startOffset))))) + + (define/override (size [input-hash (mhash)] [parent #f] [includePointers #t]) + (for/sum ([(key type) (in-dict fields)]) + (define val (hash-ref input-hash key #f)) + (define args (if val (list val) empty)) + (send type size . args)))) + + +(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 10)]) + (define field-types (for/list ([i (in-range 20)]) + (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)))) + (define es (+EncodeStream)) + (send s encode es (send s decode bs)) + (check-equal? (send es dump) bs))) + + + + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee +|# + +(define-subclass Struct (VersionedStruct type [versions (dictify)]) + (inherit-field res) + (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-field fields) + (field [forced-version #f]) + + (define/public-final (force-version! version) + (set! forced-version version)) + + (define/public (resolve-version [stream #f] [parent #f]) + (cond + [forced-version] ; for testing purposes: pass an explicit version + [(integer? type) type] + [(symbol? type) + ;; find the first Struct in the chain of ancestors + ;; with the target key + (let loop ([x parent]) + (cond + [(and x (Struct? x) (dict-ref (路 x res) type #f))] + [(路 x parent) => loop] + [else #f]))] + [(and (procedure? type) (positive? (procedure-arity type))) (type parent)] + [(RestructureBase? type) (send type decode stream)] + [else (raise-argument-error 'VersionedStruct:resolve-version "way of finding version" type)])) + + (define/override (decode stream [parent #f] [length 0]) + (set! res (send this _setup stream parent length)) + (report res 'versioned-struct-res) + (define version (resolve-version stream parent)) + (hash-set! res 'version version) + (define fields (dict-ref versions version (位 () (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (路 this versions)))))) + (cond + [(VersionedStruct? fields) (send fields decode stream parent)] + [else + (report res 'whatigot) + (send this _parseFields stream res fields) + (send this process res stream) + res])) + + (define/override (encode stream input-hash [parent #f]) + (unless (hash? input-hash) + (raise-argument-error 'Struct:encode "hash" input-hash)) + + (send this preEncode input-hash stream) ; preEncode goes first, because it might bring input hash into compliance + + (define fields (dict-ref versions (路 input-hash version) (位 () (raise-argument-error 'VersionedStruct:encode "valid version key" version)))) + + (unless (andmap (位 (key) (member key (hash-keys input-hash))) (dict-keys fields)) + (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys input-hash))) + + (cond + [(dict? fields) + (for* ([(key type) (in-dict fields)]) + (send type encode stream (hash-ref input-hash key)))] + [else (send fields encode stream input-hash parent)])) + + + (define/override (size [input-hash (mhash)] [parent #f] [includePointers #t]) + (when (and (not input-hash) (not forced-version)) + (error 'VersionedStruct-cannot-compute-size)) + (define version (resolve-version #f parent)) + (define fields (dict-ref versions version (位 () (raise-argument-error 'VersionedStruct:size "valid version key" version)))) + (cond + [(dict? fields) + (for/sum ([(key type) (in-dict fields)]) + (define val (hash-ref input-hash key #f)) + (define args (if val (list val) empty)) + (send type size . args))] + [else (send fields size input-hash parent includePointers)]))) + +(test-module + (require "number.rkt") + (check-exn exn:fail:contract? (位 () (+VersionedStruct 42 42))) + + ;; make random versioned structs and make sure we can round trip + (for ([i (in-range 20)]) + (define field-types (for/list ([i (in-range 200)]) + (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 (dict-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 (位 (p) 2) (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s)))) + (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) + + ) + + diff --git a/pitfall/restructure/struct-test.rkt b/pitfall/restructure/struct-test.rkt new file mode 100644 index 00000000..ec967fc5 --- /dev/null +++ b/pitfall/restructure/struct-test.rkt @@ -0,0 +1,146 @@ +#lang restructure/racket +(require "struct.rkt" "string.rkt" "number.rkt" "buffer.rkt" "stream.rkt" rackunit) + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee +|# + + +;describe 'Struct', -> +; describe 'decode', -> +; it 'should decode into an object', -> +; stream = new DecodeStream new Buffer '\x05devon\x15' +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; +; struct.decode(stream).should.deep.equal +; name: 'devon' +; age: 21 + +(let ([stream (+DecodeStream (+Buffer (bytes->list (bytes-append (bytes #x05) #"devon" (bytes #x15)))))] + [struct (+Struct (dictify 'name (+StringT uint8) + 'age uint8))]) + (check-equal? (send struct decode stream) (dictify 'name "devon" + 'age 21))) + + +; +; it 'should support process hook', -> +; stream = new DecodeStream new Buffer '\x05devon\x20' +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; +; struct.process = -> +; @canDrink = @age >= 21 +; +; struct.decode(stream).should.deep.equal +; name: 'devon' +; age: 32 +; canDrink: true +; +; it 'should support function keys', -> +; stream = new DecodeStream new Buffer '\x05devon\x20' +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; canDrink: -> @age >= 21 +; +; struct.decode(stream).should.deep.equal +; name: 'devon' +; age: 32 +; canDrink: true +; +; describe 'size', -> +; it 'should compute the correct size', -> +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; +; struct.size(name: 'devon', age: 21).should.equal 7 +; +; it 'should compute the correct size with pointers', -> +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; ptr: new Pointer uint8, new StringT uint8 +; +; size = struct.size +; name: 'devon' +; age: 21 +; ptr: 'hello' +; +; size.should.equal 14 +; +; it 'should get the correct size when no value is given', -> +; struct = new Struct +; name: new StringT 4 +; age: uint8 +; +; struct.size().should.equal 5 +; +; it 'should throw when getting non-fixed length size and no value is given', -> +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; +; should.throw -> +; struct.size() +; , /not a fixed size/i +; +; describe 'encode', -> +; it 'should encode objects to buffers', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '\x05devon\x15' +; done() +; +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; +; struct.encode stream, +; name: 'devon' +; age: 21 +; +; stream.end() +; +; it 'should support preEncode hook', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '\x05devon\x15' +; done() +; +; struct = new Struct +; nameLength: uint8 +; name: new StringT 'nameLength' +; age: uint8 +; +; struct.preEncode = -> +; @nameLength = @name.length +; +; struct.encode stream, +; name: 'devon' +; age: 21 +; +; stream.end() +; +; it 'should encode pointer data after structure', (done) -> +; stream = new EncodeStream +; stream.pipe concat (buf) -> +; buf.should.deep.equal new Buffer '\x05devon\x15\x08\x05hello' +; done() +; +; struct = new Struct +; name: new StringT uint8 +; age: uint8 +; ptr: new Pointer uint8, new StringT uint8 +; +; struct.encode stream, +; name: 'devon' +; age: 21 +; ptr: 'hello' +; +; stream.end() \ No newline at end of file diff --git a/pitfall/restructure/struct.rkt b/pitfall/restructure/struct.rkt index b8ee16b5..26f00246 100644 --- a/pitfall/restructure/struct.rkt +++ b/pitfall/restructure/struct.rkt @@ -8,13 +8,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee |# (define-subclass Streamcoder (Struct [fields (dictify)]) - (inherit-field res) - (unless ((disjoin assocs? VersionedStruct?) fields) + (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] [length 0]) - (set! res (_setup stream parent length)) + (define/augride (decode stream [parent #f] [length_ 0]) + (define res (_setup stream parent length_)) (_parseFields stream res fields) (send this process res stream) res) @@ -47,7 +46,6 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (unless (assocs? fields) (raise-argument-error '_parseFields "assocs" fields)) (for ([(key type) (in-dict fields)]) - (report key) (define val (if (procedure? type) (type res) @@ -83,114 +81,3 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee - -#| -approximates -https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee -|# - -(define-subclass Struct (VersionedStruct type [versions (dictify)]) - (inherit-field res) - (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-field fields) - (field [forced-version #f]) - - (define/public-final (force-version! version) - (set! forced-version version)) - - (define/public (resolve-version [stream #f] [parent #f]) - (cond - [forced-version] ; for testing purposes: pass an explicit version - [(integer? type) type] - [(symbol? type) - ;; find the first Struct in the chain of ancestors - ;; with the target key - (let loop ([x parent]) - (cond - [(and x (Struct? x) (dict-ref (路 x res) type #f))] - [(路 x parent) => loop] - [else #f]))] - [(and (procedure? type) (positive? (procedure-arity type))) (type parent)] - [(RestructureBase? type) (send type decode stream)] - [else (raise-argument-error 'VersionedStruct:resolve-version "way of finding version" type)])) - - (define/override (decode stream [parent #f] [length 0]) - (set! res (send this _setup stream parent length)) - (report res 'versioned-struct-res) - (define version (resolve-version stream parent)) - (hash-set! res 'version version) - (define fields (dict-ref versions version (位 () (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (路 this versions)))))) - (cond - [(VersionedStruct? fields) (send fields decode stream parent)] - [else - (report res 'whatigot) - (send this _parseFields stream res fields) - (send this process res stream) - res])) - - (define/override (encode stream input-hash [parent #f]) - (unless (hash? input-hash) - (raise-argument-error 'Struct:encode "hash" input-hash)) - - (send this preEncode input-hash stream) ; preEncode goes first, because it might bring input hash into compliance - - (define fields (dict-ref versions (路 input-hash version) (位 () (raise-argument-error 'VersionedStruct:encode "valid version key" version)))) - - (unless (andmap (位 (key) (member key (hash-keys input-hash))) (dict-keys fields)) - (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys input-hash))) - - (cond - [(dict? fields) - (for* ([(key type) (in-dict fields)]) - (send type encode stream (hash-ref input-hash key)))] - [else (send fields encode stream input-hash parent)])) - - - (define/override (size [input-hash (mhash)] [parent #f] [includePointers #t]) - (when (and (not input-hash) (not forced-version)) - (error 'VersionedStruct-cannot-compute-size)) - (define version (resolve-version #f parent)) - (define fields (dict-ref versions version (位 () (raise-argument-error 'VersionedStruct:size "valid version key" version)))) - (cond - [(dict? fields) - (for/sum ([(key type) (in-dict fields)]) - (define val (hash-ref input-hash key #f)) - (define args (if val (list val) empty)) - (send type size . args))] - [else (send fields size input-hash parent includePointers)]))) - -(test-module - (require "number.rkt") - (check-exn exn:fail:contract? (位 () (+VersionedStruct 42 42))) - - ;; make random versioned structs and make sure we can round trip - (for ([i (in-range 20)]) - (define field-types (for/list ([i (in-range 200)]) - (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 (dict-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 (位 (p) 2) (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s)))) - (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) - - ) - - diff --git a/pitfall/restructure/versioned-struct.rkt b/pitfall/restructure/versioned-struct.rkt index 7ef9aac3..33bc81eb 100644 --- a/pitfall/restructure/versioned-struct.rkt +++ b/pitfall/restructure/versioned-struct.rkt @@ -1,3 +1,117 @@ #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)]) + (inherit-field res) + (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-field fields) + (field [forced-version #f]) + + (define/public-final (force-version! version) + (set! forced-version version)) + + (define/public (resolve-version [stream #f] [parent #f]) + (cond + [forced-version] ; for testing purposes: pass an explicit version + [(integer? type) type] + [(symbol? type) + ;; find the first Struct in the chain of ancestors + ;; with the target key + (let loop ([x parent]) + (cond + [(and x (Struct? x) (dict-ref (路 x res) type #f))] + [(路 x parent) => loop] + [else #f]))] + [(and (procedure? type) (positive? (procedure-arity type))) (type parent)] + [(RestructureBase? type) (send type decode stream)] + [else (raise-argument-error 'VersionedStruct:resolve-version "way of finding version" type)])) + + (define/override (decode stream [parent #f] [length 0]) + (set! res (send this _setup stream parent length)) + (report res 'versioned-struct-res) + (define version (resolve-version stream parent)) + (hash-set! res 'version version) + (define fields (dict-ref versions version (位 () (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (路 this versions)))))) + (cond + [(VersionedStruct? fields) (send fields decode stream parent)] + [else + (report res 'whatigot) + (send this _parseFields stream res fields) + (send this process res stream) + res])) + + (define/override (encode stream input-hash [parent #f]) + (unless (hash? input-hash) + (raise-argument-error 'Struct:encode "hash" input-hash)) + + (send this preEncode input-hash stream) ; preEncode goes first, because it might bring input hash into compliance + + (define fields (dict-ref versions (路 input-hash version) (位 () (raise-argument-error 'VersionedStruct:encode "valid version key" version)))) + + (unless (andmap (位 (key) (member key (hash-keys input-hash))) (dict-keys fields)) + (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys input-hash))) + + (cond + [(dict? fields) + (for* ([(key type) (in-dict fields)]) + (send type encode stream (hash-ref input-hash key)))] + [else (send fields encode stream input-hash parent)])) + + + (define/override (size [input-hash (mhash)] [parent #f] [includePointers #t]) + (when (and (not input-hash) (not forced-version)) + (error 'VersionedStruct-cannot-compute-size)) + (define version (resolve-version #f parent)) + (define fields (dict-ref versions version (位 () (raise-argument-error 'VersionedStruct:size "valid version key" version)))) + (cond + [(dict? fields) + (for/sum ([(key type) (in-dict fields)]) + (define val (hash-ref input-hash key #f)) + (define args (if val (list val) empty)) + (send type size . args))] + [else (send fields size input-hash parent includePointers)]))) + +(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 20)]) + (define field-types (for/list ([i (in-range 200)]) + (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 (dict-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 (位 (p) 2) (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s)))) + (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) + + ) + +