bitfield done

xenomorph/xenomorph/redo/bitfield.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+(require "helper.rkt" racket/dict sugar/unstable/dict)
+(provide (all-defined-out))
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
+|#
+
+(define (xbitfield-decode xb [port-arg (current-input-port)] #:parent [parent #f])
+  (define port (->input-port port-arg))
+  (define flag-hash (mhasheq))
+  (define val (decode (xbitfield-type xb) port))
+  (for ([(flag i) (in-indexed (xbitfield-flags xb))]
+        #:when flag)
+    (hash-set! flag-hash flag (bitwise-bit-set? val i)))
+  flag-hash)
+
+(define (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)))
+  (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 port)
+  (unless port-arg (get-output-bytes port)))
+
+(define (xbitfield-size xb [val #f] [ctx #f])
+  (size (xbitfield-type xb)))
+
+(struct xbitfield (type flags) #:transparent
+  #:methods gen:xenomorphic
+  [(define decode xbitfield-decode)
+   (define encode xbitfield-encode)
+   (define size xbitfield-size)])
+
+(define (+xbitfield type [flags null])
+  (unless (andmap (λ (f) (or (symbol? f) (not f))) flags)
+    (raise-argument-error '+xbitfield "list of symbols" flags))
+  (xbitfield type flags))
+
+(module+ test
+  (require rackunit "number.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
+  (check-true (dict-ref bf 'bold))
+  (check-true (dict-ref bf 'underline))
+  (check-true (dict-ref bf 'shadow))
+  (check-false (dict-ref bf 'italic))
+  (check-false (dict-ref bf 'condensed))
+  (check-false (dict-ref bf 'extended))
+  (check-equal? (encode bfer bf #f) #"\0\25"))

xenomorph/xenomorph/redo/test/bitfield-test.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+(require rackunit
+         racket/match
+         racket/list
+         sugar/unstable/dict
+         "../helper.rkt"
+         "../number.rkt"
+         "../bitfield.rkt")
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
+|#
+
+(define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
+(match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK)
+  (map (λ (x) (arithmetic-shift 1 x)) (range 8)))
+
+(test-case
+ "bitfield should have the right size"
+ (check-equal? (size bitfield) 1))
+
+(test-case
+ "bitfield should decode"
+ (parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
+   (check-equal? (decode bitfield) (mhasheq 'Quack #t
+                                            'Nack #t
+                                            'Lack #f
+                                            'Oack #f
+                                            'Pack #t
+                                            'Mack #t
+                                            'Jack #t
+                                            'Kack #f))))
+
+(test-case
+ "bitfield should encode"
+ (check-equal? (encode bitfield (mhasheq 'Quack #t
+                                         'Nack #t
+                                         'Lack #f
+                                         'Oack #f
+                                         'Pack #t
+                                         'Mack #t
+                                         'Jack #t
+                                         'Kack #f) #f)
+               (bytes (bitwise-ior JACK MACK PACK NACK QUACK))))

xenomorph/xenomorph/redo/test/main.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 
 (require "array-test.rkt"
-         ;"bitfield-test.rkt"
+         "bitfield-test.rkt"
          ;"buffer-test.rkt"
          ;"enum-test.rkt"
          ;"lazy-array-test.rkt"