Simplify payloads with ppx_fields_conv

Summary: Reduces payload fields boilerplate.

Reviewed By: jeremydubreil

Differential Revision: D15051982

fbshipit-source-id: eb77e7994

infer/src/absint/SummaryPayload.ml

@@ -10,9 +10,7 @@ open! IStd
 module type Payload = sig
   type t
 
-  val update_payloads : t -> Payloads.t -> Payloads.t
+  val field : (Payloads.t, t option) Field.t
-
-  val of_payloads : Payloads.t -> t option
 end
 
 module type S = sig
@@ -30,11 +28,15 @@ end
 module Make (P : Payload) : S with type t = P.t = struct
   type t = P.t
 
+  let update_payloads = Field.fset P.field
+
+  let of_payloads = Field.get P.field
+
   let update_summary p (summary : Summary.t) =
-    {summary with payloads= P.update_payloads p summary.payloads}
+    {summary with payloads= update_payloads summary.payloads (Some p)}
 
 
-  let of_summary (summary : Summary.t) = P.of_payloads summary.payloads
+  let of_summary (summary : Summary.t) = of_payloads summary.payloads
 
   let read_full caller_pdesc callee_pname =
     let open Option.Monad_infix in

infer/src/absint/SummaryPayload.mli

@@ -10,11 +10,7 @@ open! IStd
 module type Payload = sig
   type t
 
-  val update_payloads : t -> Payloads.t -> Payloads.t
+  val field : (Payloads.t, t option) Field.t
-  (** Update the corresponding part of the payloads *)
-
-  val of_payloads : Payloads.t -> t option
-  (** Read the corresponding part of the payloads *)
 end
 
 module type S = sig

infer/src/backend/Payloads.ml

@@ -25,6 +25,7 @@ type t =
   ; starvation: StarvationDomain.summary option
   ; typestate: TypeState.t option
   ; uninit: UninitDomain.Summary.t option }
+[@@deriving fields]
 
 let pp pe fmt
     { annot_map

infer/src/backend/Payloads.mli

@@ -25,6 +25,7 @@ type t =
   ; starvation: StarvationDomain.summary option
   ; typestate: TypeState.t option
   ; uninit: UninitDomain.Summary.t option }
+[@@deriving fields]
 
 val pp : Pp.env -> Format.formatter -> t -> unit
 

infer/src/bufferoverrun/bufferOverrunAnalysis.ml

@@ -19,11 +19,7 @@ module Sem = BufferOverrunSemantics
 module Payload = SummaryPayload.Make (struct
   type t = BufferOverrunAnalysisSummary.t
 
-  let update_payloads astate (payloads : Payloads.t) =
+  let field = Payloads.Fields.buffer_overrun_analysis
-    {payloads with buffer_overrun_analysis= Some astate}
-
-
-  let of_payloads (payloads : Payloads.t) = payloads.buffer_overrun_analysis
 end)
 
 type summary_and_formals = BufferOverrunAnalysisSummary.t * (Pvar.t * Typ.t) list

infer/src/bufferoverrun/bufferOverrunChecker.ml

@@ -23,11 +23,7 @@ module Trace = BufferOverrunTrace
 module Payload = SummaryPayload.Make (struct
   type t = BufferOverrunCheckerSummary.t
 
-  let update_payloads astate (payloads : Payloads.t) =
+  let field = Payloads.Fields.buffer_overrun_checker
-    {payloads with buffer_overrun_checker= Some astate}
-
-
-  let of_payloads (payloads : Payloads.t) = payloads.buffer_overrun_checker
 end)
 
 module UnusedBranch = struct

infer/src/checkers/Litho.ml

@@ -12,9 +12,7 @@ module Domain = LithoDomain
 module Payload = SummaryPayload.Make (struct
   type t = Domain.t
 
-  let update_payloads astate (payloads : Payloads.t) = {payloads with litho= Some astate}
+  let field = Payloads.Fields.litho
-
-  let of_payloads (payloads : Payloads.t) = payloads.litho
 end)
 
 module LithoFramework = struct

