diff --git a/xenomorph/xenomorph/bitfield.rkt b/xenomorph/xenomorph/bitfield.rkt index 9478317b..4cd03728 100644 --- a/xenomorph/xenomorph/bitfield.rkt +++ b/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 diff --git a/xenomorph/xenomorph/test/bitfield-test.rkt b/xenomorph/xenomorph/test/bitfield-test.rkt index 883285c3..c60f9e14 100644 --- a/xenomorph/xenomorph/test/bitfield-test.rkt +++ b/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