structing

xenomorph/xenomorph/struct.rkt

@@ -1,6 +1,6 @@
 #lang debug racket/base
-(require (prefix-in d: racket/dict)
-         racket/promise
+(require racket/dict
+         racket/class
          racket/sequence
          racket/list
          "helper.rkt"
@@ -13,10 +13,9 @@ approximates
 https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
 |#
 
-
 (define (xstruct-setup port parent len)
   (define mheq (make-hasheq))
-  (d:dict-set*! mheq
+  (dict-set*! mheq
                 'parent parent
                 '_startOffset (pos port)
                 '_currentOffset 0
@@ -24,109 +23,89 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
   mheq)
 
 (define (xstruct-parse-fields port sdr fields-arg)
-  (define fields (if (xstruct? fields-arg) (xstruct-fields fields-arg) fields-arg))
+  (define fields (if (xstruct? fields-arg) (get-field fields fields-arg) fields-arg))
   (unless (assocs? fields)
     (raise-argument-error 'xstruct-parse-fields "assocs" fields))
   (for/fold ([sdr sdr])
-            ([(key type) (d:in-dict fields)])
+            ([(key type) (in-dict fields)])
     (define val (if (procedure? type)
                     (type sdr)
-                    (xdecode type port #:parent sdr)))
+                    (send type xxdecode port sdr)))
     (unless (void? val)
-      (d:dict-set! sdr key val))
-    (d:dict-set! sdr '_currentOffset (- (pos port) (d:dict-ref sdr '_startOffset)))
+      (dict-set! sdr key val))
+    (dict-set! sdr '_currentOffset (- (pos port) (dict-ref sdr '_startOffset)))
     sdr))
 
-(define (xstruct-decode . args)
-  (dict->mutable-hash (apply xstruct-xdecode args)))
-
-(define (xstruct-xdecode xs [port-arg (current-input-port)] #:parent [parent #f] [len 0])
-  (define port (->input-port port-arg))
-  (parameterize ([current-input-port port])
-    ;; xstruct-setup and xstruct-parse-fields are separate to cooperate with VersionedStruct
-    (define decoded-hash
-      (post-decode xs
-                   (let* ([mheq (xstruct-setup port parent len)] ; returns StructDictRes
-                          [mheq (xstruct-parse-fields port mheq (xstruct-fields xs))])
-                     mheq)))
-    (unless (d:dict? decoded-hash)
-      (raise-result-error 'xstruct-decode "dict" decoded-hash))
-    decoded-hash))
-
-(define/finalize-size (xstruct-size xs [val #f] #:parent [parent-arg #f] #:include-pointers [include-pointers #t])
-  (define parent (mhasheq 'parent parent-arg
-                          'val val
-                          'pointerSize 0))
-  (define fields-size (for/sum ([(key type) (d:in-dict (xstruct-fields xs))]
-                                #:when (xenomorphic? type))
-                               (size type (and val (d:dict-ref val key)) #:parent parent)))
-  (define pointers-size (if include-pointers (d:dict-ref parent 'pointerSize) 0))
-  (+ fields-size pointers-size))
-
-(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f])
-  (unless (d:dict? val-arg)
-    (raise-argument-error 'xstruct-encode "dict" val-arg))
-  (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
-  (parameterize ([current-output-port port])
-    ;; check keys first, since `size` also relies on keys being valid
-    (define val (let* ([val (pre-encode xs val-arg)])
-                  (unless (d:dict? val)
-                    (raise-result-error 'xstruct-encode "dict" val))
-                  val))
-    (unless (andmap (λ (key) (memq key (d:dict-keys val))) (d:dict-keys (xstruct-fields xs)))
-      (raise-argument-error 'xstruct-encode
-                            (format "dict that contains superset of xstruct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val)))
+(define xstruct%
+  (class xenobase%
+    (super-new)
+    (init-field [(@fields fields)])
 
-    (define parent (mhash 'pointers empty
-                          'startOffset (pos port)
-                          'parent parent-arg
-                          'val val
-                          'pointerSize 0))
+    (define/augment (xxdecode port parent [len 0])
+      ;; xstruct-setup and xstruct-parse-fields are separate to cooperate with VersionedStruct
+      (define decoded-hash
+        (xstruct-parse-fields port (xstruct-setup port parent len) @fields))
+      (unless (dict? decoded-hash)
+        (raise-result-error 'xstruct-decode "dict" decoded-hash))
+      decoded-hash)
 
-    ; deliberately use `xstruct-size` instead of `size` to use extra arg
-    (d:dict-set! parent 'pointerOffset
-                 (+ (pos port) (xstruct-size xs val #:parent parent #:include-pointers #f)))
+    (define/augment (xxencode val port [parent-arg #f])
+      ;; check keys first, since `size` also relies on keys being valid
+      (unless (dict? val)
+        (raise-result-error 'xstruct-encode "dict" val))
+      (unless (andmap (λ (key) (memq key (dict-keys val))) (dict-keys @fields))
+        (raise-argument-error 'xstruct-encode
+                              (format "dict that contains superset of xstruct keys: ~a"
+                                      (dict-keys @fields)) (dict-keys val))) 
+      (define parent (mhash 'pointers empty
+                            'startOffset (pos port)
+                            'parent parent-arg
+                            'val val
+                            'pointerSize 0)) 
+      (dict-set! parent 'pointerOffset (+ (pos port) (xxsize-without-pointers val parent))) 
+      (for ([(key type) (in-dict @fields)])
+        (send type xxencode (dict-ref val key) port parent))
+      (for ([ptr (in-list (dict-ref parent 'pointers))])
+        (send (dict-ref ptr 'type) xxencode (dict-ref ptr 'val) port (dict-ref ptr 'parent))))
 
-    (for ([(key type) (d:in-dict (xstruct-fields xs))])
-         (encode type (d:dict-ref val key) #:parent parent))
-    (for ([ptr (in-list (d:dict-ref parent 'pointers))])
-         (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent)))
-    (unless port-arg (get-output-bytes port))))
+    (define (xxsize-without-pointers [val #f] [parent #f])
+      (define new-parent (mhasheq 'parent parent 'val val 'pointerSize 0))
+      (for/sum ([(key type) (in-dict @fields)]
+                #:when (xenomorphic-type? type))
+        (send type xxsize (and val (dict-ref val key)) new-parent)))
+    
+    (define/augment (xxsize [val #f] [parent #f])
+      (define pointers-size (dict-ref parent 'pointerSize))
+      (+ (xxsize-without-pointers val parent) pointers-size))))
 
-(struct structish xbase () #:transparent)
-(struct xstruct structish (fields) #:transparent #:mutable
-  #:methods gen:xenomorphic
-  [(define decode xstruct-decode)
-   (define xdecode xstruct-xdecode)
-   (define encode xstruct-encode)
-   (define size xstruct-size)])
+(define (xstruct? x) (is-a? x xstruct%))
 
-(define (+xstruct . dicts)
+(define (+xstruct #:subclass [class xstruct%] . dicts)
   (define args (flatten dicts))
   (unless (even? (length args))
     (raise-argument-error '+xstruct "equal number of keys and values" dicts))
   (define fields (for/list ([kv (in-slice 2 args)])
-                           (unless (symbol? (car kv))
-                             (raise-argument-error '+xstruct "symbol" (car kv)))
-                           (apply cons kv)))
-  (unless (d:dict? fields)
+                   (unless (symbol? (car kv))
+                     (raise-argument-error '+xstruct "symbol" (car kv)))
+                   (apply cons kv)))
+  (unless (dict? fields)
     (raise-argument-error '+xstruct "dict" fields))
-  (xstruct fields))
+  (new class [fields fields]))
 
 (module+ test
-  (require rackunit "number.rkt")
+  (require rackunit "number.rkt" "generic.rkt")
   (define (random-pick xs) (list-ref xs (random (length xs))))
   (check-exn exn:fail:contract? (λ () (+xstruct 42)))
   (for ([i (in-range 20)])
-       ;; make random structs and make sure we can round trip
-       (define field-types
-         (for/list ([i (in-range 40)])
-                   (random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
-       (define size-num-types
-         (for/sum ([num-type (in-list field-types)])
-                  (size num-type)))
-       (define xs (+xstruct (for/list ([num-type (in-list field-types)])
-                                      (cons (gensym) num-type))))
-       (define bs (apply bytes (for/list ([i (in-range size-num-types)])
-                                         (random 256))))
-       (check-equal? (encode xs (decode xs bs) #f) bs)))
+    ;; make random structs and make sure we can round trip
+    (define field-types
+      (for/list ([i (in-range 40)])
+        (random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
+    (define size-num-types
+      (for/sum ([num-type (in-list field-types)])
+        (size num-type)))
+    (define xs (+xstruct (for/list ([num-type (in-list field-types)])
+                           (cons (gensym) num-type))))
+    (define bs (apply bytes (for/list ([i (in-range size-num-types)])
+                              (random 256))))
+    (check-equal? (encode xs (decode xs bs) #f) bs)))

xenomorph/xenomorph/test/struct-test.rkt

@@ -1,10 +1,12 @@
 #lang debug racket/base
 (require rackunit racket/dict
+         racket/class
          "../helper.rkt"
          "../struct.rkt"
          "../string.rkt"
          "../pointer.rkt"
          "../number.rkt"
+         "../generic.rkt"
          sugar/unstable/dict)
 
 #|
@@ -22,8 +24,10 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
 (test-case
  "decode with process hook"
  (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
-   (define struct (+xstruct 'name (+xstring #:length uint8) 'age uint8))
-   (set-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o))
+   (define mystruct% (class xstruct%
+                       (super-new)
+                       (define/override (post-decode o) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o)))
+   (define struct (+xstruct #:subclass mystruct% 'name (+xstring #:length uint8) 'age uint8))
    (check-equal? (decode struct)
                  (mhasheq 'name "roxyb" 'age 32 'canDrink #t))))
 
@@ -63,10 +67,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
 (test-case
  "support pre-encode hook"
  (parameterize ([current-output-port (open-output-bytes)])
-   (define struct (+xstruct 'nameLength uint8
+   (define mystruct% (class xstruct%
+                       (super-new)
+                       (define/override (pre-encode val)
+                         (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val)))
+   (define struct (+xstruct #:subclass mystruct%
+                            'nameLength uint8
                             'name (+xstring 'nameLength)
                             'age uint8))
-   (set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))
+   ;(set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))
    (encode struct (mhasheq 'name "roxyb" 'age 21))
    (check-equal? (get-output-bytes (current-output-port)) #"\x05roxyb\x15")))