infer/src/checkers/Siof.ml

@@ -60,9 +60,7 @@ let is_modelled =
 module Payload = SummaryPayload.Make (struct
   type t = SiofDomain.Summary.t
 
-  let update_payloads astate (payloads : Payloads.t) = {payloads with siof= Some astate}
+  let field = Payloads.Fields.siof
-
-  let of_payloads (payloads : Payloads.t) = payloads.siof
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/checkers/annotationReachability.ml

@@ -62,9 +62,7 @@ end
 module Payload = SummaryPayload.Make (struct
   type t = AnnotReachabilityDomain.t
 
-  let update_payloads annot_map (payloads : Payloads.t) = {payloads with annot_map= Some annot_map}
+  let field = Payloads.Fields.annot_map
-
-  let of_payloads (payloads : Payloads.t) = payloads.annot_map
 end)
 
 let is_modeled_expensive tenv = function

infer/src/checkers/classLoads.ml

@@ -19,9 +19,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ClassLoadsDomain.summary
 
-  let update_payloads post (payloads : Payloads.t) = {payloads with class_loads= Some post}
+  let field = Payloads.Fields.class_loads
-
-  let of_payloads (payloads : Payloads.t) = payloads.class_loads
 end)
 
 let do_call pdesc callee loc init =

infer/src/checkers/cost.ml

@@ -13,9 +13,7 @@ module BasicCost = CostDomain.BasicCost
 module Payload = SummaryPayload.Make (struct
   type t = CostDomain.summary
 
-  let update_payloads sum (payloads : Payloads.t) = {payloads with cost= Some sum}
+  let field = Payloads.Fields.cost
-
-  let of_payloads (payloads : Payloads.t) = payloads.cost
 end)
 
 (* We use this threshold to give error if the cost is above it.

infer/src/checkers/purity.ml

@@ -17,9 +17,7 @@ let debug fmt = L.(debug Analysis Verbose fmt)
 module Payload = SummaryPayload.Make (struct
   type t = PurityDomain.summary
 
-  let update_payloads post (payloads : Payloads.t) = {payloads with purity= Some post}
+  let field = Payloads.Fields.purity
-
-  let of_payloads (payloads : Payloads.t) = payloads.purity
 end)
 
 type purity_extras =

infer/src/checkers/uninit.ml

@@ -19,9 +19,7 @@ module RecordDomain = UninitDomain.Record (MaybeUninitVars) (AliasedVars) (D)
 module Payload = SummaryPayload.Make (struct
   type t = UninitDomain.Summary.t
 
-  let update_payloads sum (payloads : Payloads.t) = {payloads with uninit= Some sum}
+  let field = Payloads.Fields.uninit
-
-  let of_payloads (payloads : Payloads.t) = payloads.uninit
 end)
 
 module Models = struct

infer/src/concurrency/RacerD.ml

@@ -13,9 +13,7 @@ module MF = MarkupFormatter
 module Payload = SummaryPayload.Make (struct
   type t = RacerDDomain.summary
 
-  let update_payloads post (payloads : Payloads.t) = {payloads with racerd= Some post}
+  let field = Payloads.Fields.racerd
-
-  let of_payloads (payloads : Payloads.t) = payloads.racerd
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/concurrency/starvation.ml

@@ -33,9 +33,7 @@ let is_nonblocking tenv proc_desc =
 module Payload = SummaryPayload.Make (struct
   type t = StarvationDomain.summary
 
-  let update_payloads post (payloads : Payloads.t) = {payloads with starvation= Some post}
+  let field = Payloads.Fields.starvation
-
-  let of_payloads (payloads : Payloads.t) = payloads.starvation
 end)
 
 (* using an indentifier for a class object, create an access path representing that lock;

infer/src/deadcode/dune.in

@@ -16,7 +16,7 @@ Format.sprintf
  (ocamlopt_flags (%s))
  (libraries %s)
  (modules All_infer_in_one_file)
- (preprocess (pps ppx_compare ppx_sexp_conv ppx_variants_conv -no-check))
+ (preprocess (pps ppx_compare ppx_fields_conv ppx_sexp_conv ppx_variants_conv -no-check))
 )
 |}
   (String.concat " " common_cflags)

infer/src/dune.in

@@ -63,7 +63,7 @@ let stanzas =
  (ocamlopt_flags (%s))
  (libraries %s)
  (modules :standard \ %s infertop)
- (preprocess (pps ppx_compare ppx_sexp_conv ppx_variants_conv -no-check))
+ (preprocess (pps ppx_compare ppx_fields_conv ppx_sexp_conv ppx_variants_conv -no-check))
 )
 
 (documentation
@@ -83,7 +83,7 @@ let stanzas =
  (ocamlopt_flags (%s))
  (libraries InferModules)
  (modules %s)
- (preprocess (pps ppx_compare ppx_sexp_conv ppx_variants_conv -no-check))
+ (preprocess (pps ppx_compare ppx_fields_conv ppx_sexp_conv ppx_variants_conv -no-check))
 )
 |}
         (String.concat " " infer_binaries)
