support structs as field sources

6 years ago · f5d2309164
parent ecb3e4a1cf
commit f5d2309164
4 changed files with 84 additions and 104 deletions
--- a/xenomorph/xenomorph/struct.rkt
+++ b/xenomorph/xenomorph/struct.rkt
@ -14,39 +14,19 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
 |#


-(define (choose-dict d k)
-  (if (memq k private-keys)
-      (struct-dict-res-_pvt d)
-      (struct-dict-res-_kv d)))
-
-(struct struct-dict-res (_kv _pvt) #:transparent
-  #:methods d:gen:dict
-  [(define (dict-set! d k v) (d:dict-set! (choose-dict d k) k v))
-   (define (dict-ref d k [thunk #f])
-     (define res (d:dict-ref (choose-dict d k) k thunk))
-     (force res))
-   (define (dict-remove! d k) (d:dict-remove! (choose-dict d k) k))
-   ;; public keys only
-   (define (dict-keys d) (d:dict-keys (struct-dict-res-_kv d)))
-   (define (dict-iterate-first d) (and (pair? (dict-keys d)) 0))
-   (define (dict-iterate-next d i) (and (< (add1 i) (length (dict-keys d))) (add1 i)))
-   (define (dict-iterate-key d i) (list-ref (dict-keys d) i))
-   (define (dict-iterate-value d i) (dict-ref d (dict-iterate-key d i)))])
-
-(define (+struct-dict-res [_kv (mhasheq)] [_pvt (mhasheq)])
-  (struct-dict-res _kv _pvt))
-
-(define (_setup port parent len)
-  (define sdr (+struct-dict-res)) ; not mere hash
-  (d:dict-set*! sdr 'parent parent
+(define (xstruct-setup port parent len)
+  (define mheq (make-hasheq))
+  (d:dict-set*! mheq
+                'parent parent
                '_startOffset (pos port)
                '_currentOffset 0
                '_length len)
-  sdr)
+  mheq)

-(define (_parse-fields port sdr fields)
+(define (xstruct-parse-fields port sdr fields-arg)
+  (define fields (if (xstruct? fields-arg) (xstruct-fields fields-arg) fields-arg))
  (unless (assocs? fields)
-    (raise-argument-error '_parse-fields "assocs" fields))
+    (raise-argument-error 'xstruct-parse-fields "assocs" fields))
  (for/fold ([sdr sdr])
            ([(key type) (d:in-dict fields)])
    (define val (if (procedure? type)
@ -63,18 +43,17 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
 (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])
-    ;; _setup and _parse-fields are separate to cooperate with VersionedStruct
-    (define res
+    ;; xstruct-setup and xstruct-parse-fields are separate to cooperate with VersionedStruct
+    (define decoded-hash
      (post-decode xs
-                   (let* ([sdr (_setup port parent len)] ; returns StructDictRes
-                          [sdr (_parse-fields port sdr (xstruct-fields xs))])
-                     sdr)))
-    (unless (d:dict? res)
-      (raise-result-error 'xstruct-decode "dict" res))
-    res))
-
-(define/finalize-size (xstruct-size xs [val #f] #:parent [parent-arg #f]
-                                    #:include-pointers [include-pointers #t])
+                   (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))
@ -90,9 +69,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
  (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)]
-                       #;[val (inner res pre-encode val . args)])
-                  (unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val))
+    (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
--- a/xenomorph/xenomorph/test/pointer-test.rkt
+++ b/xenomorph/xenomorph/test/pointer-test.rkt
@ -53,8 +53,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
 "decode should support decoding pointers lazily"
 (parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
   (define res (xdecode (+xstruct 'ptr (+xpointer #:lazy #t))))
-   (check-true (promise? (dict-ref (struct-dict-res-_kv res) 'ptr)))
-   (check-equal? (dict-ref res 'ptr) 53)))
+   (check-true (promise? (dict-ref res 'ptr)))
+   (check-equal? (force (dict-ref res 'ptr)) 53)))

 (test-case
 "size"
--- a/xenomorph/xenomorph/test/versioned-struct-test.rkt
+++ b/xenomorph/xenomorph/test/versioned-struct-test.rkt
@ -6,6 +6,7 @@
         "../number.rkt"
         "../string.rkt"
         "../pointer.rkt"
+         "../struct.rkt"
         "../versioned-struct.rkt")

 #|
@ -19,7 +20,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
@ -33,7 +34,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")])
@ -46,7 +47,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                     'header (dictify 'age uint8
                                                      'alive uint8)
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'gender uint8)))])
   (parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
     (check-equal? (decode vstruct) (mhasheq 'name "roxyb"
@ -66,7 +67,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
@ -103,7 +104,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (set-post-decode! vstruct (λ (val) (dict-set! val 'processed "true") val))
@ -117,7 +118,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (check-equal? (size vstruct (mhasheq 'name "roxyb"
@ -134,7 +135,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (check-exn exn:fail:contract? (λ () (size vstruct (mhasheq 'name "roxyb" 'age 21 'version 5))))))
@ -146,7 +147,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    'header (dictify 'age uint8
                                                     'alive uint8)
                                    0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
-                                    1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                    1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                               'gender uint8)))])
   (check-equal? (size struct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0)) 9)
   (check-equal? (size struct (mhasheq 'name "roxyb 🤘" 'gender 0 'age 21 'alive 1 'version 1)) 15)))
@ -157,7 +158,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'ptr (+xpointer #:offset-type uint8
                                                                #:type (+xstring uint8)))))])
@ -172,7 +173,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))])
   (check-exn exn:fail:contract? (λ () (size vstruct)))))
@ -183,7 +184,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))]
       [op (open-output-bytes)])
@ -197,7 +198,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))]
       [op (open-output-bytes)])
@ -210,7 +211,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                     'header (dictify 'age uint8
                                                      'alive uint8)
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'gender uint8)))]
       [op (open-output-bytes)])
   (encode vstruct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0) op)
@ -223,7 +224,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify 
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'ptr (+xpointer #:offset-type uint8
                                                                #:type (+xstring uint8)))))]
@ -238,7 +239,7 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe
                                    (dictify
                                     0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
                                                'age uint8)
-                                     1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
+                                     1 (+xstruct 'name (+xstring #:length uint8 #:encoding 'utf8)
                                                'age uint8
                                                'gender uint8)))]
       [op (open-output-bytes)])
--- a/xenomorph/xenomorph/versioned-struct.rkt
+++ b/xenomorph/xenomorph/versioned-struct.rkt
@ -1,4 +1,4 @@
-#lang racket/base
+#lang debug racket/base
 (require "helper.rkt" "struct.rkt"
         racket/dict
         sugar/unstable/dict)
@ -14,7 +14,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee

 (define/post-decode (xversioned-struct-xdecode xvs [port-arg (current-input-port)] #:parent [parent #f] [length 0])
  (define port (->input-port port-arg))
-  (define res (_setup port parent length))
+  (define res (xstruct-setup port parent length))

  (dict-set! res 'version
             (cond
@ -27,67 +27,67 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
               [else (xdecode (xversioned-struct-type xvs) port)]))

  (when (dict-ref (xversioned-struct-versions xvs) 'header #f)
-    (_parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header)))
+    (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 (_parse-fields port res fields)
-           res]))
+    [(xversioned-struct? fields) (xdecode fields port #:parent parent)]
+    [else (xstruct-parse-fields port res fields)
+          res]))
+
+(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/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
-    (if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
-        (size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent)
-        0))
+    (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)))
+             (size type (and val (dict-ref val key)) #:parent parent)))
  (define fields-size
-    (let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version))
-                      (raise-argument-error 'xversioned-struct-size "valid version key" version))])
-      (for/sum ([(key type) (in-dict fields)])
-        (size type (and val (dict-ref val key)) #:parent parent))))
+    (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))

-(define/pre-encode (xversioned-struct-encode xvs val [port-arg (current-output-port)] #:parent [parent-arg #f])
+(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? val)
-    (raise-argument-error 'xversioned-struct-encode "dict" val))
-
-  (define parent (mhash 'pointers null
-                     'startOffset (pos port)
-                     'parent parent-arg
-                     'val val
-                     'pointerSize 0))
-  (dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val #:parent parent #f)))
-
-  (when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
-    (encode (xversioned-struct-type xvs) (dict-ref val 'version #f)))
-
-  (when (dict-ref (xversioned-struct-versions xvs) 'header #f)
-    (for ([(key type) (in-dict (dict-ref (xversioned-struct-versions xvs) 'header))])
-      (encode type (dict-ref val key) #:parent parent)))
-
-  (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f))
-                     (raise-argument-error 'xversioned-struct-encode "valid version key" version)))
-
-  (unless (andmap (λ (key) (member key (dict-keys val))) (dict-keys fields))
-    (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
-
-  (for ([(key type) (in-dict fields)])
-    (encode type (dict-ref val 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))))
+    (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 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))))

 (struct xversioned-struct structish (type versions version-getter version-setter) #:transparent #:mutable
  #:methods gen:xenomorphic
@ -98,7 +98,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee

 (define (+xversioned-struct type [versions (dictify)])
  (unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)])
-            (proc type))
+                  (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)))
    (raise-argument-error '+xversioned-struct "dict of dicts or structish" versions))