tweak

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)))
+    (define/public (preEncode . args) (void))
+    (define/public (dump) (void))))
+
+(define-class-predicates RestructureBase)

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))))
+ (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))))

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]

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))))
+  (check-equal? (encode array #f '(1 2 3 4)) (+Buffer '(4 5 6 7 8 1 2 3 4))))

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)))))

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))))
+                #`(begin
+                    (field [(ID _ID)  . EXPRS])
+                    (public (_ID ID))
+                    (#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID))))