From b19fe7a7898f591b1d87ca6a2027c8e11125cbe2 Mon Sep 17 00:00:00 2001
From: Marek Kubica <marek@xivilization.net>
Date: Fri, 28 Jun 2024 16:32:15 +0200
Subject: [PATCH] New equality metric that compares numbers

Closes #156
---
 lib/dune            |  4 +++
 lib/equal.cppo.ml   | 60 +++++++++++++++++++++++++++++++++++++++++++++
 lib/monomorphic.ml  | 52 +++++++++------------------------------
 lib/monomorphic.mli |  8 ++++++
 4 files changed, 83 insertions(+), 41 deletions(-)
 create mode 100644 lib/equal.cppo.ml

diff --git a/lib/dune b/lib/dune
index 3e7dc94b..523df37d 100644
--- a/lib/dune
+++ b/lib/dune
@@ -8,6 +8,7 @@
   (:out t.cppo.ml)
   type.ml
   monomorphic.ml
+  equal.cppo.ml
   prettyprint.ml
   write.ml
   write2.ml)
@@ -33,6 +34,7 @@
   write.ml
   prettyprint.ml
   monomorphic.ml
+  equal.cppo.ml
   write2.ml
   read.ml
   util.ml)
@@ -62,6 +64,7 @@
   write.ml
   prettyprint.ml
   monomorphic.ml
+  equal.cppo.ml
   write2.ml
   read.ml
   util.ml)
@@ -91,6 +94,7 @@
   write.ml
   prettyprint.ml
   monomorphic.ml
+  equal.cppo.ml
   write2.ml
   read.ml
   util.ml)
diff --git a/lib/equal.cppo.ml b/lib/equal.cppo.ml
new file mode 100644
index 00000000..519ebcdf
--- /dev/null
+++ b/lib/equal.cppo.ml
@@ -0,0 +1,60 @@
+let rec equal a b =
+  let [@warning "-26"] float_int_equal f i = (float_of_int i) = f in
+  match a, b with
+  | `Null, `Null -> true
+  | `Bool a, `Bool b -> a = b
+#ifdef INT
+  | `Int a, `Int b -> a = b
+#endif
+#ifdef INTLIT
+    | `Intlit a, `Intlit b -> a = b
+  #ifdef NUMERIC_EQUAL
+    #ifdef INT
+    | `Intlit s, `Int i
+    | `Int i, `Intlit s -> (string_of_int i) = s
+    #endif
+  #endif
+#endif
+#ifdef FLOAT
+    | `Float a, `Float b -> a = b
+  #ifdef NUMERIC_EQUAL
+    #ifdef INT
+    | `Float f, `Int i
+    | `Int i, `Float f -> float_int_equal f i
+    #endif
+  #endif
+#endif
+#ifdef FLOATLIT
+    | `Floatlit a, `Floatlit b -> a = b
+  #ifdef NUMERIC_EQUAL
+    #ifdef FLOAT
+    | `Floatlit l, `Float f
+    | `Float f, `Floatlit l -> (string_of_float f) = l
+    #endif
+  #endif
+#endif
+#ifdef STRING
+    | `String a, `String b -> a = b
+#endif
+#ifdef STRINGLIT
+    | `Stringlit a, `Stringlit b -> a = b
+#endif
+    | `Assoc xs, `Assoc ys ->
+      let compare_keys = fun (key, _) (key', _) -> String.compare key key' in
+      let xs = List.stable_sort compare_keys xs in
+      let ys = List.stable_sort compare_keys ys in
+      (match List.for_all2 (fun (key, value) (key', value') ->
+        match key = key' with
+        | false -> false
+        | true -> equal value value') xs ys with
+      | result -> result
+      | exception Invalid_argument _ ->
+        (* the lists were of different lengths, thus unequal *)
+        false)
+    | `List xs, `List ys ->
+      (match List.for_all2 equal xs ys with
+      | result -> result
+      | exception Invalid_argument _ ->
+        (* the lists were of different lengths, thus unequal *)
+        false)
+    | _ -> false
diff --git a/lib/monomorphic.ml b/lib/monomorphic.ml
index 912323b4..222066ef 100644
--- a/lib/monomorphic.ml
+++ b/lib/monomorphic.ml
@@ -71,44 +71,14 @@ let rec pp fmt =
 let show x =
   Format.asprintf "%a" pp x
 
-let rec equal a b =
-  match a, b with
-  | `Null, `Null -> true
-  | `Bool a, `Bool b -> a = b
-#ifdef INT
-  | `Int a, `Int b -> a = b
-#endif
-#ifdef INTLIT
-    | `Intlit a, `Intlit b -> a = b
-#endif
-#ifdef FLOAT
-    | `Float a, `Float b -> a = b
-#endif
-#ifdef FLOATLIT
-    | `Floatlit a, `Floatlit b -> a = b
-#endif
-#ifdef STRING
-    | `String a, `String b -> a = b
-#endif
-#ifdef STRINGLIT
-    | `Stringlit a, `Stringlit b -> a = b
-#endif
-    | `Assoc xs, `Assoc ys ->
-      let compare_keys = fun (key, _) (key', _) -> String.compare key key' in
-      let xs = List.stable_sort compare_keys xs in
-      let ys = List.stable_sort compare_keys ys in
-      (match List.for_all2 (fun (key, value) (key', value') ->
-        match key = key' with
-        | false -> false
-        | true -> equal value value') xs ys with
-      | result -> result
-      | exception Invalid_argument _ ->
-        (* the lists were of different lengths, thus unequal *)
-        false)
-    | `List xs, `List ys ->
-      (match List.for_all2 equal xs ys with
-      | result -> result
-      | exception Invalid_argument _ ->
-        (* the lists were of different lengths, thus unequal *)
-        false)
-    | _ -> false
+let equal a b =
+  #include "equal.cppo.ml"
+  in
+  equal a b
+
+let numeric_equal a b =
+  #define NUMERIC_EQUAL
+    #include "equal.cppo.ml"
+  #undef NUMERIC_EQUAL
+  in
+  equal a b
diff --git a/lib/monomorphic.mli b/lib/monomorphic.mli
index 1bb233d3..625e6800 100644
--- a/lib/monomorphic.mli
+++ b/lib/monomorphic.mli
@@ -11,3 +11,11 @@ val equal : t -> t -> bool
       duplicate keys which will be considered equal as long as they are in the
       same input order.
     *)
+
+val numeric_equal : t -> t -> bool
+(** [numeric_equal a b] determines whether [a] and [b] are equal, while
+    attempting to preserve equality according to JSON rules which do not
+    distinguish between float and integers.
+
+    The remaining semantics are identical to [equal].
+    *)