From c125c7dcbc17dd8386eb8bbc0b45c0926a4abc82 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 3 Jul 2017 13:30:07 -0700 Subject: [PATCH] tweak --- pitfall/restructure/private/base.rkt | 44 +++++++++++- pitfall/restructure/private/stream.rkt | 81 ++++++++++++---------- pitfall/restructure/private/utils.rkt | 4 +- pitfall/restructure/test/array-test.rkt | 37 +++++----- pitfall/restructure/test/bitfield-test.rkt | 20 ++++-- pitfall/sugar/class.rkt | 31 +++++---- 6 files changed, 136 insertions(+), 81 deletions(-) diff --git a/pitfall/restructure/private/base.rkt b/pitfall/restructure/private/base.rkt index 38d16ee0..64ba8138 100644 --- a/pitfall/restructure/private/base.rkt +++ b/pitfall/restructure/private/base.rkt @@ -1,12 +1,50 @@ #lang racket/base -(require racket/class sugar/class) +(require racket/class sugar/class racket/generic racket/private/generic-methods) (provide (all-defined-out)) -(define-subclass object% (RestructureBase) +(define-generics encodable + (decode encodable stream [parent]) + (encode encodable stream [val] [parent])) + + +(define encodable<%> + (interface* () + ([(generic-property gen:encodable) + (generic-method-table gen:encodable + (define (decode o stream [parent #f]) (send o decode stream parent)) + (define (encode o stream [val #f] [parent #f]) (send o encode stream val parent)))]))) + + +(define-generics sizable + (size sizable [val] [parent])) + +(define sizable<%> + (interface* () + ([(generic-property gen:sizable) + (generic-method-table gen:sizable + (define (size o [val #f] [parent #f]) (send o size val parent)))]))) + + +(define-generics dumpable + (dump dumpable)) + +(define dumpable<%> + (interface* () + ([(generic-property gen:dumpable) + (generic-method-table gen:dumpable + (define (dump o) (send o dump)))]))) + + +(define RestructureBase + (class* object% (encodable<%> sizable<%> dumpable<%>) + (super-new) (field [_hash (make-hash)] [_list null]) (define/public (decode stream . args) (void)) (define/public (encode . xs) (void)) (define/public (size . xs) (void)) (define/public (process . args) (void)) - (define/public (preEncode . args) (void))) \ No newline at end of file + (define/public (preEncode . args) (void)) + (define/public (dump) (void)))) + +(define-class-predicates RestructureBase) \ No newline at end of file diff --git a/pitfall/restructure/private/stream.rkt b/pitfall/restructure/private/stream.rkt index d653a216..c9fd9018 100644 --- a/pitfall/restructure/private/stream.rkt +++ b/pitfall/restructure/private/stream.rkt @@ -21,39 +21,43 @@ 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)]) +(define EncodeStream + (class* PortWrapper (dumpable<%>) + (init-field [[maybe-output-port maybe-output-port] (open-output-bytes)]) - (unless (output-port? maybe-output-port) - (raise-argument-error 'EncodeStream:constructor "output port" maybe-output-port)) + (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) + (super-make-object maybe-output-port) + (inherit-field _port) - (define/override-final (dump) (get-output-bytes _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 (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 (writeBuffer buffer) + (write buffer)) - (define/public-final (writeUInt8 int) - (write (bytes int))) + (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)))) + (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))))) + +(define-class-predicates EncodeStream) (test-module (define es (+EncodeStream)) @@ -69,12 +73,12 @@ https://github.com/mbutterick/restructure/blob/master/src/EncodeStream.coffee (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? (dump es2) #"FOOBAR") + (check-equal? (dump es2) #"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))) + (check-equal? (dump es3) (make-bytes 10 0))) #| approximates @@ -98,7 +102,7 @@ https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee (define DecodeStreamT (class* PortWrapper - (countable<%>) + (encodable<%> dumpable<%> countable<%>) (init-field [buffer #""]) (unless (bytes? buffer) ; corresponds to a Node Buffer, not a restructure BufferT object (raise-argument-error 'DecodeStream:constructor "bytes" buffer)) @@ -161,16 +165,17 @@ https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee (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? (dump ds) #"ABCD") + (check-equal? (dump ds) #"ABCD") ; dump can repeat (check-equal? (send ds readUInt16BE) 16706) - (check-equal? (send ds dump) #"ABCD") + (check-equal? (dump ds) #"ABCD") (check-equal? (· ds pos) 2) (check-equal? (send ds readUInt8) 67) (check-equal? (· ds pos) 3) @@ -203,13 +208,13 @@ https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee (test-module (define-subclass Streamcoder (Dummy) - (define/augment (decode stream . args) "foo") + (define/augment (decode stream parent) "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)))) \ No newline at end of file + (check-exn exn:fail:contract? (λ () (decode d 42))) + (check-not-exn (λ () (decode d #"foo"))) + (check-exn exn:fail:contract? (λ () (encode d 42 21))) + (check-not-exn (λ () (encode d (open-output-bytes) 42)))) \ No newline at end of file diff --git a/pitfall/restructure/private/utils.rkt b/pitfall/restructure/private/utils.rkt index 2d880233..36fd58b9 100644 --- a/pitfall/restructure/private/utils.rkt +++ b/pitfall/restructure/private/utils.rkt @@ -1,8 +1,8 @@ #lang reader (submod "racket.rkt" reader) -(provide (all-defined-out) (rename-out [resolveLength resolve-length])) +(provide (all-defined-out)) (require "number.rkt") -(define (resolveLength len-arg [stream #f] [parent #f]) +(define (resolve-length len-arg [stream #f] [parent #f]) (cond [(not len-arg) #f] [(number? len-arg) len-arg] diff --git a/pitfall/restructure/test/array-test.rkt b/pitfall/restructure/test/array-test.rkt index 44fc7c3c..b5659ae5 100644 --- a/pitfall/restructure/test/array-test.rkt +++ b/pitfall/restructure/test/array-test.rkt @@ -15,7 +15,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint8 4)]) - (check-equal? (send array decode stream) '(1 2 3 4))) + (check-equal? (decode array stream) '(1 2 3 4))) ; it 'should decode fixed amount of bytes', -> @@ -24,7 +24,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream).should.deep.equal [258, 772] (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint16be 4 'bytes)]) - (check-equal? (send array decode stream) '(258 772))) + (check-equal? (decode array stream) '(258 772))) ; it 'should decode length from parent key', -> @@ -34,7 +34,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint8 4 'len)]) - (check-equal? (send array decode stream (mhash 'len 4)) '(1 2 3 4))) + (check-equal? (decode array stream (mhash 'len 4)) '(1 2 3 4))) ; it 'should decode amount of bytes from parent key', -> @@ -43,7 +43,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream, len: 4).should.deep.equal [258, 772] (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint16be 'len 'bytes)]) - (check-equal? (send array decode stream (mhash 'len 4)) '(258 772))) + (check-equal? (decode array stream (mhash 'len 4)) '(258 772))) ; it 'should decode length as number before array', -> @@ -52,7 +52,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream).should.deep.equal [1, 2, 3, 4] (let ([stream (+DecodeStream (+Buffer '(4 1 2 3 4 5)))] [array (+ArrayT uint8 uint8)]) - (check-equal? (send array decode stream) '(1 2 3 4))) + (check-equal? (decode array stream) '(1 2 3 4))) ; it 'should decode amount of bytes as number before array', -> @@ -61,7 +61,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream).should.deep.equal [258, 772] (let ([stream (+DecodeStream (+Buffer '(4 1 2 3 4 5)))] [array (+ArrayT uint16be uint8 'bytes)]) - (check-equal? (send array decode stream) '(258 772))) + (check-equal? (decode array stream) '(258 772))) ; it 'should decode length from function', -> ; stream = new DecodeStream new Buffer [1, 2, 3, 4, 5] @@ -69,7 +69,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream).should.deep.equal [1, 2, 3, 4] (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint8 (λ _ 4))]) - (check-equal? (send array decode stream) '(1 2 3 4))) + (check-equal? (decode array stream) '(1 2 3 4))) ; it 'should decode amount of bytes from function', -> @@ -78,7 +78,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream).should.deep.equal [258, 772] (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint16be (λ _ 4) 'bytes)]) - (check-equal? (send array decode stream) '(258 772))) + (check-equal? (decode array stream) '(258 772))) ; it 'should decode to the end of the parent if no length is given', -> @@ -87,13 +87,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream, _length: 4, _startOffset: 0).should.deep.equal [1, 2, 3, 4] (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint8)]) - (check-equal? (send array decode stream (mhash '_length 4 '_startOffset 0)) '(1 2 3 4))) + (check-equal? (decode array stream (mhash '_length 4 '_startOffset 0)) '(1 2 3 4))) ; decode to the end of the stream if parent exists, but its length is 0 (let ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+ArrayT uint8)]) - (check-equal? (send array decode stream (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5))) + (check-equal? (decode array stream (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5))) ; it 'should decode to the end of the stream if no parent and length is given', -> @@ -102,7 +102,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.decode(stream).should.deep.equal [1, 2, 3, 4] (let ([stream (+DecodeStream (+Buffer '(1 2 3 4)))] [array (+ArrayT uint8)]) - (check-equal? (send array decode stream) '(1 2 3 4))) + (check-equal? (decode array stream) '(1 2 3 4))) ; describe 'size', -> @@ -110,7 +110,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array = new ArrayT uint8, 10 ; array.size([1, 2, 3, 4]).should.equal 4 (let ([array (+ArrayT uint8 10)]) - (check-equal? (send array size '(1 2 3 4)) 4)) + (check-equal? (size array '(1 2 3 4)) 4)) ; it 'should add size of length field before string', -> @@ -118,14 +118,14 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee ; array.size([1, 2, 3, 4]).should.equal 5 ; (let ([array (+ArrayT uint8 uint8)]) - (check-equal? (send array size '(1 2 3 4)) 5)) + (check-equal? (size array '(1 2 3 4)) 5)) ; it 'should use defined length if no value given', -> ; array = new ArrayT uint8, 10 ; array.size().should.equal 10 (let ([array (+ArrayT uint8 10)]) - (check-equal? (send array size) 10)) + (check-equal? (size array) 10)) ; describe 'encode', -> @@ -141,8 +141,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (let ([stream (+EncodeStream)] [array (+ArrayT uint8 10)]) - (send array encode stream '(1 2 3 4)) - (check-equal? (send stream dump) (+Buffer '(1 2 3 4)))) + (check-equal? (encode array #f '(1 2 3 4)) (+Buffer '(1 2 3 4)))) ; @@ -158,8 +157,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (let ([stream (+EncodeStream)] [array (+ArrayT uint8 uint8)]) - (send array encode stream '(1 2 3 4)) - (check-equal? (send stream dump) (+Buffer '(4 1 2 3 4)))) + (check-equal? (encode array #f '(1 2 3 4)) (+Buffer '(4 1 2 3 4)))) ; it 'should add pointers after array if length is encoded at start', (done) -> @@ -174,5 +172,4 @@ https://github.com/mbutterick/restructure/blob/master/test/Array.coffee (let ([stream (+EncodeStream)] [array (+ArrayT (+Pointer uint8 uint8) uint8)]) - (send array encode stream '(1 2 3 4)) - (check-equal? (send stream dump) (+Buffer '(4 5 6 7 8 1 2 3 4)))) \ No newline at end of file + (check-equal? (encode array #f '(1 2 3 4)) (+Buffer '(4 5 6 7 8 1 2 3 4)))) \ No newline at end of file diff --git a/pitfall/restructure/test/bitfield-test.rkt b/pitfall/restructure/test/bitfield-test.rkt index 79e098d7..a3e9ac03 100644 --- a/pitfall/restructure/test/bitfield-test.rkt +++ b/pitfall/restructure/test/bitfield-test.rkt @@ -34,8 +34,14 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee ; Jack: yes, Kack: no, Lack: no, Mack: yes, Nack: yes, Oack: no, Pack: yes, Quack: yes (let ([stream (+DecodeStream (+Buffer (list (bitwise-ior JACK MACK PACK NACK QUACK))))]) - (for/and ([(k v) (in-hash (send bitfield decode stream))]) - (check-equal? v (hash-ref #hasheq((Quack . #t) (Nack . #t) (Lack . #f) (Oack . #f) (Pack . #t) (Mack . #t) (Jack . #t) (Kack . #f)) k)))) + (check-equal? (decode bitfield stream) (mhasheq 'Quack #t + 'Nack #t + 'Lack #f + 'Oack #f + 'Pack #t + 'Mack #t + 'Jack #t + 'Kack #f))) ; @@ -48,6 +54,12 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee ; bitfield.encode stream, Jack: yes, Kack: no, Lack: no, Mack: yes, Nack: yes, Oack: no, Pack: yes, Quack: yes (let ([stream (+EncodeStream)]) - (define h #hasheq((Quack . #t) (Nack . #t) (Lack . #f) (Oack . #f) (Pack . #t) (Mack . #t) (Jack . #t) (Kack . #f))) - (send bitfield encode stream h) + (send bitfield encode stream (mhasheq 'Quack #t + 'Nack #t + 'Lack #f + 'Oack #f + 'Pack #t + 'Mack #t + 'Jack #t + 'Kack #f)) (check-equal? (send stream dump) (+Buffer (list (bitwise-ior JACK MACK PACK NACK QUACK))))) diff --git a/pitfall/sugar/class.rkt b/pitfall/sugar/class.rkt index 50d026a1..e70716a2 100644 --- a/pitfall/sugar/class.rkt +++ b/pitfall/sugar/class.rkt @@ -19,9 +19,9 @@ (define-macro (as-method ID) (with-pattern ([PRIVATE-ID (generate-temporary #'ID)]) - #'(begin - (public [PRIVATE-ID ID]) - (define (PRIVATE-ID . args) (apply ID this args))))) + #'(begin + (public [PRIVATE-ID ID]) + (define (PRIVATE-ID . args) (apply ID this args))))) (define-macro (as-methods ID ...) @@ -30,20 +30,23 @@ (define-macro (define-instance ID (MAKER BASE-CLASS . ARGS)) (with-pattern ([ID-CLASS (prefix-id #'BASE-CLASS ":" #'ID)]) - #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))]) - (MAKER ID-CLASS . ARGS))))) + #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))]) + (MAKER ID-CLASS . ARGS))))) (define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) #'(define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) -(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) +(define-macro (define-class-predicates ID) (with-pattern ([+ID (prefix-id "+" #'ID)] [ID? (suffix-id #'ID "?")]) - #'(begin - (define ID (class SUPERCLASS (init-field . INIT-ARGS) . BODY)) - (define (ID? x) (is-a? x ID)) - (define (+ID . args) (apply make-object ID args))))) + #'(begin (define (ID? x) (is-a? x ID)) + (define (+ID . args) (apply make-object ID args))))) + +(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) + #'(begin + (define ID (class SUPERCLASS (init-field . INIT-ARGS) . BODY)) + (define-class-predicates ID))) (define-macro (push-field! FIELD O EXPR) @@ -70,7 +73,7 @@ (define-macro (getter-field [ID . EXPRS]) (with-pattern ([_ID (prefix-id "_" #'ID)]) - #`(begin - (field [(ID _ID) . EXPRS]) - (public (_ID ID)) - (#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID)))) \ No newline at end of file + #`(begin + (field [(ID _ID) . EXPRS]) + (public (_ID ID)) + (#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID)))) \ No newline at end of file