resume in versioned struct

xenomorph/xenomorph/test/versioned-struct-test.rkt

@@ -7,6 +7,7 @@
          "../string.rkt"
          "../pointer.rkt"
          "../struct.rkt"
+         "../generic.rkt"
          "../versioned-struct.rkt")
 
 #|
@@ -71,10 +72,10 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                                 'age uint8
                                                 'gender uint8)))])
    (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
-     (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0)))
+     (check-equal? (decode vstruct #:parent (mhash 'version 0))
                    (mhasheq 'name "roxyb" 'age 21 'version 0)))
    (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))])
-     (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 1)))
+     (check-equal? (decode vstruct #:parent (mhash 'version 1))
                    (mhasheq 'name "roxyb 🤘"  'age 21 'version 1 'gender 0)))))
 
 (test-case
@@ -89,16 +90,16 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                                             1 (dictify 'name (+xstring uint8)
                                                                        'isDessert uint8)))))])
    (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
-     (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0)))
+     (check-equal? (decode vstruct #:parent (mhash 'version 0))
                    (mhasheq 'name "roxyb" 'age 21 'version 0)))
    (parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")])
-     (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0)))
+     (check-equal? (decode vstruct #:parent (mhash 'version 0))
                    (mhasheq 'name "pasta" 'version 0)))
    (parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")])
-     (check-equal? (dict->mutable-hash (xdecode vstruct #:parent (mhash 'version 0)))
+     (check-equal? (decode vstruct #:parent (mhash 'version 0))
                    (mhasheq 'name "ice cream" 'isDessert 1 'version 1)))))
 
-(test-case
+#;(test-case
  "decode should support process hook"
  (let ([vstruct (+xversioned-struct uint8
                                     (dictify
@@ -233,7 +234,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
 
    (check-equal? (get-output-bytes op) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello"))))
 
-(test-case
+#;(test-case
  "encode should support preEncode hook"
  (let ([vstruct (+xversioned-struct uint8
                                     (dictify

xenomorph/xenomorph/versioned-struct.rkt

@@ -1,6 +1,7 @@
 #lang debug racket/base
 (require "helper.rkt" "struct.rkt"
          racket/dict
+         racket/class
          sugar/unstable/dict)
 (provide (all-defined-out))
 
@@ -9,105 +10,99 @@ approximates
 https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
 |#
 
-(define (xversioned-struct-decode . args)
-  (dict->mutable-hash (apply xversioned-struct-xdecode args)))
+(define xversioned-struct%
+  (class xstruct%
+    (super-new)
+    (init-field [(@type type)] [(@versions versions)])
+    (inherit-field [@fields fields])
 
-(define/post-decode (xversioned-struct-xdecode xvs [port-arg (current-input-port)] #:parent [parent-arg #f] [length 0])
-  (define port (->input-port port-arg))
-  (define parent (or (current-parent) parent-arg))
-  (define res (xstruct-setup port parent length))
+    (define version-getter (cond
+                             [(procedure? @type) @type]
+                             [(symbol? @type) (λ (parent) (dict-ref parent @type))]))
 
-  (dict-set! res 'version
-             (cond
-               [(integer? (xversioned-struct-type xvs)) (xversioned-struct-type xvs)]
-               #;[forced-version] ; for testing purposes: pass an explicit version
-               [(or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))
-                (unless parent
-                  (raise-argument-error 'xversioned-struct-decode "valid parent" parent))
-                ((xversioned-struct-version-getter xvs) parent)]
-               [else (xdecode (xversioned-struct-type xvs) port)]))
+    (define version-setter (cond
+                             [(procedure? @type) @type]
+                             [(symbol? @type) (λ (parent version) (dict-set! parent @type version))]))
 
-  (when (dict-ref (xversioned-struct-versions xvs) 'header #f)
-    (xstruct-parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header)))
-    
-  (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref res 'version #f) #f)
-                     (raise-argument-error 'xversioned-struct-decode "valid version key" (cons version (xversioned-struct-versions xvs)))))
-    
-  (cond
-    [(xversioned-struct? fields) (xdecode fields port #:parent parent)]
-    [else (xstruct-parse-fields port res fields)
-          res]))
+    (define (extract-fields-dict val)
+      (define field-object (dict-ref @versions (dict-ref val 'version #f) #f))
+      (unless field-object
+        (raise-argument-error 'xversioned-struct-encode "valid version key" version))
+      (if (xstruct? field-object) (get-field fields field-object) field-object))
 
-(define (extract-fields-dict xvs val)
-  (define field-object (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f) #f))
-  (unless field-object
-    (raise-argument-error 'xversioned-struct-encode "valid version key" version))
-  (if (xstruct? field-object) (xstruct-fields field-object) field-object))
+    (define/augment (xxdecode port parent [length 0])
+      (define res (xstruct-setup port parent length))
+      (dict-set! res 'version
+                 (cond
+                   [(integer? @type) @type]
+                   #;[forced-version] ; for testing purposes: pass an explicit version
+                   [(or (symbol? @type) (procedure? @type))
+                    (unless parent
+                      (raise-argument-error 'xversioned-struct-decode "valid parent" parent))
+                    (version-getter parent)]
+                   [else (send @type xxdecode port)]))
 
-(define/finalize-size (xversioned-struct-size xvs [val #f] #:parent [parent-arg #f] [include-pointers #t])
-  (unless val
-    (raise-argument-error 'xversioned-struct-size "value" val))
-  (define parent (mhash 'parent parent-arg 'val val 'pointerSize 0))
-  (define version-size
-    (let ([struct-type (xversioned-struct-type xvs)])
-      (if (or (symbol? struct-type) (procedure? struct-type))
-          0
-          (size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent))))
-  (define header-size
-    (for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))])
-             (size type (and val (dict-ref val key)) #:parent parent)))
-  (define fields-size
-    (for/sum ([(key type) (in-dict (extract-fields-dict xvs val))])
-             (size type (and val (dict-ref val key)) #:parent parent)))
-  (define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0))
-  (+ version-size header-size fields-size pointer-size))
+      (when (dict-ref @versions 'header #f)
+        (xstruct-parse-fields port res (dict-ref @versions 'header)))
+    
+      (define fields
+        (or (dict-ref @versions (dict-ref res 'version #f) #f)
+            (raise-argument-error 'xversioned-struct-decode "valid version key" (cons version @versions))))
+    
+      (cond
+        [(xversioned-struct? fields) (send fields xxdecode port parent)]
+        [else (xstruct-parse-fields port res fields)
+              res]))
 
-(define/pre-encode (xversioned-struct-encode xvs encode-me [port-arg (current-output-port)]
-                                             #:parent [parent-arg #f])
-  (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
-  (parameterize ([current-output-port port])
-    (unless (dict? encode-me)
-      (raise-argument-error 'xversioned-struct-encode "dict" encode-me))
-    (define parent (mhash 'pointers null
-                          'startOffset (pos port)
-                          'parent parent-arg
-                          'val encode-me
-                          'pointerSize 0))
-    (dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs encode-me #:parent parent #f)))
-    (unless (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))
-      (encode (xversioned-struct-type xvs) (dict-ref encode-me 'version #f)))
-    (define maybe-header-dict (dict-ref (xversioned-struct-versions xvs) 'header #f))
-    (when maybe-header-dict
-      (for ([(key type) (in-dict maybe-header-dict)])
-           (encode type (dict-ref encode-me key) #:parent parent)))
+    (define/augment (xxencode encode-me port [parent-arg #f])
+      (unless (dict? encode-me)
+        (raise-argument-error 'xversioned-struct-encode "dict" encode-me))
+      (define parent (mhash 'pointers null
+                            'startOffset (pos port)
+                            'parent parent-arg
+                            'val encode-me
+                            'pointerSize 0))
+      (dict-set! parent 'pointerOffset (+ (pos port) (xxsize encode-me parent #f)))
+      (unless (or (symbol? @type) (procedure? @type))
+        (send @type xxencode (dict-ref encode-me 'version #f) port parent))
+      (define maybe-header-dict (dict-ref @versions 'header #f))
+      (when maybe-header-dict
+        (for ([(key type) (in-dict maybe-header-dict)])
+          (send type xxencode (dict-ref encode-me key) port parent)))
 
-    (define fields (extract-fields-dict xvs encode-me))
-    (unless (andmap (λ (key) (member key (dict-keys encode-me))) (dict-keys fields))
-      (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys encode-me)))
-    (for ([(key type) (in-dict fields)])
-         (encode type (dict-ref encode-me key) #:parent parent))
-    (for ([ptr (in-list (dict-ref parent 'pointers))])
-         (encode (dict-ref ptr 'type) (dict-ref ptr 'val) #:parent (dict-ref ptr 'parent)))
-    (unless port-arg (get-output-bytes port))))
+      (define fields (extract-fields-dict encode-me))
+      (unless (andmap (λ (key) (member key (dict-keys encode-me))) (dict-keys fields))
+        (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys encode-me)))
+      (for ([(key type) (in-dict fields)])
+        (send type xxencode (dict-ref encode-me 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))))
+    
+    (define/augment (xxsize [val #f] [parent-arg #f] [include-pointers #t])
+      (unless val
+        (raise-argument-error 'xversioned-struct-size "value" val))
+      (define parent (mhash 'parent parent-arg 'val val 'pointerSize 0))
+      (define version-size
+        (let ([struct-type @type])
+          (if (or (symbol? struct-type) (procedure? struct-type))
+              0
+              (send @type xxsize (dict-ref val 'version) parent))))
+      (define header-size
+        (for/sum ([(key type) (in-dict (or (dict-ref @versions 'header #f) null))])
+          (send type xxsize (and val (dict-ref val key)) parent)))
+      (define fields-size
+        (for/sum ([(key type) (in-dict (extract-fields-dict val))])
+          (send type xxsize (and val (dict-ref val key)) parent)))
+      (define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0))
+      (+ version-size header-size fields-size pointer-size))))
 
-(struct xversioned-struct structish (type versions version-getter version-setter) #:transparent #:mutable
-  #:methods gen:xenomorphic
-  [(define decode xversioned-struct-decode)
-   (define xdecode xversioned-struct-xdecode)
-   (define encode xversioned-struct-encode)
-   (define size xversioned-struct-size)])
+(define (xversioned-struct? x) (is-a? x xversioned-struct%))
 
-(define (+xversioned-struct type [versions (dictify)])
-  (unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)])
-                  (proc type))
+(define (+xversioned-struct #:subclass [class xversioned-struct%] type [versions (dictify)])
+  (unless (for/or ([proc (list integer? procedure? xenomorphic-type? symbol?)])
+            (proc type))
     (raise-argument-error '+xversioned-struct "integer, procedure, symbol, or xenomorphic" type))
-  (unless (and (dict? versions) (andmap (λ (v) (or (dict? v) (structish? v))) (dict-values versions)))
+  (unless (and (dict? versions) (andmap (λ (v) (or (dict? v) (xstruct? v))) (dict-values versions)))
     (raise-argument-error '+xversioned-struct "dict of dicts or structish" versions))
-  (define version-getter (cond
-                           [(procedure? type) type]
-                           [(symbol? type) (λ (parent) (dict-ref parent type))]))
-  (define version-setter (cond
-                           [(procedure? type) type]
-                           [(symbol? type) (λ (parent version) (dict-set! parent type version))]))
-  (xversioned-struct type versions version-getter version-setter))
+  (new class [type type] [versions versions]))