ppx_compare PredSymb

Reviewed By: cristianoc

Differential Revision: D4232393

fbshipit-source-id: 384182b

infer/src/IR/PredSymb.re

@@ -43,7 +43,8 @@ type mem_kind =
   | Mmalloc /** memory allocated with malloc */
   | Mnew /** memory allocated with new */
   | Mnew_array /** memory allocated with new[] */
-  | Mobjc /** memory allocated with objective-c alloc */;
+  | Mobjc /** memory allocated with objective-c alloc */
+[@@deriving compare];
 
 let mem_kind_to_num =
   fun
@@ -52,39 +53,21 @@ let mem_kind_to_num =
   | Mnew_array => 2
   | Mobjc => 3;
 
-let mem_kind_compare mk1 mk2 => int_compare (mem_kind_to_num mk1) (mem_kind_to_num mk2);
-
 
 /** resource that can be allocated */
 type resource =
   | Rmemory mem_kind
   | Rfile
   | Rignore
-  | Rlock;
+  | Rlock
-
+[@@deriving compare];
-let resource_compare r1 r2 => {
-  let res_to_num =
-    fun
-    | Rmemory mk => mem_kind_to_num mk
-    | Rfile => 100
-    | Rignore => 200
-    | Rlock => 300;
-  int_compare (res_to_num r1) (res_to_num r2)
-};
 
 
 /** kind of resource action */
 type res_act_kind =
   | Racquire
-  | Rrelease;
+  | Rrelease
-
+[@@deriving compare];
-let res_act_kind_compare rak1 rak2 =>
-  switch (rak1, rak2) {
-  | (Racquire, Racquire) => 0
-  | (Racquire, Rrelease) => (-1)
-  | (Rrelease, Racquire) => 1
-  | (Rrelease, Rrelease) => 0
-  };
 
 
 /** kind of dangling pointers */
@@ -95,62 +78,24 @@ type dangling_kind =
       of a stack variable which went out of scope */
   | DAaddr_stack_var
   /** pointer is -1 */
-  | DAminusone;
+  | DAminusone
-
+[@@deriving compare];
-let dangling_kind_compare dk1 dk2 =>
-  switch (dk1, dk2) {
-  | (DAuninit, DAuninit) => 0
-  | (DAuninit, _) => (-1)
-  | (_, DAuninit) => 1
-  | (DAaddr_stack_var, DAaddr_stack_var) => 0
-  | (DAaddr_stack_var, _) => (-1)
-  | (_, DAaddr_stack_var) => 1
-  | (DAminusone, DAminusone) => 0
-  };
 
 
 /** position in a path: proc name, node id */
-type path_pos = (Procname.t, int);
+type path_pos = (Procname.t, int) [@@deriving compare];
-
-let path_pos_compare (pn1, nid1) (pn2, nid2) => {
-  let n = Procname.compare pn1 pn2;
-  if (n != 0) {
-    n
-  } else {
-    int_compare nid1 nid2
-  }
-};
 
-let path_pos_equal pp1 pp2 => path_pos_compare pp1 pp2 == 0;
+let equal_path_pos pp1 pp2 => compare_path_pos pp1 pp2 == 0;
 
 type taint_kind =
   | Tk_unverified_SSL_socket
   | Tk_shared_preferences_data
   | Tk_privacy_annotation
   | Tk_integrity_annotation
