diff --git a/xenomorph/xenomorph/optional.rkt b/xenomorph/xenomorph/optional.rkt index 4f224d71..5c411ce1 100644 --- a/xenomorph/xenomorph/optional.rkt +++ b/xenomorph/xenomorph/optional.rkt @@ -1,6 +1,5 @@ - #lang debug racket/base -(require "helper.rkt") +(require "helper.rkt" racket/class) (provide (all-defined-out)) #| @@ -8,54 +7,42 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee |# -(define (resolve-condition xo parent) - (define maybe-proc (xoptional-condition xo)) - (if (procedure? maybe-proc) - (maybe-proc parent) - maybe-proc)) - -(define/post-decode (xoptional-decode xo [port-arg (current-input-port)] #:parent [parent #f]) - (define port (->input-port port-arg)) - (parameterize ([current-input-port port]) - (when (resolve-condition xo parent) - (xdecode (xoptional-type xo) #:parent parent)))) - -(define/pre-encode (xoptional-encode xo val [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]) - (when (resolve-condition xo parent) - (encode (xoptional-type xo) val #:parent parent)) - (unless port-arg (get-output-bytes port)))) +(define xoptional% + (class xenobase% + (super-new) + (init-field type condition) -(define/finalize-size (xoptional-size xo [val #f] #:parent [parent #f]) - (when (resolve-condition xo parent) - (size (xoptional-type xo) val #:parent parent))) - -(struct xoptional xbase (type condition) #:transparent - #:methods gen:xenomorphic - [(define decode xoptional-decode) - (define xdecode xoptional-decode) - (define encode xoptional-encode) - (define size xoptional-size)]) - -#;(define (+xoptional [type-arg #f] [cond-arg #f] - #:type [type-kwarg #f] - #:condition [cond-kwarg #f]) - (define type (or type-arg type-kwarg)) - (unless (xenomorphic? type) + (unless (xenomorphic-type? type) (raise-argument-error '+xoptional"xenomorphic type" type)) - (define condition (or cond-arg cond-kwarg)) - (xoptional type condition)) + + (define (resolve-condition parent) + (define maybe-proc condition) + (if (procedure? maybe-proc) + (maybe-proc parent) + maybe-proc)) + + (define/augment (xxdecode port parent) + (when (resolve-condition parent) + (send type xxdecode port parent))) + + (define/augment (xxencode val port [parent #f]) + (when (resolve-condition parent) + (send type xxencode val port parent))) + + (define/augment (xxsize [val #f] [parent #f]) + (if (resolve-condition parent) + (send type xxsize val parent) + 0)))) + (define no-val (gensym)) (define (+xoptional [type-arg #f] [cond-arg no-val] #:type [type-kwarg #f] - #:condition [cond-kwarg no-val]) + #:condition [cond-kwarg no-val] + #:subclass [class xoptional%]) (define type (or type-arg type-kwarg)) - (unless (xenomorphic? type) - (raise-argument-error '+xoptional"xenomorphic type" type)) (define condition (cond [(and (eq? cond-arg no-val) (eq? cond-kwarg no-val)) #true] [(not (eq? cond-arg no-val)) cond-arg] [(not (eq? cond-kwarg no-val)) cond-kwarg])) - (xoptional type condition)) + (new class [type type] [condition condition])) diff --git a/xenomorph/xenomorph/test/array-test.rkt b/xenomorph/xenomorph/test/array-test.rkt index 94662914..c1ae7375 100644 --- a/xenomorph/xenomorph/test/array-test.rkt +++ b/xenomorph/xenomorph/test/array-test.rkt @@ -1,7 +1,6 @@ #lang racket/base (require rackunit racket/class - "../helper.rkt" "../array.rkt" "../number.rkt" "../pointer.rkt" diff --git a/xenomorph/xenomorph/test/bitfield-test.rkt b/xenomorph/xenomorph/test/bitfield-test.rkt index c60f9e14..7e0b7059 100644 --- a/xenomorph/xenomorph/test/bitfield-test.rkt +++ b/xenomorph/xenomorph/test/bitfield-test.rkt @@ -4,7 +4,6 @@ racket/class racket/list sugar/unstable/dict - "../helper.rkt" "../number.rkt" "../bitfield.rkt" "../generic.rkt") diff --git a/xenomorph/xenomorph/test/buffer-test.rkt b/xenomorph/xenomorph/test/buffer-test.rkt index 2d6c4cd8..591ed059 100644 --- a/xenomorph/xenomorph/test/buffer-test.rkt +++ b/xenomorph/xenomorph/test/buffer-test.rkt @@ -1,10 +1,8 @@ #lang racket/base (require rackunit racket/class - sugar/unstable/dict "../buffer.rkt" "../number.rkt" - "../helper.rkt" "../generic.rkt") #| diff --git a/xenomorph/xenomorph/test/enum-test.rkt b/xenomorph/xenomorph/test/enum-test.rkt index bcad246b..5b54b96e 100644 --- a/xenomorph/xenomorph/test/enum-test.rkt +++ b/xenomorph/xenomorph/test/enum-test.rkt @@ -1,8 +1,6 @@ #lang racket/base (require rackunit racket/class - sugar/unstable/dict - "../helper.rkt" "../number.rkt" "../enum.rkt" "../generic.rkt") diff --git a/xenomorph/xenomorph/test/number-test.rkt b/xenomorph/xenomorph/test/number-test.rkt index 728f6d29..ac105d6b 100644 --- a/xenomorph/xenomorph/test/number-test.rkt +++ b/xenomorph/xenomorph/test/number-test.rkt @@ -2,7 +2,6 @@ (require rackunit racket/class "../number.rkt" - "../helper.rkt" "../generic.rkt") #| diff --git a/xenomorph/xenomorph/test/optional-test.rkt b/xenomorph/xenomorph/test/optional-test.rkt index 8d70d07a..35cd625e 100644 --- a/xenomorph/xenomorph/test/optional-test.rkt +++ b/xenomorph/xenomorph/test/optional-test.rkt @@ -1,8 +1,10 @@ #lang racket/base (require rackunit + racket/class "../helper.rkt" "../number.rkt" - "../optional.rkt") + "../optional.rkt" + "../generic.rkt") #| approximates @@ -19,8 +21,10 @@ https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee (test-case "decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes 0))]) - (define optional (+xoptional #:type uint8 #:condition #f)) - (set-post-decode! optional (λ (val) 42)) + (define myxopt% (class xoptional% + (super-new) + (define/override (post-decode val) 42))) + (define optional (+xoptional #:type uint8 #:condition #f #:subclass myxopt%)) (check-equal? (decode optional) 42) (check-equal? (pos (current-input-port)) 0))) @@ -82,8 +86,10 @@ https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee (test-case "encode with pre-encode" (parameterize ([current-output-port (open-output-bytes)]) - (define optional (+xoptional #:type uint8)) - (set-pre-encode! optional (λ (val) 42)) + (define myxopt% (class xoptional% + (super-new) + (define/override (pre-encode val) 42))) + (define optional (+xoptional #:type uint8 #:subclass myxopt%)) (encode optional 128) (check-equal? (get-output-bytes (current-output-port)) (bytes 42))))