resume in bitfield

xenomorph/xenomorph/bitfield.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require "helper.rkt" racket/dict sugar/unstable/dict)
+(require "helper.rkt" racket/class racket/dict sugar/unstable/dict)
 (provide (all-defined-out))
 
 #|
@@ -7,45 +7,62 @@ approximates
 https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
 |#
 
-(define/post-decode (xbitfield-decode xb [port-arg (current-input-port)] #:parent [parent #f])
-  (define port (->input-port port-arg))
-  (parameterize ([current-input-port port])
+#;(define/post-decode (xbitfield-decode xb [port-arg (current-input-port)] #:parent [parent #f])
+    (define port (->input-port port-arg))
+    (parameterize ([current-input-port port])
+      ))
+
+#;(define/pre-encode (xbitfield-encode xb flag-hash [port-arg (current-output-port)] #:parent [parent #f])
+    (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
+    (parameterize ([current-output-port port])
+      
+      (unless port-arg (get-output-bytes port))))
+
+#;(define (xbitfield-size xb [val #f] #:parent [parent #f])
+    )
+
+#;(struct xbitfield xbase (type flags) #:transparent
+    #:methods gen:xenomorphic
+    [(define decode xbitfield-decode)
+     (define xdecode xbitfield-decode)
+     (define encode xbitfield-encode)
+     (define size xbitfield-size)])
+
+(define xbitfield%
+  (class xenobase%
+    (super-new)
+    (init-field type flags)
+
     (define flag-hash (mhasheq))
-    (define val (xdecode (xbitfield-type xb)))
-    (for ([(flag i) (in-indexed (xbitfield-flags xb))]
-          #:when flag)
-      (hash-set! flag-hash flag (bitwise-bit-set? val i)))
-    flag-hash))
-
-(define/pre-encode (xbitfield-encode xb flag-hash [port-arg (current-output-port)] #:parent [parent #f])
-  (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
-  (parameterize ([current-output-port port])
-    (define bit-int (for/sum ([(flag i) (in-indexed (xbitfield-flags xb))]
-                              #:when (and flag (dict-ref flag-hash flag #f)))
-                      (arithmetic-shift 1 i)))
-    (encode (xbitfield-type xb) bit-int)
-    (unless port-arg (get-output-bytes port))))
-
-(define (xbitfield-size xb [val #f] #:parent [parent #f])
-  (size (xbitfield-type xb)))
-
-(struct xbitfield xbase (type flags) #:transparent
-  #:methods gen:xenomorphic
-  [(define decode xbitfield-decode)
-   (define xdecode xbitfield-decode)
-   (define encode xbitfield-encode)
-   (define size xbitfield-size)])
 
+    (define/augment (xxdecode port parent)
+      (define val (send type xxdecode port))
+      (for ([(flag i) (in-indexed flags)]
+            #:when flag)
+           (hash-set! flag-hash flag (bitwise-bit-set? val i)))
+      flag-hash)
+
+    (define/augment (xxencode array port [parent #f])
+      (define bit-int (for/sum ([(flag i) (in-indexed flags)]
+                                #:when (and flag (dict-ref flag-hash flag #f)))
+                               (arithmetic-shift 1 i)))
+      (send type xxencode bit-int port))
+    
+    (define/augment (xxsize [val #f] [parent #f])
+      (send type xxsize))))
+  
 (define (+xbitfield [type-arg #f] [flag-arg #f]
-                    #:type [type-kwarg #f] #:flags [flag-kwarg #f])
+                    #:type [type-kwarg #f]
+                    #:flags [flag-kwarg #f]
+                    #:subclass [class xbitfield%])
   (define type (or type-arg type-kwarg))
   (define flags (or flag-arg flag-kwarg null))
   (unless (andmap (λ (f) (or (symbol? f) (not f))) flags)
     (raise-argument-error '+xbitfield "list of symbols" flags))
-  (xbitfield type flags))
+  (new class [type type] [flags flags]))
 
 (module+ test
-  (require rackunit "number.rkt")
+  (require rackunit "number.rkt" "generic.rkt")
   (define bfer (+xbitfield uint16be '(bold italic underline #f shadow condensed extended)))
   (define bf (decode bfer #"\0\25"))
   (check-equal? (length (dict-keys bf)) 6) ; omits #f flag

xenomorph/xenomorph/test/bitfield-test.rkt

@@ -1,11 +1,13 @@
 #lang racket/base
 (require rackunit
          racket/match
+         racket/class
          racket/list
          sugar/unstable/dict
          "../helper.rkt"
          "../number.rkt"
-         "../bitfield.rkt")
+         "../bitfield.rkt"
+         "../generic.rkt")
 
 #|
 approximates
@@ -35,7 +37,10 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
 (test-case
  "bitfield should decode with post-decode"
  (parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
-   (set-post-decode! bitfield (λ (fh . _) (hash-set! fh 'foo 42) fh))
+   (define mybitfield% (class xbitfield%
+                         (super-new)
+                         (define/override (post-decode fh) (hash-set! fh 'foo 42) fh)))
+   (define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) #:subclass mybitfield%))
    (check-equal? (decode bitfield) (mhasheq 'Quack #t
                                             'Nack #t
                                             'Lack #f
@@ -60,11 +65,14 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
 
 (test-case
  "bitfield should encode with pre-encode"
- (set-pre-encode! bitfield (λ (fh . _)
-                             (hash-set! fh 'Jack #f)
-                             (hash-set! fh 'Mack #f)
-                             (hash-set! fh 'Pack #f)
-                             fh))
+ (define mybitfield% (class xbitfield%
+                       (super-new)
+                       (define/override (pre-encode fh)
+                         (hash-set! fh 'Jack #f)
+                         (hash-set! fh 'Mack #f)
+                         (hash-set! fh 'Pack #f)
+                         fh)))
+ (define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) #:subclass mybitfield%))
  (check-equal? (encode bitfield (mhasheq 'Quack #t
                                          'Nack #t
                                          'Lack #f