-  | Tk_unknown;
+  | Tk_unknown
-
+[@@deriving compare];
-let taint_kind_compare tk1 tk2 =>
-  switch (tk1, tk2) {
-  | (Tk_unverified_SSL_socket, Tk_unverified_SSL_socket) => 0
-  | (Tk_unverified_SSL_socket, _) => (-1)
-  | (_, Tk_unverified_SSL_socket) => 1
-  | (Tk_shared_preferences_data, Tk_shared_preferences_data) => 0
-  | (Tk_shared_preferences_data, _) => 1
-  | (_, Tk_shared_preferences_data) => (-1)
-  | (Tk_privacy_annotation, Tk_privacy_annotation) => 0
-  | (Tk_privacy_annotation, _) => 1
-  | (_, Tk_privacy_annotation) => (-1)
-  | (Tk_integrity_annotation, Tk_integrity_annotation) => 0
-  | (Tk_integrity_annotation, _) => 1
-  | (_, Tk_integrity_annotation) => (-1)
-  | (Tk_unknown, Tk_unknown) => 0
-  };
-
-type taint_info = {taint_source: Procname.t, taint_kind: taint_kind};
 
-let taint_info_compare {taint_source: ts1, taint_kind: tk1} {taint_source: ts2, taint_kind: tk2} =>
+type taint_info = {taint_source: Procname.t, taint_kind: taint_kind} [@@deriving compare];
-  taint_kind_compare tk1 tk2 |> next Procname.compare ts1 ts2;
 
 
 /** acquire/release action on a resource */
@@ -162,6 +107,23 @@ type res_action = {
   ra_vpath: DecompiledExp.vpath /** vpath of the resource value */
 };
 
+/* ignore other values beside resources: arbitrary merging into one */
+let compare_res_action {ra_kind: k1, ra_res: r1} {ra_kind: k2, ra_res: r2} =>
+  [%compare : (res_act_kind, resource)] (k1, r1) (k2, r2);
+
+/* type aliases for components of t values that compare should ignore */
+type _annot_item = Annot.Item.t;
+
+let compare__annot_item _ _ => 0;
+
+type _location = Location.t;
+
+let compare__location _ _ => 0;
+
+type _path_pos = path_pos;
+
+let compare__path_pos _ _ => 0;
+
 
 /** Attributes are nary function symbols that are applied to expression arguments in Apred and
     Anpred atomic formulas.  Many operations don't make much sense for nullary predicates, and are
@@ -176,7 +138,7 @@ type t =
   | Aautorelease
   | Adangling dangling_kind /** dangling pointer */
   /** undefined value obtained by calling the given procedure, plus its return value annots */
-  | Aundef Procname.t Annot.Item.t Location.t path_pos
+  | Aundef Procname.t _annot_item _location _path_pos
   | Ataint taint_info
   | Auntaint taint_info
   | Alocked
@@ -190,62 +152,8 @@ type t =
   /** denotes an object registered as an observers to a notification center */
   | Aobserver
   /** denotes an object unsubscribed from observers of a notification center */
