From 18c6ba40d03148ae59e2853e62231643258b9e1c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 28 Jun 2017 19:11:45 -0700 Subject: [PATCH] struct tests pass --- pitfall/restructure/generic.rkt | 13 ++++-- pitfall/restructure/struct-test.rkt | 70 ++++++++++++++++++++++++++--- pitfall/restructure/struct.rkt | 50 ++++++++++++++++----- 3 files changed, 113 insertions(+), 20 deletions(-) diff --git a/pitfall/restructure/generic.rkt b/pitfall/restructure/generic.rkt index a3e8e6e3..5b03c113 100644 --- a/pitfall/restructure/generic.rkt +++ b/pitfall/restructure/generic.rkt @@ -11,26 +11,31 @@ (define-generics indexable (ref indexable i) (ref-set! indexable i v) + (ref-keys indexable) #:defaults ([hash? (define ref hash-ref) - (define ref-set! hash-set!)] + (define ref-set! hash-set!) + (define ref-keys hash-keys)] [object? (define (ref o i) (with-handlers ([exn:fail:object? (λ (exn) (hash-ref (get-field _hash o) i))]) (dynamic-get-field i o))) - (define (ref-set! o i v) (with-handlers ([exn:fail:object? (λ (exn) (hash-set! (get-field _hash o) i v))]) (dynamic-set-field! i o v)))])) + (define (ref-set! o i v) (with-handlers ([exn:fail:object? (λ (exn) (hash-set! (get-field _hash o) i v))]) (dynamic-set-field! i o v))) + (define (ref-keys o) (append (remove '_hash (field-names o)) (hash-keys (get-field _hash o))))])) (module+ test - (require rackunit) + (require rackunit racket/set) (define h (make-hash '((foo . 42)))) (check-equal? (ref h 'foo) 42) (ref-set! h 'foo 85) (check-equal? (ref h 'foo) 85) (ref-set! h 'bar 121) (check-equal? (ref h 'bar) 121) + (check-equal? (apply set (ref-keys h)) (apply set '(foo bar))) (define o (make-object (class object% (super-new) (field [_hash (make-hash)][foo 42])))) (check-equal? (ref o 'foo) 42) (ref-set! o 'foo 100) (check-equal? (ref o 'foo) 100) (ref-set! o 'bar 121) - (check-equal? (ref o 'bar) 121)) + (check-equal? (ref o 'bar) 121) + (check-equal? (apply set (ref-keys o)) (apply set '(foo bar)))) (define (ref* c . is) (for/fold ([c c]) diff --git a/pitfall/restructure/struct-test.rkt b/pitfall/restructure/struct-test.rkt index ec967fc5..d204dfe4 100644 --- a/pitfall/restructure/struct-test.rkt +++ b/pitfall/restructure/struct-test.rkt @@ -22,8 +22,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (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))) + (check-equal? (send (send struct decode stream) ht) + (mhasheq 'name "devon" 'age 21))) ; @@ -40,6 +40,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; name: 'devon' ; age: 32 ; canDrink: true + +(let ([stream (+DecodeStream (+Buffer (bytes->list (bytes-append (bytes #x05) #"devon" (bytes #x20)))))] + [struct (+Struct (dictify 'name (+StringT uint8) + 'age uint8))]) + (set-field! process struct (λ (o stream) (ref-set! o 'canDrink (>= (ref o 'age) 21)))) + (check-equal? (send (send struct decode stream) ht) + (mhasheq 'name "devon" 'age 32 'canDrink #t))) + + ; ; it 'should support function keys', -> ; stream = new DecodeStream new Buffer '\x05devon\x20' @@ -52,6 +61,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; name: 'devon' ; age: 32 ; canDrink: true + +(let ([stream (+DecodeStream (+Buffer (bytes->list (bytes-append (bytes #x05) #"devon" (bytes #x20)))))] + [struct (+Struct (dictify 'name (+StringT uint8) + 'age uint8 + 'canDrink (λ (o) (>= (ref o 'age) 21))))]) + (check-equal? (send (send struct decode stream) ht) + (mhasheq 'name "devon" 'age 32 'canDrink #t))) + + ; ; describe 'size', -> ; it 'should compute the correct size', -> @@ -60,7 +78,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; age: uint8 ; ; struct.size(name: 'devon', age: 21).should.equal 7 -; + +(let ([struct (+Struct (dictify 'name (+StringT uint8) + 'age uint8))]) + (check-equal? (send struct size (hasheq 'name "devon" 'age 32)) 7)) + + +; todo: when pointers are ready ; it 'should compute the correct size with pointers', -> ; struct = new Struct ; name: new StringT uint8 @@ -73,6 +97,11 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; ptr: 'hello' ; ; size.should.equal 14 + + +(displayln 'warning:pointer-not-done) + + ; ; it 'should get the correct size when no value is given', -> ; struct = new Struct @@ -80,6 +109,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; age: uint8 ; ; struct.size().should.equal 5 + + +(let ([struct (+Struct (dictify 'name (+StringT 4) + 'age uint8))]) + (check-equal? (send struct size) 5)) + + ; ; it 'should throw when getting non-fixed length size and no value is given', -> ; struct = new Struct @@ -89,6 +125,11 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; should.throw -> ; struct.size() ; , /not a fixed size/i + +(let ([struct (+Struct (dictify 'name (+StringT uint8) + 'age uint8))]) + (check-exn exn:fail:contract? (λ () (send struct size)))) + ; ; describe 'encode', -> ; it 'should encode objects to buffers', (done) -> @@ -106,6 +147,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; age: 21 ; ; stream.end() + +(let ([stream (+DecodeStream (+Buffer (bytes->list (bytes-append (bytes #x05) #"devon" (bytes #x15)))))] + [struct (+Struct (dictify 'name (+StringT uint8) + 'age uint8))]) + (check-equal? (send (send struct decode stream) ht) + (mhasheq 'name "devon" 'age 21))) + ; ; it 'should support preEncode hook', (done) -> ; stream = new EncodeStream @@ -126,7 +174,18 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; age: 21 ; ; stream.end() -; + +(let ([stream (+EncodeStream)] + [struct (+Struct (dictify 'nameLength uint8 + 'name (+StringT 'nameLength) + 'age uint8))]) + (set-field! preEncode struct (λ (val stream) (ref-set! val 'nameLength (length (ref val 'name))))) + (send struct encode stream (mhasheq 'name "devon" 'age 21)) + (check-equal? (send stream dump) + (+Buffer (bytes->list (bytes-append (bytes #x05) #"devon" (bytes #x15)))))) + + +; todo: when pointer is ready ; it 'should encode pointer data after structure', (done) -> ; stream = new EncodeStream ; stream.pipe concat (buf) -> @@ -143,4 +202,5 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee ; age: 21 ; ptr: 'hello' ; -; stream.end() \ No newline at end of file +; stream.end() +(displayln 'warning:pointer-not-done) \ No newline at end of file diff --git a/pitfall/restructure/struct.rkt b/pitfall/restructure/struct.rkt index 26f00246..9829646b 100644 --- a/pitfall/restructure/struct.rkt +++ b/pitfall/restructure/struct.rkt @@ -1,5 +1,5 @@ #lang restructure/racket -(require racket/dict "stream.rkt") +(require racket/dict "stream.rkt" racket/private/generic-methods racket/struct) (provide (all-defined-out)) #| @@ -7,7 +7,33 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee |# +(define hashable<%> + (interface* () + ([(generic-property gen:indexable) + (generic-method-table gen:indexable + (define (ref o i) (or (hash-ref (get-field kv o) i #f) + (hash-ref (get-field _hash o) i #f))) + (define (ref-set! o i v) (hash-set! (get-field kv o) i v)) + (define (ref-keys o) (hash-keys (get-field kv o))))] + [(generic-property gen:custom-write) + (generic-method-table gen:custom-write + (define (write-proc o port mode) + (define proc (case mode + [(#t) write] + [(#f) display] + [else (λ (p port) (print p port mode))])) + (proc (get-field kv o) port)))]))) + +(define StructRes (class* RestructureBase (hashable<%>) + (super-make-object) + (field [kv (mhasheq)]) + (define/public (ht) kv))) + (define-subclass Streamcoder (Struct [fields (dictify)]) + (field [[_process process] void] + [[_preEncode preEncode] void]) ; store as field so it can be mutated from outside + (define/override (process . args) (apply _process args)) + (define/override (preEncode . args) (apply _preEncode args)) (unless ((disjoin assocs? Struct?) fields) ; should be Versioned Struct but whatever (raise-argument-error 'Struct "assocs or Versioned Struct" fields)) @@ -15,28 +41,28 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define/augride (decode stream [parent #f] [length_ 0]) (define res (_setup stream parent length_)) (_parseFields stream res fields) - (send this process res stream) + (process res stream) res) (define/augride (encode stream input-hash [parent #f]) - (unless (hash? input-hash) - (raise-argument-error 'Struct:encode "hash" input-hash)) + #;(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)) + (unless (andmap (λ (key) (member key (ref-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)))] + (send type encode stream (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 + (define res (make-object StructRes)) ; not mere hash + (hash-set*! (· res _hash) 'parent parent '_startOffset (· stream pos) '_currentOffset 0 '_length length) @@ -49,9 +75,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (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))))) + (send type decode stream res))) + ;; skip PropertyDescriptor maneuver. Only used for lazy pointer + (ref-set! res key val) + (hash-set! (· res _hash) '_currentOffset (- (· stream pos) (ref res '_startOffset))))) + (define/override (size [input-hash (mhash)] [parent #f] [includePointers #t]) (for/sum ([(key type) (in-dict fields)])