From 89702924d8678b978b6da2d9b958d741b47e3aeb Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 30 Jun 2022 20:25:19 -0400
Subject: [PATCH] test: add qcheck test for cbor

---
 src/cbor/tests/dune | 17 ++++++++++--
 src/cbor/tests/t.ml | 65 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 80 insertions(+), 2 deletions(-)
 create mode 100644 src/cbor/tests/t.ml

diff --git a/src/cbor/tests/dune b/src/cbor/tests/dune
index 61ae6a4a..2a76380d 100644
--- a/src/cbor/tests/dune
+++ b/src/cbor/tests/dune
@@ -1,10 +1,23 @@
 (executable
  (name t_appendix_a)
  (modules t_appendix_a)
- (preprocess (action (run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
+ (preprocess
+  (action
+   (run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
  (libraries yojson containers containers.cbor))
 
 (rule
  (alias runtest)
+ (deps t_appendix_a.exe appendix_a.json)
  (action
-   (run ./t_appendix_a.exe ./appendix_a.json)))
+  (run ./t_appendix_a.exe ./appendix_a.json)))
+
+(executable
+ (name t)
+ (modules t)
+ (libraries qcheck-core qcheck-core.runner containers containers.cbor))
+
+(rule
+ (alias runtest)
+ (action
+  (run ./t.exe --no-colors)))
diff --git a/src/cbor/tests/t.ml b/src/cbor/tests/t.ml
new file mode 100644
index 00000000..9680db8e
--- /dev/null
+++ b/src/cbor/tests/t.ml
@@ -0,0 +1,65 @@
+
+module Q = QCheck
+module Cbor = Containers_cbor
+
+let suite = ref []
+
+[@@@ifge 4.08]
+
+let gen_c : Cbor.t Q.Gen.t =
+  let open Q.Gen in
+  sized @@ fix @@ fun self size ->
+    let recurse = self (size-1) in
+    let base = [
+      (1, return `Null);
+      (1, return `Undefined);
+      (3, let+ x = int in `Int x);
+      (1, let+ b = bool in `Bool b);
+      (1, let+ f = float in `Float f);
+      (2, let+ s = string_size ~gen:printable (0--150) in `Text s);
+      (2, let+ s = string_size ~gen:char (0--150) in `Bytes s);
+    ] in
+    let rec_ = [
+      (2, let+ l = list_size (0--5) recurse in `Array l);
+      (2, let+ l = list_size (0--5) (pair (frequency base) recurse) in `Map l);
+    ]in
+    frequency (if size>0  then base @ rec_ else base)
+
+let rec shrink (c:Cbor.t) : Cbor.t Q.Iter.t =
+  let open Q.Iter in
+  match c with
+  | `Null | `Undefined | `Bool false -> empty
+  | `Bool true -> return (`Bool false)
+  | `Simple i -> let+ i = Q.Shrink.int i in `Simple i
+  | `Int i -> let+ i = Q.Shrink.int i in `Int i
+  | `Tag(t,i) -> let+ i = shrink i in `Tag (t,i)
+  | `Float _ -> empty
+  | `Array l ->
+    let+ l = Q.Shrink.list ~shrink l in `Array l
+  | `Map l ->
+    let shrink_pair (a,b) =
+      (let+a = shrink a in a,b) <+> (let+b = shrink b in a,b)
+    in
+    let+ l = Q.Shrink.list ~shrink:shrink_pair l in `Map l
+  | `Text s ->
+    let+ s = Q.Shrink.string s in `Text s
+  | `Bytes s ->
+    let+ s = Q.Shrink.string s in `Bytes s
+
+
+let arb = Q.make ~shrink ~print:Cbor.to_string_diagnostic gen_c
+
+let t1 =
+  Q.Test.make ~count:100_000 ~name:"to_from_same" arb @@ fun c ->
+    let s = Cbor.encode c in
+    let c' = Cbor.decode_exn s in
+    if not (c = c') then
+      Q.Test.fail_reportf "@[<hv2>roundtrip failed:@ from %a@ to %a@]"
+      Cbor.pp_diagnostic c Cbor.pp_diagnostic c';
+    true
+
+let () = suite := t1 :: !suite
+
+[@@@endif]
+
+let () = QCheck_base_runner.run_tests_main !suite