@@ -97,7 +97,7 @@ let stanzas =
  (flags (%s))
  (libraries utop InferModules)
  (modules Infertop)
- (preprocess (pps ppx_compare ppx_sexp_conv ppx_variants_conv -no-check))
+ (preprocess (pps ppx_compare ppx_fields_conv ppx_sexp_conv ppx_variants_conv -no-check))
  (link_flags (-linkall -warn-error -31))
 )
 |}

infer/src/labs/00_dummy_checker/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.t
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/labs/01_integer_domain/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.t
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/labs/02_domain_join/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.t
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/labs/03_domain_top/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.t
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/labs/04_interprocedural/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.t
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/labs/05_access_paths_interprocedural/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.summary
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/labs/ResourceLeaks.ml

@@ -13,11 +13,7 @@ module L = Logging
 module Payload = SummaryPayload.Make (struct
   type t = ResourceLeakDomain.t
 
-  let update_payloads resources_payload (payloads : Payloads.t) =
+  let field = Payloads.Fields.lab_resource_leaks
-    {payloads with lab_resource_leaks= Some resources_payload}
-
-
-  let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks
 end)
 
 module TransferFunctions (CFG : ProcCfg.S) = struct

infer/src/pulse/Pulse.ml

@@ -40,9 +40,7 @@ let check_error summary = function
 module Payload = SummaryPayload.Make (struct
   type t = PulseSummary.t
 
-  let update_payloads astate (payloads : Payloads.t) = {payloads with pulse= Some astate}
+  let field = Payloads.Fields.pulse
-
-  let of_payloads (payloads : Payloads.t) = payloads.pulse
 end)
 
 module PulseTransferFunctions = struct

infer/src/quandary/TaintAnalysis.ml

@@ -17,11 +17,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct
   module Payload = SummaryPayload.Make (struct
     type t = QuandarySummary.t
 
-    let update_payloads quandary_payload (payloads : Payloads.t) =
+    let field = Payloads.Fields.quandary
-      {payloads with quandary= Some quandary_payload}
-
-
-    let of_payloads (payloads : Payloads.t) = payloads.quandary
   end)
 
   module Domain = TaintDomain

opam

@@ -42,6 +42,7 @@ depends: [
   "ounit" {>="2.0.5"}
   "parmap" {>="1.0-rc8"}
   "ppx_deriving" {>="4.1"}
+  "ppx_fields_conv" {">=v0.11.0" & < "v0.12"}
   "sawja" {>="1.5.4"}
   "sqlite3"
   "utop" {with-test}

scripts/toplevel_init

@@ -11,6 +11,7 @@
 #require "ctypes.stubs";;
 #require "ocamlgraph";;
 #require "ppx_compare";;
+#require "ppx_fields_conv";;
 #require "sawja";;
 #require "sqlite3";;
 #require "xmlm";;