# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1597372406 14400
# Node ID 69dd3d1b63f36572615503948ee217906f08d903
# Parent  d23a34c34dc3f1d45797fd0a474dd49e84f84fd8
Refactor fuzzing code, fuzz in both directions

diff -r d23a34c34dc3 -r 69dd3d1b63f3 test/tests.lisp
--- a/test/tests.lisp	Thu Aug 13 22:06:44 2020 -0400
+++ b/test/tests.lisp	Thu Aug 13 22:33:26 2020 -0400
@@ -280,7 +280,7 @@
   (1 1 "00.0"))
 
 
-;;;; Fuzz Tests ---------------------------------------------------------------
+;;;; Fuzz Utilities -----------------------------------------------------------
 (defparameter *basic-chars*
   " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")
 
@@ -358,31 +358,70 @@
   gen/object)
 
 
+(defun copy-and-map-hash-table (function hash-table)
+  (let ((result (make-hash-table :test #'equal
+                                 :size (hash-table-count hash-table))))
+    (maphash (lambda (k v)
+               (setf (gethash k result) (funcall function v)))
+             hash-table)
+    result))
+
+
+(defgeneric to-jarl (from o)
+  (:method (from o) o)
+  (:method (from (o string)) o))
+
+(defmethod to-jarl (from (o vector))
+  (map 'vector (alexandria:curry #'to-jarl from) o))
+
+(defmethod to-jarl (from (o hash-table))
+  (copy-and-map-hash-table (alexandria:curry #'to-jarl from) o))
+
+
+(defgeneric from-jarl (to o)
+  (:method (to o) o)
+  (:method (to (o string)) o))
+
+(defmethod from-jarl (to (o vector))
+  (map 'vector (alexandria:curry #'from-jarl to) o))
+
+(defmethod from-jarl (to (o hash-table))
+  (copy-and-map-hash-table (alexandria:curry #'from-jarl to) o))
+
+
+;;;; Yason Fuzzing ------------------------------------------------------------
 (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))
+(defun yason/print (object)
+  (let ((yason:*parse-json-arrays-as-vectors* t)
+        (yason:*parse-json-booleans-as-symbols* t)
+        (*read-default-float-format* 'double-float))
+    (with-output-to-string (s)
+      (yason:encode object s))))
 
-(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 to-jarl ((from (eql 'yason)) (o symbol))
+  (alexandria:make-keyword o))
+
+(defmethod to-jarl ((from (eql 'yason)) (o null))
+  nil)
 
-(defmethod yason= ((a vector) (b vector))
-  (vec= a b :test #'yason=))
 
-(defmethod yason= ((a hash-table) (b hash-table))
-  (obj= a b :test #'yason=))
+(defmethod from-jarl ((to (eql 'yason)) (o symbol))
+  (ecase o
+    ((nil) nil)
+    (:true 'yason:true)
+    (:false 'yason:false)))
 
 
 (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))))))
+  (dotimes (i 500)
+    (let* ((o (gen/any))
+           (js (jarl:print o nil))
+           (ys (yason/print (from-jarl 'yason o))))
+      (is (same (jarl:read t js) (to-jarl 'yason (yason/read js))))
+      (is (same (jarl:read t ys) (to-jarl 'yason (yason/read ys)))))))