# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1597288198 14400
# Node ID d093b64cf92c17041ddbfa6af27e66f6ee3bf23f
# Parent  a450f8f200cd73194c1c9a12f458c7426e31b784
Add simple fuzz tests against Yason

diff -r a450f8f200cd -r d093b64cf92c .TODO.done
--- a/.TODO.done	Wed Aug 12 00:38:21 2020 -0400
+++ b/.TODO.done	Wed Aug 12 23:09:58 2020 -0400
@@ -1,2 +1,3 @@
 Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
+Add fuzz tests against other implementations | id:cd53968480f72453ee820d65a180efe6da0fef71
 Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
diff -r a450f8f200cd -r d093b64cf92c TODO
--- a/TODO	Wed Aug 12 00:38:21 2020 -0400
+++ b/TODO	Wed Aug 12 23:09:58 2020 -0400
@@ -3,5 +3,4 @@
 Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
 Add opaque-json type | id:a1a380eb9782d088693dfb75402b99c2b30cf039
 Add dynamic extent wrapper definition | id:a937f1179ff1fac77ca501ce7c70449464411f58
-Add fuzz tests against other implementations | id:cd53968480f72453ee820d65a180efe6da0fef71
 Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
diff -r a450f8f200cd -r d093b64cf92c jarl.asd
--- a/jarl.asd	Wed Aug 12 00:38:21 2020 -0400
+++ b/jarl.asd	Wed Aug 12 23:09:58 2020 -0400
@@ -22,7 +22,7 @@
   :author "Steve Losh <steve@stevelosh.com>"
   :license "MIT"
 
-  :depends-on (:jarl :1am :alexandria)
+  :depends-on (:jarl :1am :alexandria :yason :chancery)
 
   :serial t
   :components ((:module "test"
diff -r a450f8f200cd -r d093b64cf92c test/tests.lisp
--- a/test/tests.lisp	Wed Aug 12 00:38:21 2020 -0400
+++ b/test/tests.lisp	Wed Aug 12 23:09:58 2020 -0400
@@ -13,23 +13,29 @@
   ;; This makes it less miserable to write JSON strings in Lisp.
   (substitute #\" #\' string))
 
+(defun obj= (a b &key (test #'equal))
+  (and (= (hash-table-count a)
+          (hash-table-count b))
+       (not (maphash (lambda (ak av)
+                       (multiple-value-bind (bv found) (gethash ak b)
+                         (when (or (not found) (not (funcall test av bv)))
+                           (return-from obj= nil))))
+                     a))))
+
+(defun vec= (a b &key (test #'equal))
+  (and (= (length a) (length b))
+       (every test a b)))
+
 (defgeneric same (a b))
 
 (defmethod same (a b)
   (equal a b))
 
 (defmethod same ((a vector) (b vector))
-  (and (= (length a) (length b))
-       (every #'same a b)))
+  (vec= a b :test #'same))
 
 (defmethod same ((a hash-table) (b hash-table))
-  (and (= (hash-table-count a)
-          (hash-table-count b))
-       (not (maphash (lambda (ak av)
-                       (multiple-value-bind (bv found) (gethash ak b)
-                         (when (or (not found) (not (same av bv)))
-                           (return-from same nil))))
-                     a))))
+  (obj= a b :test #'same))
 
 (defun h (&rest keys-and-values)
   (alexandria:plist-hash-table keys-and-values :test #'equal))
@@ -273,3 +279,110 @@
   (1 1 "00")
   (1 1 "00.0"))
 
+
+;;;; Fuzz Tests ---------------------------------------------------------------
+(defparameter *basic-chars*
+  " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")
+
+(defparameter *gen-depth* 0)
+(defparameter *max-gen-depth* 5)
+
+
+(chancery:define-rule gen/keyword
+  :true
+  :false)
+
+(chancery:define-rule gen/null
+  nil)
+
+(chancery:define-rule (random-char :distribution :weighted)
+  (50 (chancery:eval (string (alexandria:random-elt *basic-chars*))))
+  (1 "\\\\")
+  (1 "\\\"")
+  (1 "\\n")
+  (1 "\\b")
+  (1 "\\f")
+  (1 "\\t")
+  ;; todo more unicode
+  (1 (chancery:eval (format nil "\\u~4,'0X" (char-code (alexandria:random-elt *basic-chars*))))))
+
+(defun random-string ()
+  (with-output-to-string (s)
+    (dotimes (i (random 20))
+      (write-string (random-char) s))))
+
+(chancery:define-rule (gen/string :distribution :weighted)
+  (1 "")
+  (5 random-string))
+
+(chancery:define-rule gen/float
+  0.0d0
+  (chancery:eval (- (random 1d12) 0.5d12)))
+
+(defun gen/integer ()
+  (- (random 100000) 50000))
+
+(chancery:define-rule gen/number
+  0
+  0d0
+  gen/integer
+  gen/float)
+
+(defun gen/vector ()
+  (if (> *gen-depth* *max-gen-depth*)
+    (vector)
+    (let ((result (make-array (random 20)))
+          (*gen-depth* (1+ *gen-depth*)))
+      (dotimes (i (length result))
+        (setf (aref result i) (gen/any)))
+      result)))
+
+(defun gen/object ()
+  (if (> *gen-depth* *max-gen-depth*)
+    (h)
+    (let* ((result (h))
+           (*gen-depth* (1+ *gen-depth*))
+           (keys (remove-duplicates (loop :repeat (random 10)
+                                          :collect (gen/string))
+                                    :test #'equal)))
+      (dolist (k keys)
+        (setf (gethash k result) (gen/any)))
+      result)))
+
+(chancery:define-rule gen/any
+  gen/keyword
+  gen/null
+  gen/string
+  gen/number
+  gen/vector
+  gen/object)
+
+
+(defun yason/read (string)
+  (let ((yason:*parse-json-arrays-as-vectors* t)
+        (yason:*parse-json-booleans-as-symbols* t)
+        (*read-default-float-format* 'double-float))
+    (yason:parse string)))
+
+(defgeneric yason= (a b))
+
+(defmethod yason= (a b)
+  (equal a b))
+
+(defmethod yason= ((a symbol) (b symbol))
+  ;; Yason uses yason:true and yason:false instead of :true and :false.
+  (string= a b))
+
+(defmethod yason= ((a vector) (b vector))
+  (vec= a b :test #'yason=))
+
+(defmethod yason= ((a hash-table) (b hash-table))
+  (obj= a b :test #'yason=))
+
+
+(define-test fuzz-against-yason
+  (dotimes (i 1000)
+    (let ((s (jarl:print (gen/any) nil)))
+      ;; (format t "~&Fuzzing ~S" s)
+      (is (yason= (jarl:read t s)
+                  (yason/read s))))))