From 0f2a613bb4694b44b797f06dae9a8ecda2185bec Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Tue, 11 Dec 2018 17:44:07 -0800
Subject: [PATCH] main pointer tests pass

---
 xenomorph/xenomorph/redo/pointer.rkt          | 110 +++++++++
 .../xenomorph/redo/test/pointer-test.rkt      | 210 ++++++++++++++++++
 2 files changed, 320 insertions(+)
 create mode 100644 xenomorph/xenomorph/redo/pointer.rkt
 create mode 100644 xenomorph/xenomorph/redo/test/pointer-test.rkt

diff --git a/xenomorph/xenomorph/redo/pointer.rkt b/xenomorph/xenomorph/redo/pointer.rkt
new file mode 100644
index 00000000..d2e07762
--- /dev/null
+++ b/xenomorph/xenomorph/redo/pointer.rkt
@@ -0,0 +1,110 @@
+#lang debug racket/base
+(require "helper.rkt"
+         racket/dict
+         sugar/unstable/dict)
+(provide (all-defined-out))
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
+|#
+
+(define (find-top-ctx ctx)
+  (cond
+    [(dict-ref ctx 'parent #f) => find-top-ctx]
+    [else ctx]))
+
+(define (xpointer-decode xp [port-arg (current-input-port)] #:parent [ctx #f])
+  (define port (->input-port port-arg))
+  (define offset (decode (xpointer-offset-type xp) port #:parent ctx))
+  (cond
+    [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers
+    [else
+     (define relative (+ (case (pointer-style xp)
+                           [(local) (dict-ref ctx '_startOffset)]
+                           [(immediate) (- (pos port) (size (xpointer-offset-type xp)))]
+                           [(parent) (dict-ref (dict-ref ctx 'parent) '_startOffset)]
+                           [(global) (or (dict-ref (find-top-ctx ctx) '_startOffset) 0)]
+                           [else (error 'unknown-pointer-style)])
+                         ((relative-getter-or-0 xp) ctx)))
+     (define ptr (+ offset relative))
+     (cond
+       [(xpointer-type xp)
+        (define val (void))
+        (define (decode-value)
+          (cond
+            [(not (void? val)) val]
+            [else
+             (define orig-pos (pos port))
+             (pos port ptr)
+             (set! val (decode (xpointer-type xp) port #:parent ctx))
+             (pos port orig-pos)
+             val]))
+        (if (lazy xp)
+            (lazy-thunk decode-value)
+            (decode-value))]
+       [else ptr])]))
+
+(define (resolve-void-pointer type val)
+  (cond
+    [type (values type val)]
+    [(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))]
+    [else (raise-argument-error 'Pointer:size "VoidPointer" val)]))
+
+(define (xpointer-encode xp val [port-arg (current-output-port)] #:parent [ctx #f])
+  (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
+  (unless ctx ; todo: furnish default pointer context? adapt from Struct?
+    (raise-argument-error 'xpointer-encode "valid pointer context" ctx))
+  (if (not val)
+      (encode (xpointer-offset-type xp) (null-value xp) port)
+      (let* ([parent ctx]
+             [ctx (case (pointer-style xp)
+                    [(local immediate) ctx]
+                    [(parent) (dict-ref ctx 'parent)]
+                    [(global) (find-top-ctx ctx)]
+                    [else (error 'unknown-pointer-style)])]
+             [relative (+ (case (pointer-style xp)
+                            [(local parent) (dict-ref ctx 'startOffset)]
+                            [(immediate) (+ (pos port) (size (xpointer-offset-type xp) val parent))]
+                            [(global) 0])
+                          ((relative-getter-or-0 xp) (dict-ref parent 'val #f)))])
+        (encode (xpointer-offset-type xp) (- (dict-ref ctx 'pointerOffset) relative) port)
+        (let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)])
+          (dict-set! ctx 'pointers (append (dict-ref ctx 'pointers)
+                                           (list (mhasheq 'type type
+                                                          'val val
+                                                          'parent parent))))
+          (dict-set! ctx 'pointerOffset (+ (dict-ref ctx 'pointerOffset) (size type val parent))))))
+  (unless port-arg (get-output-bytes port)))
+
+(define (xpointer-size xp [val #f] [ctx #f])
+  (let*-values ([(parent) ctx]
+                [(ctx) (case (pointer-style xp)
+                         [(local immediate) ctx]
+                         [(parent) (dict-ref ctx 'parent)]
+                         [(global) (find-top-ctx ctx)]
+                         [else (error 'unknown-pointer-style)])]
+                [(type val) (resolve-void-pointer (xpointer-type xp) val)])
+    (when (and val ctx)
+      (dict-set! ctx 'pointerSize (and (dict-ref ctx 'pointerSize)
+                                       (+ (dict-ref ctx 'pointerSize) (size type val parent)))))
+    (size (xpointer-offset-type xp))))
+
+(struct xpointer (offset-type type options) #:transparent
+  #:methods gen:xenomorphic
+  [(define decode xpointer-decode)
+   (define encode xpointer-encode)
+   (define size xpointer-size)])
+
+(define (+xpointer offset-type type-in [options (mhasheq)])
+  (xpointer offset-type (and (not (eq? type-in 'void)) type-in) options))
+
+(define (pointer-style xp) (or (dict-ref (xpointer-options xp) 'type #f) 'local))
+(define (allow-null xp) (or (dict-ref (xpointer-options xp) 'allowNull #f) #t)) 
+(define (null-value xp) (or (dict-ref (xpointer-options xp) 'nullValue #f) 0))
+(define (lazy xp) (dict-ref (xpointer-options xp) 'lazy #f))
+(define (relative-getter-or-0 xp) (or (dict-ref (xpointer-options xp) 'relativeTo #f) (λ (ctx) 0))) ; changed this to a simple lambda
+
+;; A pointer whose type is determined at decode time
+(struct xvoid-pointer (type value) #:transparent)
+(define +xvoid-pointer xvoid-pointer)
\ No newline at end of file
diff --git a/xenomorph/xenomorph/redo/test/pointer-test.rkt b/xenomorph/xenomorph/redo/test/pointer-test.rkt
new file mode 100644
index 00000000..79312f3b
--- /dev/null
+++ b/xenomorph/xenomorph/redo/test/pointer-test.rkt
@@ -0,0 +1,210 @@
+#lang debug racket/base
+(require rackunit
+         racket/dict
+         "../helper.rkt"
+         "../pointer.rkt"
+         "../number.rkt"
+         "../struct.rkt"
+         sugar/unstable/dict)
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
+|#
+
+(test-case
+ "decode should handle null pointers"
+ (parameterize ([current-input-port (open-input-bytes (bytes 0))])
+   (check-false (decode (+xpointer uint8 uint8) #:parent (mhash '_startOffset 50)))))
+
+(test-case
+ "decode should use local offsets from start of parent by default"
+ (parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
+   (check-equal? (decode (+xpointer uint8 uint8) #:parent (mhash '_startOffset 0)) 53)))
+
+(test-case
+ "decode 'should support immediate offsets"
+ (parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
+   (check-equal? (decode (+xpointer uint8 uint8 (mhash 'type 'immediate))) 53)))
+
+(test-case
+ "decode 'should support offsets relative to the parent"
+ (parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))])
+   (pos (current-input-port) 2)
+   (check-equal? (decode (+xpointer uint8 uint8 (mhash 'type 'parent))
+                         #:parent (mhash 'parent (mhash '_startOffset 2))) 53)))
+
+(test-case
+ "decode should support global offsets"
+ (parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))])
+   (pos (current-input-port) 2)
+   (check-equal? (decode (+xpointer uint8 uint8 (mhash 'type 'global))
+                         #:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
+                 53)))
+
+(test-case
+ "decode should support offsets relative to a property on the parent"
+ (parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))])
+   (check-equal? (decode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (dict-ref (dict-ref ctx 'parent) 'ptr))))
+                         #:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
+                 53)))
+
+(test-case
+ "decode should support returning pointer if there is no decode type"
+ (parameterize ([current-input-port (open-input-bytes (bytes 4))])
+   (check-equal? (decode (+xpointer uint8 'void)
+                         #:parent (mhash '_startOffset 0)) 4)))
+
+(test-case
+ "decode should support decoding pointers lazily"
+ (parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
+   (define res (decode (+xstruct (dictify 'ptr (+xpointer uint8 uint8 (mhasheq 'lazy #t))))))
+   (check-true (lazy-thunk? (dict-ref (struct-dict-res-_kv res) 'ptr)))
+   (check-equal? (dict-ref res 'ptr) 53)))
+
+(test-case
+ "size"
+ (let ([ctx (mhash 'pointerSize 0)])
+   (check-equal? (size (+xpointer uint8 uint8) 10 ctx) 1)
+   (check-equal? (dict-ref ctx 'pointerSize) 1)))
+
+(test-case
+ "size should add to immediate pointerSize"
+ (let ([ctx (mhash 'pointerSize 0)])
+   (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 ctx) 1)
+   (check-equal? (dict-ref ctx 'pointerSize) 1)))
+
+(test-case
+ "size should add to parent pointerSize"
+ (let ([ctx (mhash 'parent (mhash 'pointerSize 0))])
+   (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 ctx) 1)
+   (check-equal? (dict-ref (dict-ref ctx 'parent) 'pointerSize) 1)))
+
+(test-case
+ "size should add to global pointerSize"
+ (let ([ctx (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
+   (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'global)) 10 ctx) 1)
+   (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref ctx 'parent) 'parent) 'parent) 'pointerSize) 1)))
+
+(test-case
+ "size should handle void pointers"
+ (let ([ctx (mhash 'pointerSize 0)])
+   (check-equal? (size (+xpointer uint8 'void) (+xvoid-pointer uint8 50) ctx) 1)
+   (check-equal? (dict-ref ctx 'pointerSize) 1)))
+
+(test-case
+ "size should throw if no type and not a void pointer"
+ (let ([ctx (mhash 'pointerSize 0)])
+   (check-exn exn:fail:contract? (λ () (size (+xpointer uint8 'void) 30 ctx)))))
+
+(test-case
+ "size should return a fixed size without a value"
+ (check-equal? (size (+xpointer uint8 uint8)) 1))
+
+(test-case
+ "encode should handle null pointers"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'pointerSize 0
+                      'startOffset 0
+                      'pointerOffset 0
+                      'pointers null))
+   (encode (+xpointer uint8 uint8) #f #:parent ctx)
+   (check-equal? (dict-ref ctx 'pointerSize) 0)
+   (check-equal? (dump (current-output-port)) (bytes 0))))
+
+(test-case
+ "encode should handle local offsets"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'pointerSize 0
+                      'startOffset 0
+                      'pointerOffset 1
+                      'pointers null))
+   (encode (+xpointer uint8 uint8) 10 #:parent ctx)
+   (check-equal? (dict-ref ctx 'pointerOffset) 2)
+   (check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8
+                                                         'val 10
+                                                         'parent ctx)))
+   (check-equal? (dump (current-output-port)) (bytes 1))))
+
+(test-case
+ "encode should handle immediate offsets"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'pointerSize 0
+                      'startOffset 0
+                      'pointerOffset 1
+                      'pointers null))
+   (encode (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent ctx)
+   (check-equal? (dict-ref ctx 'pointerOffset) 2)
+   (check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8
+                                                         'val 10
+                                                         'parent ctx)))
+   (check-equal? (dump (current-output-port)) (bytes 0))))
+
+(test-case
+ "encode should handle offsets relative to parent"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'parent (mhash 'pointerSize 0
+                                     'startOffset 3
+                                     'pointerOffset 5
+                                     'pointers null)))
+   (encode (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent ctx)
+   (check-equal? (dict-ref (dict-ref ctx 'parent) 'pointerOffset) 6)
+   (check-equal? (dict-ref (dict-ref ctx 'parent) 'pointers) (list (mhasheq 'type uint8
+                                                                            'val 10
+                                                                            'parent ctx)))
+   (check-equal? (dump (current-output-port)) (bytes 2))))
+
+(test-case
+ "encode should handle global offsets"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'parent
+                      (mhash 'parent
+                             (mhash 'parent (mhash 'pointerSize 0
+                                                   'startOffset 3
+                                                   'pointerOffset 5
+                                                   'pointers null)))))
+   (encode (+xpointer uint8 uint8 (mhash 'type 'global)) 10 #:parent ctx)
+   (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref ctx 'parent) 'parent) 'parent) 'pointerOffset) 6)
+   (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref ctx 'parent) 'parent) 'parent) 'pointers)
+                 (list (mhasheq 'type uint8
+                                'val 10
+                                'parent ctx)))
+   (check-equal? (dump (current-output-port)) (bytes 5))))
+
+(test-case
+ "encode should support offsets relative to a property on the parent"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'pointerSize 0
+                      'startOffset 0
+                      'pointerOffset 10
+                      'pointers null
+                      'val (mhash 'ptr 4)))
+   (encode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (dict-ref ctx 'ptr)))) 10 #:parent ctx)
+   (check-equal? (dict-ref ctx 'pointerOffset) 11)
+   (check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8
+                                                         'val 10
+                                                         'parent ctx)))
+   (check-equal? (dump (current-output-port)) (bytes 6))))
+
+(test-case
+ "encode should support void pointers"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'pointerSize 0
+                      'startOffset 0
+                      'pointerOffset 1
+                      'pointers null))
+   (encode (+xpointer uint8 'void) (+xvoid-pointer uint8 55) #:parent  ctx)
+   (check-equal? (dict-ref ctx 'pointerOffset) 2)
+   (check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8
+                                                         'val 55
+                                                         'parent ctx)))
+   (check-equal? (dump (current-output-port)) (bytes 1))))
+
+(test-case
+ "encode should throw if not a void pointer instance"
+ (parameterize ([current-output-port (open-output-bytes)])
+   (define ctx (mhash 'pointerSize 0
+                      'startOffset 0
+                      'pointerOffset 1
+                      'pointers null))
+   (check-exn exn:fail:contract? (λ () (encode (+xpointer uint8 'void) 44 #:parent ctx)))))