From e90a790963a66fb5af66b55ae3cc16146b2c2845 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Wed, 21 Aug 2019 22:18:21 +0100
Subject: [PATCH] First real running tests with the new design, and several
 concomitant fixes and new tests

---
 implementations/racket/preserves/main.rkt | 196 ++++++++++++++--------
 tests/samples.txt                         |  35 ++--
 2 files changed, 145 insertions(+), 86 deletions(-)

diff --git a/implementations/racket/preserves/main.rkt b/implementations/racket/preserves/main.rkt
index 4698acd..b6ecde5 100644
--- a/implementations/racket/preserves/main.rkt
+++ b/implementations/racket/preserves/main.rkt
@@ -4,8 +4,11 @@
 (provide (struct-out stream-of)
          (struct-out record)
          (struct-out annotated)
+         annotate
          strip-annotations
+         strip-annotations-proc
          peel-annotations
+         peel-annotations-proc
          read-preserve
          read-preserve-syntax
          string->preserve
@@ -52,7 +55,14 @@
   (with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
     (apply make-prefab-struct label fields)))
 
-(define (strip-annotations v #:depth [depth +inf.0])
+(define (annotate v . as)
+  (match v
+    [(annotated annotations srcloc item)
+     (annotated (append as annotations) srcloc item)]
+    [item
+     (annotated as #f item)]))
+
+(define (strip-annotations-proc v #:depth [depth +inf.0])
   (let walk* ((v v) (depth depth))
     (define next-depth (- depth 1))
     (define (walk v) (walk* v next-depth))
@@ -72,8 +82,16 @@
              [_ item])]
           [_ v]))))
 
-(define (peel-annotations v)
-  (strip-annotations v #:depth 1))
+(define (peel-annotations-proc v)
+  (strip-annotations-proc v #:depth 1))
+
+(define-match-expander strip-annotations
+  (syntax-rules () [(_ pat extra ...) (app (lambda (v) (strip-annotations-proc v extra ...)) pat)])
+  (syntax-rules () [(_ args ...) (strip-annotations-proc args ...)]))
+
+(define-match-expander peel-annotations
+  (syntax-rules () [(_ pat extra ...) (app (lambda (v) (peel-annotations-proc v extra ...)) pat)])
+  (syntax-rules () [(_ args ...) (peel-annotations-proc args ...)]))
 
 (define current-value->placeholder (make-parameter (lambda (v) #f)))
 (define current-placeholder->value (make-parameter (lambda (v) (void))))
@@ -96,7 +114,7 @@
 (define (decode-syntax bs
                        #:on-short [on-short (default-on-short bs)]
                        [on-fail (default-on-fail bs)])
-  (decode #:read-syntax? #t #:on-short on-short #:on-fail on-fail))
+  (decode bs on-fail #:read-syntax? #t #:on-short on-short))
 
 (define-syntax wire-value
   (syntax-rules ()
@@ -777,7 +795,7 @@
 (module+ test
   (require rackunit)
   (require racket/runtime-path)
-  (require (for-syntax racket syntax/srcloc))
+  (require syntax/srcloc)
 
   (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (0 :: (wire-length)))) (bytes 0))
   (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (3 :: (wire-length)))) (bytes 3))
@@ -811,34 +829,37 @@
                               void)
                       'short))
         (error 'd "~a-byte prefix of ~v does not read as short" i bs)))
-    (decode bs
-            #:on-short (lambda () 'short)
-            void))
+    (decode-syntax bs
+                   #:on-short (lambda () 'short)
+                   void))
 
-  (define-syntax (cross-check stx)
-    (syntax-case stx ()
-      ((_ text v (b ...))
-       #'(let ((val v)) (cross-check text v v (b ...))))
-      ((_ text forward back (b ...))
-       #`(let ((loc #,(source-location->string #'forward)))
-           (check-equal? (string->preserve text) back loc)
-           (check-equal? (d (encode forward)) back loc)
-           (check-equal? (d (encode back)) back loc)
-           (check-equal? (d (expected b ...)) back loc)
-           (check-equal? (encode forward) (expected b ...) loc)
-           ))))
+  (define (d-strip bs)
+    (strip-annotations (d bs)))
 
-  (define-syntax (cross-check/nondeterministic stx)
-    (syntax-case stx ()
-      ((_ text v (b ...))
-       #'(let ((val v)) (cross-check/nondeterministic text v v (b ...))))
-      ((_ text forward back (b ...))
-       #`(let ((loc #,(source-location->string #'forward)))
-           (check-equal? (string->preserve text) back loc)
-           (check-equal? (d (encode forward)) back loc)
-           (check-equal? (d (encode back)) back loc)
-           (check-equal? (d (expected b ...)) back loc)
-           ))))
+  ;; (define-syntax (cross-check stx)
+  ;;   (syntax-case stx ()
+  ;;     ((_ text v (b ...))
+  ;;      #'(let ((val v)) (cross-check text v v (b ...))))
+  ;;     ((_ text forward back (b ...))
+  ;;      #`(let ((loc #,(source-location->string #'forward)))
+  ;;          (check-equal? (string->preserve text) back loc)
+  ;;          (check-equal? (d (encode forward)) back loc)
+  ;;          (check-equal? (d (encode back)) back loc)
+  ;;          (check-equal? (d (expected b ...)) back loc)
+  ;;          (check-equal? (encode forward) (expected b ...) loc)
+  ;;          ))))
+
+  ;; (define-syntax (cross-check/nondeterministic stx)
+  ;;   (syntax-case stx ()
+  ;;     ((_ text v (b ...))
+  ;;      #'(let ((val v)) (cross-check/nondeterministic text v v (b ...))))
+  ;;     ((_ text forward back (b ...))
+  ;;      #`(let ((loc #,(source-location->string #'forward)))
+  ;;          (check-equal? (string->preserve text) back loc)
+  ;;          (check-equal? (d (encode forward)) back loc)
+  ;;          (check-equal? (d (encode back)) back loc)
+  ;;          (check-equal? (d (expected b ...)) back loc)
+  ;;          ))))
 
   (struct discard () #:prefab)
   (struct capture (detail) #:prefab)
@@ -852,7 +873,6 @@
   (struct titled person (title) #:prefab)
 
   (struct asymmetric (forward back))
-  (struct nondeterministic (value))
 
   (define samples-txt-expected
     (hash 'record1 (capture (discard))
@@ -898,7 +918,11 @@
           'string4 "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz"
           'bytes13 #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz"
           'string5 "\U0001D11E"
-          'list2 '("abc" "def")
+          'list2 (asymmetric (stream-of 'sequence
+                                        (sequence->generator
+                                         (list (stream-of 'string (sequence->generator '(#"abc")))
+                                               (stream-of 'string (sequence->generator '(#"def"))))))
+                             '("abc" "def"))
           'record1 (capture (discard))
           'record2 (observe (speak (discard) (capture (discard))))
           'record3 (titled 101 "Blackwell" (date 1821 2 3) "Dr")
@@ -913,35 +937,41 @@
                        "b" #t
                        '(1 2 3) #"c"
                        (hash 'first-name "Elizabeth") (hash 'surname "Blackwell"))
-          'rfc8259-example1 (nondeterministic
-                             (hash "Image"
-                                   (hash "Width" 800
-                                         "Height" 600
-                                         "Title" "View from 15th Floor"
-                                         "Thumbnail" (hash "Url" "http://www.example.com/image/481989943"
-                                                           "Height" 125
-                                                           "Width" 100)
-                                         "Animated" #f
-                                         "IDs" (list 116 943 234 38793))))
-          'rfc8259-example2 (nondeterministic
-                             (list (hash
-                                    "precision" "zip"
-                                    "Latitude"  37.7668
-                                    "Longitude" -122.3959
-                                    "Address"   ""
-                                    "City"      "SAN FRANCISCO"
-                                    "State"     "CA"
-                                    "Zip"       "94107"
-                                    "Country"   "US")
-                                   (hash
-                                    "precision" "zip"
-                                    "Latitude"  37.371991
-                                    "Longitude" -122.026020
-                                    "Address"   ""
-                                    "City"      "SUNNYVALE"
-                                    "State"     "CA"
-                                    "Zip"       "94085"
-                                    "Country"   "US")))
+          'rfc8259-example1 (hash "Image"
+                                  (hash "Width" 800
+                                        "Height" 600
+                                        "Title" "View from 15th Floor"
+                                        "Thumbnail" (hash "Url" "http://www.example.com/image/481989943"
+                                                          "Height" 125
+                                                          "Width" 100)
+                                        "Animated" #f
+                                        "IDs" (list 116 943 234 38793)))
+          'rfc8259-example2 (list (hash
+                                   "precision" "zip"
+                                   "Latitude"  37.7668
+                                   "Longitude" -122.3959
+                                   "Address"   ""
+                                   "City"      "SAN FRANCISCO"
+                                   "State"     "CA"
+                                   "Zip"       "94107"
+                                   "Country"   "US")
+                                  (hash
+                                   "precision" "zip"
+                                   "Latitude"  37.371991
+                                   "Longitude" -122.026020
+                                   "Address"   ""
+                                   "City"      "SUNNYVALE"
+                                   "State"     "CA"
+                                   "Zip"       "94085"
+                                   "Country"   "US"))
+          'annotation1 (asymmetric (annotate 9 "abc") 9)
+          'annotation2 (asymmetric (annotate (list '() (annotate '() "x")) "abc" "def") '(() ()))
+          'annotation3 (asymmetric (annotate 5 (annotate 2 1) (annotate 4 3)) 5)
+          'annotation4 (asymmetric (hash (annotate 'a 'ak) (annotate 1 'av)
+                                         (annotate 'b 'bk) (annotate 2 'bv))
+                                   (hash 'a 1 'b 2))
+          'annotation5 (asymmetric (annotate `#s(R ,(annotate 'f 'af)) 'ar) `#s(R f))
+          'annotation6 (asymmetric (record (annotate 'R 'ar) (list (annotate 'f 'af))) `#s(R f))
           ))
 
   (define-runtime-path tests-path "../../../tests")
@@ -951,12 +981,38 @@
                     (port-count-lines! p)
                     (read-preserve-syntax p #:source path)))))
     (local-require racket/pretty)
-    (for [((t-name t) (in-hash (annotated-item tests)))]
-      (newline)
-      (newline)
-      (write-preserve t #:indent #f)
-      (newline)
-      (newline)
-      (pretty-print (list (peel-annotations t-name)
-                          (peel-annotations t)))))
+    (define placeholder->value-map
+      (or (for/or [(a* (annotated-annotations tests))]
+            (match (strip-annotations a*)
+              [`#s(ExpectedPlaceholderMapping ,p->v) p->v]
+              [_ #f]))
+          (hash)))
+    (define value->placeholder-map
+      (for/hash [((k v) (in-hash placeholder->value-map))]
+        (values v k)))
+    (parameterize
+        ((current-value->placeholder (lambda (v) (hash-ref value->placeholder-map v #f)))
+         (current-placeholder->value (lambda (p) (hash-ref placeholder->value-map p void))))
+      (for [((t-name* t*) (in-hash (annotated-item tests)))]
+        (define t-name (strip-annotations t-name*))
+        (define loc (format "Test case '~a' (~a)" t-name (source-location->string (annotated-srcloc t*))))
+        (displayln loc)
+        (match t*
+          [(peel-annotations `#s(Test ,(strip-annotations binary-form) ,annotated-text-form))
+           (define text-form (strip-annotations annotated-text-form))
+           (define-values (forward back)
+             (match (hash-ref samples-txt-expected t-name text-form)
+               [(asymmetric f b) (values f b)]
+               [v (values v v)]))
+           (check-equal? text-form back loc)
+           (check-equal? (d-strip (encode text-form)) back loc)
+           (check-equal? (d-strip (encode forward)) back loc)
+           (check-equal? (d-strip binary-form) back loc)
+           (check-equal? (d binary-form) annotated-text-form loc)
+           (check-equal? (encode forward) binary-form loc)
+           (check-equal? (encode annotated-text-form) binary-form loc)]
+          [_
+           (write-preserve t* #:indent #f)
+           (newline)])))
+    )
   )
diff --git a/tests/samples.txt b/tests/samples.txt
index 01f18af..dcb6029 100644
--- a/tests/samples.txt
+++ b/tests/samples.txt
@@ -1,15 +1,18 @@
 @<EmacsMode "-*- preserves -*-">
-@"Expects placeholder mapping of:"
-@"{ 0: discard, 1: capture, 2: observe }"
+@<ExpectedPlaceholderMapping {
+  0: discard
+  1: capture
+  2: observe
+}>
 {
   annotation1: <Test #hex{055361626339} @"abc" 9>
   annotation2: <Test #hex{05536162630553646566929005517890} @"abc" @"def" [[] @"x" []]>
   annotation3: <Test #hex{050531320505333435} @@1 2 @@3 4 5>
-  annotation4: <Test #hex{b4 05 72616b 7161 05 726176 31 05 72626b 7162 05 726276 32}
-                     {@ak a: @av 1 @bk b: @bv 2}>
+  annotation4: <NondeterministicTest #hex{b4 05 72616b 7161 05 726176 31 05 72626b 7162 05 726276 32}
+                                     {@ak a: @av 1 @bk b: @bv 2}>
   annotation5: <Test #hex{05726172827152057261667166} @ar <R @af f>>
   annotation6: <Test #hex{82057261727152057261667166} <@ar R @af f>>
-  bytes1: <Test #hex{26626865626c6c616f04} #"hello">
+  bytes1: <StreamingTest #hex{26626865626c6c616f04} #"hello">
   bytes2: <Test #hex{6568656c6c6f} #"hello">
   bytes3: <Test #hex{63414243} #"ABC">
   bytes4: <Test #hex{63414243} #hex{414243}>
@@ -24,7 +27,7 @@
   bytes13: <Test #hex{6f 11 61 62 63 6c 34 f0 5c 2f 22 08 0c 0a 0d 09 78 79 7a} #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz">
 
   dict0: <Test #hex{b0} {}>
-  dict1: <Test #hex{b8 7161 31 5162 01 93313233 6163 b2 7a66697273742d6e616d65 59456c697a6162657468 b2 777375726e616d65 59426c61636b77656c6c} { a: 1 "b": #true [1 2 3]: c { first-name: "Elizabeth" }: { surname: "Blackwell" } }>
+  dict1: <NondeterministicTest #hex{b8 7161 31 5162 01 93313233 6163 b2 7a66697273742d6e616d65 59456c697a6162657468 b2 777375726e616d65 59426c61636b77656c6c} { a: 1 "b": #true [1 2 3]: #"c" { first-name: "Elizabeth" }: { surname: "Blackwell" } }>
   dict2: @"Missing close brace" <ParseShort "{ a: b, c: d ">
   dict2a: @"Missing close brace" <ParseShort "{">
   dict3: @"Duplicate key" <ParseError "{ a: 1, a: 2 }">
@@ -56,13 +59,13 @@
   int65536: <Test #hex{43010000} 65536>
   int131072: <Test #hex{43020000} 131072>
   list0: <Test #hex{90} []>
-  list1: <Test #hex{293132333404} [1 2 3 4]>
-  list2: <Test #hex{2925636162630425636465660404} ["abc" "def"]>
-  list3: <Test #hex{2992516131925162329251633304} [["a" 1] ["b" 2] ["c" 3]]>
+  list1: <StreamingTest #hex{293132333404} [1 2 3 4]>
+  list2: <StreamingTest #hex{2925636162630425636465660404} ["abc" "def"]>
+  list3: <StreamingTest #hex{2992516131925162329251633304} [["a" 1] ["b" 2] ["c" 3]]>
   list4: <Test #hex{9431323334} [1 2 3 4]>
   list4a: <Test #hex{9431323334} [1, 2, 3, 4]>
   list5: <Test #hex{943e3f3031} [-2 -1 0 1]>
-  list6: <Test #hex{97 5568656c6c6f 757468657265 65776f726c64 90 a0 01 00} ["hello" #"there" world [] #set{} #true #false]>
+  list6: <Test #hex{97 5568656c6c6f 757468657265 65776f726c64 90 a0 01 00} ["hello" there #"world" [] #set{} #true #false]>
   list7: <Test #hex{93 73616263 732e2e2e 73646566} [abc ... def]>
   list8: @"Missing close bracket" <ParseShort "[">
   placeholder0: <Test #hex{10} discard>
@@ -79,8 +82,8 @@
   record9: @"Missing record label" <ParseError "<>">
   record10: @"Missing close-angle-bracket" <ParseShort "<">
   set0: <Test #hex{a0} #set{}>
-  set1: <Test #hex{a3313233} {1 2 3}>
-  set1a: <Test #hex{a3313233} #set{1 2 3}>
+  set1: <NondeterministicTest #hex{a3313233} {1 2 3}>
+  set1a: <NondeterministicTest #hex{a3313233} #set{1 2 3}>
   set2: @"Missing close brace" <ParseShort "#set{ 1 2 3 ">
   set2a: @"Missing close brace" <ParseShort "#set{">
   stream1: @"Chunk must be bytes" <DecodeError #hex{25516104}>
@@ -92,14 +95,14 @@
   stream7: @"Missing end byte" <DecodeShort #hex{290000}>
   stream8: @"Missing element" <DecodeShort #hex{930000}>
   string0: <Test #hex{50} "">
-  string0a: <Test #hex{2504} "">
-  string1: <Test #hex{25626865626c6c616f04} "hello">
-  string2: <Test #hex{25626865636c6c6f04} "hello">
+  string0a: <StreamingTest #hex{2504} "">
+  string1: <StreamingTest #hex{25626865626c6c616f04} "hello">
+  string2: <StreamingTest #hex{25626865636c6c6f04} "hello">
   string3: <Test #hex{5568656c6c6f} "hello">
   string4: <Test #hex{5f 14 616263e6b0b4e6b0b45c2f22080c0a0d0978797a} "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz">
   string5: <Test #hex{54f09d849e} "\uD834\uDD1E">
   symbol0: <Test #hex{70} ||>
-  symbol1: <Test #hex{27626865626c6c616f04} hello>
+  symbol1: <StreamingTest #hex{27626865626c6c616f04} hello>
   symbol2: <Test #hex{7568656c6c6f} hello>
   value1: <Test #"\x66corymb" #value#"fcorymb">
   value2: <Test #"\x01" #value#"\x01">