From 143cf1e138f1c8f3f2d49025a934c76e4cb90ad0 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Tue, 11 Dec 2018 14:38:57 -0800
Subject: [PATCH] struct tests pass

---
 xenomorph/xenomorph/redo/base.rkt             |  21 ++-
 xenomorph/xenomorph/redo/struct.rkt           | 130 ++++++++++++++++++
 xenomorph/xenomorph/redo/test/struct-test.rkt |  90 ++++++++++++
 3 files changed, 230 insertions(+), 11 deletions(-)
 create mode 100644 xenomorph/xenomorph/redo/struct.rkt
 create mode 100644 xenomorph/xenomorph/redo/test/struct-test.rkt

diff --git a/xenomorph/xenomorph/redo/base.rkt b/xenomorph/xenomorph/redo/base.rkt
index 2e57f67a..239693f6 100644
--- a/xenomorph/xenomorph/redo/base.rkt
+++ b/xenomorph/xenomorph/redo/base.rkt
@@ -20,16 +20,13 @@
   (bitwise-and sint (arithmetic-shift 1 bits)))
 
 (define (dump x)
-  (define (dump-dict x)
-    (for/list ([(k v) (in-dict x)])
-      (cons (dump k) (dump v))))
-  (let loop ([x x])
-    (cond
-      [(input-port? x) (port->bytes x)]
-      [(output-port? x) (get-output-bytes x)]
-      [(dict? x) (dump-dict x)]
-      [(list? x) (map loop x)]
-      [else x])))
+  (cond
+    [(input-port? x) (port->bytes x)]
+    [(output-port? x) (get-output-bytes x)]
+    [(dict? x) (for/list ([(k v) (in-dict x)])
+                         (cons (dump k) (dump v)))]
+    [(list? x) (map dump x)]
+    [else x]))
 
 (define (pos p [new-pos #f])
   (when new-pos
@@ -39,4 +36,6 @@
 (define-generics xenomorphic
   (encode xenomorphic val [port] #:parent [parent])
   (decode xenomorphic [port] #:parent [parent])
-  (size xenomorphic [item] [parent]))
\ No newline at end of file
+  (size xenomorphic [item] [parent]))
+
+(struct lazy-thunk (proc) #:transparent)
\ No newline at end of file
diff --git a/xenomorph/xenomorph/redo/struct.rkt b/xenomorph/xenomorph/redo/struct.rkt
new file mode 100644
index 00000000..0d83922d
--- /dev/null
+++ b/xenomorph/xenomorph/redo/struct.rkt
@@ -0,0 +1,130 @@
+#lang debug racket/base
+(require (prefix-in d: racket/dict) racket/list "base.rkt" "util.rkt" "number.rkt" sugar/unstable/dict)
+(provide (all-defined-out))
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
+|#
+
+(define private-keys '(parent _startOffset _currentOffset _length))
+
+(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))
+     (if (lazy-thunk? res) ((lazy-thunk-proc res)) 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
+                '_startOffset (pos port)
+                '_currentOffset 0
+                '_length len)
+  sdr)
+
+(define (_parse-fields port sdr fields)
+  (unless (assocs? fields)
+    (raise-argument-error '_parse-fields "assocs" fields))
+  (for/fold ([sdr sdr])
+            ([(key type) (d:in-dict fields)])
+    (define val (if (procedure? type)
+                    (type sdr)
+                    (decode type port #:parent sdr)))
+    (unless (void? val)
+      (d:dict-set! sdr key val))
+    (d:dict-set! sdr '_currentOffset (- (pos port) (d:dict-ref sdr '_startOffset)))
+    sdr))
+
+(define (xstruct-decode xs [port-arg (current-input-port)] #:parent [parent #f] [len 0])
+  (define port (->input-port port-arg))
+  ;; _setup and _parse-fields are separate to cooperate with VersionedStruct
+  (define res
+    (let* ([sdr (_setup port parent len)] ; returns StructDictRes
+           [sdr (_parse-fields port sdr (xstruct-fields xs))])
+      sdr))
+  (let* ([res ((xstruct-post-decode xs) res port parent)]
+         #;[res (inner res post-decode res . args)])
+    (unless (d:dict? res) (raise-result-error 'xstruct-decode "dict" res))
+    res))
+
+(define (xstruct-size xs [val #f] [parent #f] [include-pointers #t])
+  (define ctx (mhasheq 'parent parent
+                       'val val
+                       'pointerSize 0))
+  (+ (for/sum ([(key type) (d:in-dict (xstruct-fields xs))]
+               #:when (xenomorphic? type))
+              (size type (and val (d:dict-ref val key)) ctx))
+     (if include-pointers (d:dict-ref ctx 'pointerSize) 0)))
+
+(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent #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)))
+  ;; check keys first, since `size` also relies on keys being valid
+  (define val (let* ([val ((xstruct-pre-encode xs) val-arg port)]
+                     #;[val (inner res pre-encode val . args)])
+                (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 Struct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val)))
+
+  (define ctx (mhash 'pointers empty
+                     'startOffset (pos port)
+                     'parent parent
+                     'val val
+                     'pointerSize 0))
+  
+  (d:dict-set! ctx 'pointerOffset (+ (pos port) (if (xenomorphic? val) (size val #f ctx) 0)))
+
+  (for ([(key type) (d:in-dict (xstruct-fields xs))])
+       (encode type (d:dict-ref val key) port #:parent ctx))
+  (for ([ptr (in-list (d:dict-ref ctx 'pointers))])
+       (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) port #:parent (d:dict-ref ptr 'parent)))
+  (unless port-arg (get-output-bytes port)))
+
+(struct xstruct (fields post-decode pre-encode) #:transparent #:mutable
+  #:methods gen:xenomorphic
+  [(define decode xstruct-decode)
+   (define encode xstruct-encode)
+   (define size xstruct-size)])
+
+(define (+xstruct [fields null] [post-decode (λ (val port ctx) val)] [pre-encode (λ (val port) val)])
+  (unless (d:dict? fields)
+    (raise-argument-error '+xstruct "dict" fields))
+  (xstruct fields post-decode pre-encode))
+
+(module+ test
+  (require rackunit "number.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)))
\ No newline at end of file
diff --git a/xenomorph/xenomorph/redo/test/struct-test.rkt b/xenomorph/xenomorph/redo/test/struct-test.rkt
new file mode 100644
index 00000000..a0e814e0
--- /dev/null
+++ b/xenomorph/xenomorph/redo/test/struct-test.rkt
@@ -0,0 +1,90 @@
+#lang debug racket/base
+(require rackunit racket/dict
+         "../base.rkt"
+         "../struct.rkt"
+         "../string.rkt"
+         "../number.rkt"
+         sugar/unstable/dict)
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
+|#
+
+(test-case
+ "decode into an object"
+ (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
+   (check-equal?
+    (dump (decode (+xstruct (dictify 'name (+xstring uint8)
+                                     'age uint8))))
+    '((name . "roxyb") (age . 21)))))
+
+(test-case
+ "decode with process hook"
+ (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
+   (define struct (+xstruct (dictify 'name (+xstring uint8)
+                                     'age uint8)))
+   (set-xstruct-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o))
+   (check-equal? (dump (decode struct))
+                 '((name . "roxyb") (canDrink . #t) (age . 32)))))
+
+(test-case
+ "decode supports function keys"
+ (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
+   (define struct (+xstruct (dictify 'name (+xstring uint8)
+                                     'age uint8
+                                     'canDrink (λ (o) (>= (dict-ref o 'age) 21)))))
+   (check-equal? (dump (decode struct))
+                 '((name . "roxyb") (canDrink . #t) (age . 32)))))
+
+(test-case
+ "compute the correct size"
+ (check-equal? (size (+xstruct (dictify
+                                'name (+xstring uint8)
+                                'age uint8))
+                     (hasheq 'name "roxyb" 'age 32)) 7))
+
+;; todo: reinstate pointer test
+#;(test-case
+   "compute the correct size with pointers"
+   (check-equal? (size (+xstruct (dictify
+                                  'name (+xstring uint8)
+                                  'age uint8
+                                  'ptr (+Pointer uint8 (+xstring uint8))))
+                       (mhash 'name "roxyb" 'age 21 'ptr "hello")) 14))
+
+(test-case
+ "get the correct size when no value is given"
+ (check-equal? (size (+xstruct (dictify 'name (+xstring 4) 'age uint8))) 5))
+
+(test-case
+ "throw when getting non-fixed length size and no value is given"
+ (check-exn exn:fail:contract? (λ () (size (+xstruct (dictify 'name (+xstring uint8)
+                                                              'age uint8))))))
+
+(test-case
+ "encode objects to buffers"
+ (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
+   (check-equal? (dump (decode (+xstruct (dictify 'name (+xstring uint8)
+                                                  'age uint8))))
+                 '((name . "roxyb") (age . 21)))))
+
+(test-case
+ "support pre-encode hook"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define struct (+xstruct (dictify 'nameLength uint8
+                                     'name (+xstring 'nameLength)
+                                     'age uint8)))
+   (set-xstruct-pre-encode! struct (λ (val port) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))
+   (encode struct (mhasheq 'name "roxyb" 'age 21))
+   (check-equal? (dump (current-output-port)) #"\x05roxyb\x15")))
+
+;; todo: reinstate pointer test
+#;(test-case
+   "encode pointer data after structure"
+   (parameterize ([current-output-port (open-output-bytes)])
+     (define struct (+xstruct (dictify 'name (+xstring uint8)
+                                       'age uint8
+                                       'ptr (+Pointer uint8 (+xstring uint8)))))
+     (encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
+     (check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello")))
\ No newline at end of file