xoptional

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

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"

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

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

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

xenomorph/xenomorph/test/number-test.rkt

@@ -2,7 +2,6 @@
 (require rackunit
          racket/class
          "../number.rkt"
-         "../helper.rkt"
          "../generic.rkt")
 
 #|

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