-  | Aunsubscribed_observer;
+  | Aunsubscribed_observer
-
+[@@deriving compare];
-let compare (att1: t) (att2: t) :int =>
-  switch (att1, att2) {
-  | (Aresource ra1, Aresource ra2) =>
-    let n = res_act_kind_compare ra1.ra_kind ra2.ra_kind;
-    if (n != 0) {
-      n
-    } else {
-      /* ignore other values beside resources: arbitrary merging into one */
-      resource_compare
-        ra1.ra_res ra2.ra_res
-    }
-  | (Aresource _, _) => (-1)
-  | (_, Aresource _) => 1
-  | (Aautorelease, Aautorelease) => 0
-  | (Aautorelease, _) => (-1)
-  | (_, Aautorelease) => 1
-  | (Adangling dk1, Adangling dk2) => dangling_kind_compare dk1 dk2
-  | (Adangling _, _) => (-1)
-  | (_, Adangling _) => 1
-  | (Aundef pn1 _ _ _, Aundef pn2 _ _ _) => Procname.compare pn1 pn2
-  | (Ataint ti1, Ataint ti2) => taint_info_compare ti1 ti2
-  | (Ataint _, _) => (-1)
-  | (_, Ataint _) => 1
-  | (Auntaint ti1, Auntaint ti2) => taint_info_compare ti1 ti2
-  | (Auntaint _, _) => (-1)
-  | (_, Auntaint _) => 1
-  | (Alocked, Alocked) => 0
-  | (Alocked, _) => (-1)
-  | (_, Alocked) => 1
-  | (Aunlocked, Aunlocked) => 0
-  | (Aunlocked, _) => (-1)
-  | (_, Aunlocked) => 1
-  | (Adiv0 pp1, Adiv0 pp2) => path_pos_compare pp1 pp2
-  | (Adiv0 _, _) => (-1)
-  | (_, Adiv0 _) => 1
-  | (Aobjc_null, Aobjc_null) => 0
-  | (Aobjc_null, _) => (-1)
-  | (_, Aobjc_null) => 1
-  | (Aretval pn1 annots1, Aretval pn2 annots2) =>
-    let n = Procname.compare pn1 pn2;
-    if (n != 0) {
-      n
-    } else {
-      Annot.Item.compare annots1 annots2
-    }
-  | (Aretval _, _) => (-1)
-  | (_, Aretval _) => 1
-  | (Aobserver, Aobserver) => 0
-  | (Aobserver, _) => (-1)
-  | (_, Aobserver) => 1
-  | (Aunsubscribed_observer, Aunsubscribed_observer) => 0
-  | (Aunsubscribed_observer, _) => (-1)
-  | (_, Aunsubscribed_observer) => 1
-  };
 
 let equal att1 att2 => compare att1 att2 == 0;
 
@@ -278,11 +186,10 @@ type category =
   | ACobjc_null
   | ACundef
   | ACretval
-  | ACobserver;
+  | ACobserver
-
+[@@deriving compare];
-let category_compare (ac1: category) (ac2: category) :int => Pervasives.compare ac1 ac2;
 
-let category_equal att1 att2 => category_compare att1 att2 == 0;
+let equal_category att1 att2 => compare_category att1 att2 == 0;
 
 let to_category att =>
   switch att {

infer/src/IR/PredSymb.rei

@@ -41,9 +41,8 @@ type mem_kind =
   | Mmalloc /** memory allocated with malloc */
   | Mnew /** memory allocated with new */
   | Mnew_array /** memory allocated with new[] */
-  | Mobjc /** memory allocated with objective-c alloc */;
+  | Mobjc /** memory allocated with objective-c alloc */
-
+[@@deriving compare];
-let mem_kind_compare: mem_kind => mem_kind => int;
 
 
 /** resource that can be allocated */
@@ -51,17 +50,15 @@ type resource =
   | Rmemory mem_kind
   | Rfile
   | Rignore
-  | Rlock;
+  | Rlock
-
+[@@deriving compare];
-let resource_compare: resource => resource => int;
 
 
 /** kind of resource action */
 type res_act_kind =
   | Racquire
-  | Rrelease;
+  | Rrelease
-
+[@@deriving compare];
-let res_act_kind_compare: res_act_kind => res_act_kind => int;
 
 
 /** kind of dangling pointers */
@@ -75,11 +72,9 @@ type dangling_kind =
 
 
 /** position in a path: proc name, node id */
-type path_pos = (Procname.t, int);
+type path_pos = (Procname.t, int) [@@deriving compare];
 
-let path_pos_compare: path_pos => path_pos => int;
+let equal_path_pos: path_pos => path_pos => bool;
-
-let path_pos_equal: path_pos => path_pos => bool;
 
 type taint_kind =
   | Tk_unverified_SSL_socket
@@ -128,9 +123,8 @@ type t =
   /** denotes an object registered as an observers to a notification center */
   | Aobserver
   /** denotes an object unsubscribed from observers of a notification center */
-  | Aunsubscribed_observer;
+  | Aunsubscribed_observer
-
+[@@deriving compare];
-let compare: t => t => int;
 
 let equal: t => t => bool;
 
@@ -153,11 +147,10 @@ type category =
   | ACobjc_null
   | ACundef
   | ACretval
-  | ACobserver;
+  | ACobserver
-
+[@@deriving compare];
-let category_compare: category => category => int;
 
-let category_equal: category => category => bool;
+let equal_category: category => category => bool;
 
 
 /**  Return the category to which the attribute belongs. */

infer/src/IR/Sil.re

@@ -334,7 +334,7 @@ let inst_compare_base inst1 inst2 =>
         if (n != 0) {
           n
         } else {
-          PredSymb.path_pos_compare path_pos1 path_pos2
+          PredSymb.compare_path_pos path_pos1 path_pos2
         }
       }
     }
