From 0a3993edeea7af61e71fe6f315379211250ff1ab Mon Sep 17 00:00:00 2001
From: Sam Blackshear <shb@fb.com>
Date: Fri, 14 Oct 2016 10:14:39 -0700
Subject: [PATCH] [utils] add tags_compare utility to make writing default
 comparison functions easy

Differential Revision: D4020123

fbshipit-source-id: ace1a03
---
 infer/src/base/Utils.ml         | 17 +++++++++++++++++
 infer/src/base/Utils.mli        |  4 ++++
 infer/src/quandary/CppTrace.ml  | 13 ++-----------
 infer/src/quandary/JavaTrace.ml | 19 ++-----------------
 4 files changed, 25 insertions(+), 28 deletions(-)

diff --git a/infer/src/base/Utils.ml b/infer/src/base/Utils.ml
index d523db6e4..9098f4c55 100644
--- a/infer/src/base/Utils.ml
+++ b/infer/src/base/Utils.ml
@@ -81,6 +81,23 @@ let trd3 (_,_,x) = x
 
 let int_of_bool b = if b then 1 else 0
 
+let tags_compare (x : 'a) (y : 'a) =
+  let x = Obj.repr x
+  and y = Obj.repr y in
+  if Obj.is_int x
+  then
+    if Obj.is_int y
+    (* we can use (-) because tags are small and won't overflow *)
+    then Obj.obj x - Obj.obj y
+    else -1
+  else if Obj.is_int y
+  then 1
+  else
+    let r = Obj.tag x - Obj.tag y in
+    if r = 0
+    then failwith "Comparing parameterized constructors"
+    else r
+
 (** {2 Useful Modules} *)
 
 (** Set of integers *)
diff --git a/infer/src/base/Utils.mli b/infer/src/base/Utils.mli
index a12ce03ff..fdcd02b40 100644
--- a/infer/src/base/Utils.mli
+++ b/infer/src/base/Utils.mli
@@ -69,6 +69,10 @@ val string_equal : string -> string -> bool
 (** Comparison for floats *)
 val float_compare : float -> float -> int
 
+(** Use this function to compare sum types (ONLY!) in the default case of your custom compare
+    function. It will fail if you try to check equality of parameterized constructors *)
+val tags_compare: 'a -> 'a -> int
+
 (** Return the first component of a triple. *)
 val fst3 : 'a * 'b * 'c -> 'a
 
diff --git a/infer/src/quandary/CppTrace.ml b/infer/src/quandary/CppTrace.ml
index 2955e1e6c..544030ecf 100644
--- a/infer/src/quandary/CppTrace.ml
+++ b/infer/src/quandary/CppTrace.ml
@@ -22,12 +22,7 @@ module CppSource = struct
 
     let compare sk1 sk2 = match sk1, sk2 with
       | Footprint ap1, Footprint ap2 -> AccessPath.compare ap1 ap2
-      | Footprint _, _ -> (-1)
-      | _, Footprint _ -> 1
-      | EnvironmentVariable, EnvironmentVariable -> 0
-      | EnvironmentVariable, _ -> (-1)
-      | _, EnvironmentVariable -> 1
-      | Other, Other -> 0
+      | _ -> tags_compare sk1 sk2
   end
 
   type kind = SourceKind.t
@@ -107,11 +102,7 @@ module CppSink = struct
       | ShellExec (** shell exec function *)
       | Other (** for testing or uncategorized sinks *)
 
-    let compare snk1 snk2 = match snk1, snk2 with
-      | ShellExec, ShellExec -> 0
-      | ShellExec, _ -> (-1)
-      | _, ShellExec -> 1
-      | Other, Other -> 0
+    let compare snk1 snk2 = tags_compare snk1 snk2
   end
 
   type kind = SinkKind.t
diff --git a/infer/src/quandary/JavaTrace.ml b/infer/src/quandary/JavaTrace.ml
index 631f81941..393caff8a 100644
--- a/infer/src/quandary/JavaTrace.ml
+++ b/infer/src/quandary/JavaTrace.ml
@@ -22,16 +22,8 @@ module JavaSource = struct
       | Other (** for testing or uncategorized sources *)
 
     let compare sk1 sk2 = match sk1, sk2 with
-      | SharedPreferences, SharedPreferences -> 0
-      | SharedPreferences, _ -> (-1)
-      | _, SharedPreferences -> 1
       | Footprint ap1, Footprint ap2 -> AccessPath.compare ap1 ap2
-      | Footprint _, _ -> (-1)
-      | _, Footprint _ -> 1
-      | Intent, Intent -> 0
-      | Intent, _ -> (-1)
-      | _, Intent -> 1
-      | Other, Other -> 0
+      | _ -> tags_compare sk1 sk2
   end
 
   type kind = SourceKind.t
@@ -109,14 +101,7 @@ module JavaSink = struct
       | Logging (** sink that logs one or more of its arguments *)
       | Other (** for testing or uncategorized sinks *)
 
-    let compare snk1 snk2 = match snk1, snk2 with
-      | Logging, Logging -> 0
-      | Logging, _ -> (-1)
-      | _, Logging -> 1
-      | Intent, Intent -> 0
-      | Intent, _ -> (-1)
-      | _, Intent -> 1
-      | Other, Other -> 0
+    let compare snk1 snk2 = tags_compare snk1 snk2
   end
 
   type kind = SinkKind.t