From c2c498c9f643c8faf2c5ab4e877c0e128866d29a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 2 Jul 2017 11:53:48 -0700 Subject: [PATCH] refac --- pitfall/restructure/array.rkt | 111 ++++++++++------------- pitfall/restructure/base.rkt | 10 +- pitfall/restructure/generic.rkt | 11 ++- pitfall/restructure/helper.rkt | 3 + pitfall/restructure/lazy-array-test.rkt | 8 +- pitfall/restructure/lazy-array.rkt | 101 +++++++++------------ pitfall/restructure/stream.rkt | 2 +- pitfall/restructure/utils.rkt | 15 +-- pitfall/restructure/versioned-struct.rkt | 3 +- pitfall/sugar/js.rkt | 7 +- 10 files changed, 124 insertions(+), 147 deletions(-) diff --git a/pitfall/restructure/array.rkt b/pitfall/restructure/array.rkt index 9eb310f9..f7ab9669 100644 --- a/pitfall/restructure/array.rkt +++ b/pitfall/restructure/array.rkt @@ -1,5 +1,5 @@ #lang restructure/racket -(require "number.rkt" (prefix-in utils- "utils.rkt") "stream.rkt") +(require "number.rkt" "utils.rkt" "stream.rkt") (provide (all-defined-out)) #| @@ -7,79 +7,66 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Array.coffee |# -(define-subclass Streamcoder (ArrayT type [length_ #f] [lengthType 'count]) +(define-subclass Streamcoder (ArrayT type [len #f] [length-type 'count]) (define/augride (decode stream [parent #f]) - (define pos (send stream pos)) - - (define res (make-object RestructureBase)) ; instead of empty list - (define ctx parent) - - (define length__ - (and length_ (utils-resolveLength length_ stream parent))) - - (when (NumberT? length_) - ;; define hidden properties - (ref-set*! res 'parent parent - '_startOffset pos - '_currentOffset 0 - '_length length_) - (set! ctx res)) + (define ctx (if (NumberT? len) + (mhasheq 'parent parent + '_startOffset (· stream pos) + '_currentOffset 0 + '_length len) + parent)) + (define decoded-len (resolve-length len stream parent)) (cond - [(or (not length__) (eq? lengthType 'bytes)) - (define target (cond - [length__ (+ (send stream pos) length__)] - [(and parent (positive? (· parent _length))) - (+ (ref parent '_startOffset) - (ref parent '_length))] - [else (· stream length_)])) - (ref-set! res '_list - (push-end res - (for/list ([i (in-naturals)] - #:break (= (send stream pos) target)) - (send type decode stream ctx))))] - [else - (ref-set! res '_list - (push-end res - (for/list ([i (in-range length__)]) - (send type decode stream ctx))))]) + [(or (not decoded-len) (eq? length-type 'bytes)) + (define end-pos (cond + ;; decoded-len is byte length + [decoded-len (+ (· stream pos) decoded-len)] + ;; no decoded-len, but parent has length + [(and parent (not (zero? (· parent _length)))) (+ (· parent _startOffset) (· parent _length))] + ;; no decoded-len or parent, so consume whole stream + [else (· stream length_)])) + (for/list ([i (in-naturals)] + #:break (= (· stream pos) end-pos)) + (send type decode stream ctx))] + ;; we have decoded-len, which is treated as count of items + [else (for/list ([i (in-range decoded-len)]) + (send type decode stream ctx))])) + - (countable->list res)) - - (define/override (size [array #f] [ctx #f]) - (when array - (unless (countable? array) - (raise-argument-error 'Array:size "list or countable" array))) + (define/override (size [val #f] [ctx #f]) + (when val (unless (countable? val) + (raise-argument-error 'Array:size "list or countable" val))) (cond - [(not array) - (* (send type size #f ctx) (utils-resolveLength length_ #f ctx))] - [else - (+ (cond - [(NumberT? length_) - (set! ctx (mhash 'parent ctx)) - (send length_ size)] - [else 0]) - (for/sum ([item (in-list (countable->list array))]) - (send type size item ctx)))])) + [val (let-values ([(ctx len-size) (if (NumberT? len) + (values (mhasheq 'parent ctx) (send len size)) + (values ctx 0))]) + (+ len-size (for/sum ([item (in-list (countable->list val))]) + (send type size item ctx))))] + [else (let ([item-count (resolve-length len #f ctx)] + [item-size (send type size #f ctx)]) + (* item-size item-count))])) + (define/augride (encode stream array [parent #f]) (when array (unless (countable? array) (raise-argument-error 'Array:encode "list or countable" array))) - (define ctx parent) - (when (NumberT? length_) - (set! ctx (mhash 'pointers null - 'startOffset (· stream pos) - 'parent parent)) - (ref-set! ctx 'pointerOffset (+ (· stream pos) (size array ctx))) - (send length_ encode stream (length array))) - (for ([item (in-list (countable->list array))]) - (send type encode stream item ctx)) + (define (encode-items ctx) + (for ([item (in-list (countable->list array))]) + (send type encode stream item ctx))) - (when (NumberT? length_) - (for ([ptr (in-list (· ctx pointers))]) - (send (· ptr type) encode stream (· ptr val)))))) + (cond + [(NumberT? len) (define ctx (mhash 'pointers null + 'startOffset (· stream pos) + 'parent parent)) + (ref-set! ctx 'pointerOffset (+ (· stream pos) (size array ctx))) + (send len encode stream (length array)) ; encode length at front + (encode-items ctx) + (for ([ptr (in-list (· ctx pointers))]) ; encode pointer data at end + (send (· ptr type) encode stream (· ptr val)))] + [else (encode-items parent)]))) (define-values (Array Array? +Array) (values ArrayT ArrayT? +ArrayT)) diff --git a/pitfall/restructure/base.rkt b/pitfall/restructure/base.rkt index 0583fd2b..38d16ee0 100644 --- a/pitfall/restructure/base.rkt +++ b/pitfall/restructure/base.rkt @@ -1,16 +1,12 @@ #lang racket/base -(require racket/class sugar/debug) +(require racket/class sugar/class) (provide (all-defined-out)) -(define RestructureBase - (class object% - (super-new) +(define-subclass object% (RestructureBase) (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)))) - -(define (RestructureBase? x) (is-a? x RestructureBase)) \ No newline at end of file + (define/public (preEncode . args) (void))) \ No newline at end of file diff --git a/pitfall/restructure/generic.rkt b/pitfall/restructure/generic.rkt index a0cef86d..04387488 100644 --- a/pitfall/restructure/generic.rkt +++ b/pitfall/restructure/generic.rkt @@ -9,17 +9,20 @@ (provide (all-defined-out)) (define-generics indexable - (ref indexable i) + (ref indexable i [thunk]) + (ref! indexable i [thunk]) (ref-set! indexable i v) (ref-keys indexable) #:defaults - ([hash? (define (ref o i) (hash-ref o i #f)) + ([hash? (define (ref o i [thunk #f]) (hash-ref o i thunk)) + (define (ref! o i [thunk #f]) (hash-ref! o i thunk)) (define ref-set! hash-set!) (define ref-keys hash-keys)] - [dict? (define (ref o i) (dict-ref o i #f)) + [dict? (define (ref o i [thunk #f]) (dict-ref o i thunk)) + (define (ref! o i [thunk #f]) (dict-ref o i thunk)) (define ref-set! dict-set!) (define ref-keys dict-keys)] - [object? (define (ref o i) (with-handlers ([exn:fail:object? (λ (exn) (hash-ref (get-field _hash o) i #f))]) (dynamic-get-field i o))) + [object? (define (ref o i [thunk #f]) (with-handlers ([exn:fail:object? (λ (exn) (hash-ref (get-field _hash o) i thunk))]) (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-keys o) (append (remove '_hash (field-names o)) (hash-keys (get-field _hash o))))])) diff --git a/pitfall/restructure/helper.rkt b/pitfall/restructure/helper.rkt index de983a1b..97186ed1 100644 --- a/pitfall/restructure/helper.rkt +++ b/pitfall/restructure/helper.rkt @@ -10,6 +10,9 @@ (define index? (λ (x) (and (number? x) (integer? x) (not (negative? x))))) +(define key? symbol?) +(define (keys? x) (and (pair? x) (andmap key? x))) + (define (unsigned->signed uint bits) (define most-significant-bit-mask (arithmetic-shift 1 (sub1 bits))) (- (bitwise-xor uint most-significant-bit-mask) most-significant-bit-mask)) diff --git a/pitfall/restructure/lazy-array-test.rkt b/pitfall/restructure/lazy-array-test.rkt index d9538276..f74d68fa 100644 --- a/pitfall/restructure/lazy-array-test.rkt +++ b/pitfall/restructure/lazy-array-test.rkt @@ -29,7 +29,7 @@ https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee [array (+LazyArray uint8 4)]) (define arr (send array decode stream)) (check-false (Array? arr)) - (check-equal? (ref arr 'length_) 4) + (check-equal? (ref arr 'len) 4) (check-equal? (send stream pos) 4) (check-equal? (send arr get 0) 1) (check-equal? (send arr get 1) 2) @@ -49,7 +49,7 @@ https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee (let* ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+LazyArray uint8 4)]) (define arr (send array decode stream)) - (check-equal? (send arr toArray) '(1 2 3 4))) + (check-equal? (send arr to-list) '(1 2 3 4))) ; ; it 'should have an inspect method', -> @@ -59,7 +59,7 @@ https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee ; arr = array.decode(stream) ; arr.inspect().should.equal '[ 1, 2, 3, 4 ]' -(let* ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] +#;(let* ([stream (+DecodeStream (+Buffer '(1 2 3 4 5)))] [array (+LazyArray uint8 4)]) (define arr (send array decode stream)) (check-equal? (send arr inspect) (format "~a" '(1 2 3 4)))) @@ -75,7 +75,7 @@ https://github.com/mbutterick/restructure/blob/master/test/LazyArray.coffee (let* ([stream (+DecodeStream (+Buffer '(4 1 2 3 4 5)))] [array (+LazyArray uint8 uint8)]) (define arr (send array decode stream)) - (check-equal? (send arr toArray) '(1 2 3 4))) + (check-equal? (send arr to-list) '(1 2 3 4))) ; ; describe 'size', -> diff --git a/pitfall/restructure/lazy-array.rkt b/pitfall/restructure/lazy-array.rkt index 3c28d250..9b4f2db9 100644 --- a/pitfall/restructure/lazy-array.rkt +++ b/pitfall/restructure/lazy-array.rkt @@ -1,5 +1,5 @@ #lang restructure/racket -(require (prefix-in utils- "utils.rkt") "array.rkt" "number.rkt") +(require "utils.rkt" "array.rkt" "number.rkt") (provide (all-defined-out)) #| @@ -7,77 +7,66 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee |# -(define-subclass object% (InnerLazyArray type [length_ #f] [stream #f] [ctx #f]) - (define base (and stream (· stream pos))) - (define items (mhash)) ; rather than empty array +(define-subclass object% (InnerLazyArray type [len #f] [stream #f] [ctx #f]) + (unless stream (raise-argument-error 'LazyArray "stream" stream)) + (define starting-pos (· stream pos)) + (define item-cache (mhasheqv)) ; integer-keyed hash, rather than list (define/public-final (get index) - (cond - [(or (< index 0) (>= index length_)) #f] - [else - (define item (with-handlers ([exn:fail? (λ _ #f)]) - (ref items index))) - (or item - (let () - (define pos_ (· stream pos)) - (send stream pos (+ base (* (send type size #f ctx) index))) - (define new-item (send type decode stream ctx)) - (ref-set! items index new-item) - (send stream pos pos_) - new-item))])) + (unless (<= 0 index (sub1 len)) + (raise-argument-error 'LazyArray:get (format "index in range 0 to ~a" len) index)) + (ref! item-cache index (λ () + (define orig-pos (· stream pos)) + (send stream pos (+ starting-pos (* (send type size #f ctx) index))) + (define new-item (send type decode stream ctx)) + (send stream pos orig-pos) + new-item))) - (define/public-final (toArray) - (for/list ([i (in-range length_)]) - (get i))) + (define/public-final (to-list) + (for/list ([i (in-range len)]) + (get i)))) - (define/public-final (inspect) - (format "~a" (toArray)))) (define-subclass ArrayT (LazyArray) - (inherit-field length_ type) + (inherit-field len type) (define/override (decode stream [parent #f]) - (define pos (· stream pos)) - (define length__ (utils-resolveLength length_ stream parent)) - - (when (NumberT? length_) - ;; define hidden properties - (set! parent (mhash 'parent parent - '_startOffset pos - '_currentOffset 0 - '_length length_))) - - (define res (+InnerLazyArray type length__ stream parent)) - (send stream pos (+ (· stream pos) (* length__ (send type size #f parent)))) - res) + (define decoded-len (resolve-length len stream parent)) + (let ([parent (if (NumberT? len) + (mhasheq 'parent parent + '_startOffset (· stream pos) + '_currentOffset 0 + '_length len) + parent)]) + (define res (+InnerLazyArray type decoded-len stream parent)) + (send stream pos (+ (· stream pos) (* decoded-len (send type size #f parent)))) + res)) (define/override (size [val #f] [ctx #f]) (super size (if (InnerLazyArray? val) - (send val toArray) + (send val to-list) val) ctx)) (define/override (encode stream val [ctx #f]) (super encode stream (if (InnerLazyArray? val) - (send val toArray) + (send val to-list) val) ctx))) -#;(test-module - (require "stream.rkt") - (define bstr #"ABCD1234") - (define ds (+DecodeStream bstr)) - (define la (+LazyArray uint8 4)) - (define ila (send la decode ds)) - (check-equal? (send ds pos) 4) - (check-equal? (send ila get 1) 66) - (check-equal? (send ila get 3) 68) - (check-equal? (send ds pos) 4) - (check-equal? (send ila toArray) '(65 66 67 68)) - - (define la2 (+LazyArray int16be (λ (t) 4))) - (define es (+EncodeStream)) - (send la2 encode es '(1 2 3 4)) - (check-equal? (send es dump) #"\0\1\0\2\0\3\0\4") - (check-equal? (send (send la2 decode (+DecodeStream #"\0\1\0\2\0\3\0\4")) toArray) '(1 2 3 4)) +(test-module + (require "stream.rkt") + (define bstr #"ABCD1234") + (define ds (+DecodeStream bstr)) + (define la (+LazyArray uint8 4)) + (define ila (send la decode ds)) + (check-equal? (send ds pos) 4) + (check-equal? (send ila get 1) 66) + (check-equal? (send ila get 3) 68) + (check-equal? (send ds pos) 4) + (check-equal? (send ila to-list) '(65 66 67 68)) - ) + (define la2 (+LazyArray int16be (λ (t) 4))) + (define es (+EncodeStream)) + (send la2 encode es '(1 2 3 4)) + (check-equal? (send es dump) #"\0\1\0\2\0\3\0\4") + (check-equal? (send (send la2 decode (+DecodeStream #"\0\1\0\2\0\3\0\4")) to-list) '(1 2 3 4))) diff --git a/pitfall/restructure/stream.rkt b/pitfall/restructure/stream.rkt index fa7051c6..182d7435 100644 --- a/pitfall/restructure/stream.rkt +++ b/pitfall/restructure/stream.rkt @@ -178,7 +178,7 @@ https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee (define-subclass RestructureBase (Streamcoder) (define/overment (decode x [parent #f]) (when parent (unless (indexable? parent) - (raise-argument-error 'Streamcoder:decode "hash or incexable" x))) + (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)) diff --git a/pitfall/restructure/utils.rkt b/pitfall/restructure/utils.rkt index 37a536c9..a6f1fad5 100644 --- a/pitfall/restructure/utils.rkt +++ b/pitfall/restructure/utils.rkt @@ -1,11 +1,12 @@ #lang restructure/racket -(provide (all-defined-out)) +(provide (all-defined-out) (rename-out [resolveLength resolve-length])) (require "number.rkt") -(define (resolveLength length [stream #f] [parent #f]) +(define (resolveLength len-arg [stream #f] [parent #f]) (cond - [(number? length) length] - [(procedure? length) (length parent)] - [(and parent (symbol? length)) (ref parent length)] ; treat as key into RStruct parent - [(and stream (NumberT? length)) (send length decode stream)] - [else (raise-argument-error 'resolveLength "fixed-size argument" length)])) \ No newline at end of file + [(not len-arg) #f] + [(number? len-arg) len-arg] + [(procedure? len-arg) (len-arg parent)] + [(and parent (key? len-arg)) (ref parent len-arg)] ; treat as key into RStruct parent + [(and stream (NumberT? len-arg)) (send len-arg decode stream)] + [else (raise-argument-error 'resolveLength "fixed-size argument" len-arg)])) \ No newline at end of file diff --git a/pitfall/restructure/versioned-struct.rkt b/pitfall/restructure/versioned-struct.rkt index 3b75bb7e..b896234e 100644 --- a/pitfall/restructure/versioned-struct.rkt +++ b/pitfall/restructure/versioned-struct.rkt @@ -6,8 +6,7 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee |# -(define key? symbol?) -(define (keys? x) (and (pair? x) (andmap key? x))) + (define-subclass Struct (VersionedStruct type [versions (dictify)]) diff --git a/pitfall/sugar/js.rkt b/pitfall/sugar/js.rkt index d74ebf9f..d994e0de 100644 --- a/pitfall/sugar/js.rkt +++ b/pitfall/sugar/js.rkt @@ -54,10 +54,9 @@ #'(let loop ([x X]) (cond ;; dict first, to catch objects that implement gen:dict - [(and (dict? x) (dict-ref x 'REF #f))] - [(dict? x) #f] - [(and (object? x) (or (get-or-false x REF) (send-or-false x REF)))] - [(object? x) #f] + [(dict? x) (dict-ref x 'REF #f)] + ;; give `send` precedence (presence of method => wants runtime resolution of value) + [(object? x) (or (send-or-false x REF) (get-or-false x REF))] [else (raise-argument-error '· (format "~a must be object or dict" 'X) x)]))] [(_ X REF0 . REFS) #'(· (· X REF0) . REFS)])