@@ -359,7 +359,7 @@ let inst_compare_base inst1 inst2 =>
         if (n != 0) {
           n
         } else {
-          PredSymb.path_pos_compare path_pos1 path_pos2
+          PredSymb.compare_path_pos path_pos1 path_pos2
         }
       }
     }

infer/src/backend/Attribute.ml

@@ -30,7 +30,7 @@ let add tenv ?(footprint = false) ?(polarity = true) prop attr args =
 let attributes_in_same_category attr1 attr2 =
   let cat1 = PredSymb.to_category attr1 in
   let cat2 = PredSymb.to_category attr2 in
-  PredSymb.category_equal cat1 cat2
+  PredSymb.equal_category cat1 cat2
 
 (** Replace an attribute associated to the expression *)
 let add_or_replace_check_changed tenv check_attribute_change prop atom0 =
@@ -88,7 +88,7 @@ let get tenv prop exp category =
     Some
       (IList.find (function
            | Sil.Apred (att, _) | Anpred (att, _) ->
-               PredSymb.category_equal (PredSymb.to_category att) category
+               PredSymb.equal_category (PredSymb.to_category att) category
            | _ -> false
          ) atts)
   with Not_found -> None
@@ -150,8 +150,8 @@ let remove_for_attr tenv prop att0 =
 let remove_resource tenv ra_kind ra_res =
   let f = function
     | Sil.Apred (Aresource res_action, _) ->
-        PredSymb.res_act_kind_compare res_action.ra_kind ra_kind <> 0
+        PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0
-        || PredSymb.resource_compare res_action.ra_res ra_res <> 0
+        || PredSymb.compare_resource res_action.ra_res ra_res <> 0
     | _ -> true in
   filter_atoms tenv ~f
 

infer/src/backend/paths.ml

@@ -275,7 +275,7 @@ end = struct
   let contains_position path pos =
     let found = ref false in
     let f node =
-      if PredSymb.path_pos_equal (get_path_pos node) pos then found := true;
+      if PredSymb.equal_path_pos (get_path_pos node) pos then found := true;
       true in
     Invariant.compute_stats true f path;
     Invariant.reset_stats path;
@@ -318,7 +318,7 @@ end = struct
       (pos_opt : PredSymb.path_pos option) (path: t) : unit =
     let filter node = match pos_opt with
       | None -> true
-      | Some pos -> PredSymb.path_pos_equal (get_path_pos node) pos in
+      | Some pos -> PredSymb.equal_path_pos (get_path_pos node) pos in
     let path_pos_at_path p =
       try
         match curr_node p with

infer/src/backend/tabulation.ml

@@ -590,7 +590,7 @@ let prop_footprint_add_pi_sigma_starfld_sigma tenv
 let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with
   | PredSymb.Aresource ({ ra_kind = Racquire; ra_res = Rmemory mk_old } as ra_old),
     PredSymb.Aresource ({ ra_kind = Rrelease; ra_res = Rmemory mk_new } as ra_new)
-    when PredSymb.mem_kind_compare mk_old mk_new <> 0 ->
+    when PredSymb.compare_mem_kind mk_old mk_new <> 0 ->
       let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in
       raise (Exceptions.Deallocation_mismatch (desc, __POS__))
   | _ -> ()