From 9d2e9102add85ab220d1cd7fc039743a957d58e5 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 24 Apr 2019 01:38:33 -0700 Subject: [PATCH] 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 | 12 +++++++----- infer/src/absint/SummaryPayload.mli | 6 +----- infer/src/backend/Payloads.ml | 1 + infer/src/backend/Payloads.mli | 1 + infer/src/bufferoverrun/bufferOverrunAnalysis.ml | 6 +----- infer/src/bufferoverrun/bufferOverrunChecker.ml | 6 +----- infer/src/checkers/Litho.ml | 4 +--- infer/src/checkers/Siof.ml | 4 +--- infer/src/checkers/annotationReachability.ml | 4 +--- infer/src/checkers/classLoads.ml | 4 +--- infer/src/checkers/cost.ml | 4 +--- infer/src/checkers/purity.ml | 4 +--- infer/src/checkers/uninit.ml | 4 +--- infer/src/concurrency/RacerD.ml | 4 +--- infer/src/concurrency/starvation.ml | 4 +--- infer/src/deadcode/dune.in | 2 +- infer/src/dune.in | 6 +++--- infer/src/labs/00_dummy_checker/ResourceLeaks.ml | 6 +----- infer/src/labs/01_integer_domain/ResourceLeaks.ml | 6 +----- infer/src/labs/02_domain_join/ResourceLeaks.ml | 6 +----- infer/src/labs/03_domain_top/ResourceLeaks.ml | 6 +----- infer/src/labs/04_interprocedural/ResourceLeaks.ml | 6 +----- .../05_access_paths_interprocedural/ResourceLeaks.ml | 6 +----- infer/src/labs/ResourceLeaks.ml | 6 +----- infer/src/pulse/Pulse.ml | 4 +--- infer/src/quandary/TaintAnalysis.ml | 6 +----- opam | 1 + scripts/toplevel_init | 1 + 28 files changed, 36 insertions(+), 94 deletions(-) diff --git a/infer/src/absint/SummaryPayload.ml b/infer/src/absint/SummaryPayload.ml index d80f484d1..094b893c8 100644 --- a/infer/src/absint/SummaryPayload.ml +++ b/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 of_payloads : Payloads.t -> t option + val field : (Payloads.t, t option) Field.t 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 diff --git a/infer/src/absint/SummaryPayload.mli b/infer/src/absint/SummaryPayload.mli index 4be1467a1..9a224b883 100644 --- a/infer/src/absint/SummaryPayload.mli +++ b/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 - (** Update the corresponding part of the payloads *) - - val of_payloads : Payloads.t -> t option - (** Read the corresponding part of the payloads *) + val field : (Payloads.t, t option) Field.t end module type S = sig diff --git a/infer/src/backend/Payloads.ml b/infer/src/backend/Payloads.ml index b0ae3e3b4..fcb5def73 100644 --- a/infer/src/backend/Payloads.ml +++ b/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 diff --git a/infer/src/backend/Payloads.mli b/infer/src/backend/Payloads.mli index 2e52c85e5..81d757ff7 100644 --- a/infer/src/backend/Payloads.mli +++ b/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 diff --git a/infer/src/bufferoverrun/bufferOverrunAnalysis.ml b/infer/src/bufferoverrun/bufferOverrunAnalysis.ml index 63ec0b96e..4bac26566 100644 --- a/infer/src/bufferoverrun/bufferOverrunAnalysis.ml +++ b/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) = - {payloads with buffer_overrun_analysis= Some astate} - - - let of_payloads (payloads : Payloads.t) = payloads.buffer_overrun_analysis + let field = Payloads.Fields.buffer_overrun_analysis end) type summary_and_formals = BufferOverrunAnalysisSummary.t * (Pvar.t * Typ.t) list diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index cb5d37a68..d25fae443 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/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) = - {payloads with buffer_overrun_checker= Some astate} - - - let of_payloads (payloads : Payloads.t) = payloads.buffer_overrun_checker + let field = Payloads.Fields.buffer_overrun_checker end) module UnusedBranch = struct diff --git a/infer/src/checkers/Litho.ml b/infer/src/checkers/Litho.ml index a843f2502..aade31137 100644 --- a/infer/src/checkers/Litho.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.litho + let field = Payloads.Fields.litho end) module LithoFramework = struct diff --git a/infer/src/checkers/Siof.ml b/infer/src/checkers/Siof.ml index 6ecf73ee2..03ec05cde 100644 --- a/infer/src/checkers/Siof.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.siof + let field = Payloads.Fields.siof end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/checkers/annotationReachability.ml b/infer/src/checkers/annotationReachability.ml index d63c46e25..91e9d4a01 100644 --- a/infer/src/checkers/annotationReachability.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.annot_map + let field = Payloads.Fields.annot_map end) let is_modeled_expensive tenv = function diff --git a/infer/src/checkers/classLoads.ml b/infer/src/checkers/classLoads.ml index 3ed916613..44403168b 100644 --- a/infer/src/checkers/classLoads.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.class_loads + let field = Payloads.Fields.class_loads end) let do_call pdesc callee loc init = diff --git a/infer/src/checkers/cost.ml b/infer/src/checkers/cost.ml index b8f26bc10..b383ebb1d 100644 --- a/infer/src/checkers/cost.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.cost + let field = Payloads.Fields.cost end) (* We use this threshold to give error if the cost is above it. diff --git a/infer/src/checkers/purity.ml b/infer/src/checkers/purity.ml index c59fbb412..73df96076 100644 --- a/infer/src/checkers/purity.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.purity + let field = Payloads.Fields.purity end) type purity_extras = diff --git a/infer/src/checkers/uninit.ml b/infer/src/checkers/uninit.ml index f35391076..6a74750e1 100644 --- a/infer/src/checkers/uninit.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.uninit + let field = Payloads.Fields.uninit end) module Models = struct diff --git a/infer/src/concurrency/RacerD.ml b/infer/src/concurrency/RacerD.ml index 4ca9a8809..eaa3c216f 100644 --- a/infer/src/concurrency/RacerD.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.racerd + let field = Payloads.Fields.racerd end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/concurrency/starvation.ml b/infer/src/concurrency/starvation.ml index 5890d2958..9dc7f63e5 100644 --- a/infer/src/concurrency/starvation.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.starvation + let field = Payloads.Fields.starvation end) (* using an indentifier for a class object, create an access path representing that lock; diff --git a/infer/src/deadcode/dune.in b/infer/src/deadcode/dune.in index 5ab554e5d..05fb2563d 100644 --- a/infer/src/deadcode/dune.in +++ b/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) diff --git a/infer/src/dune.in b/infer/src/dune.in index afa680532..2ec802c3a 100644 --- a/infer/src/dune.in +++ b/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)) ) |} diff --git a/infer/src/labs/00_dummy_checker/ResourceLeaks.ml b/infer/src/labs/00_dummy_checker/ResourceLeaks.ml index 26a33f901..620f53e9a 100644 --- a/infer/src/labs/00_dummy_checker/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/labs/01_integer_domain/ResourceLeaks.ml b/infer/src/labs/01_integer_domain/ResourceLeaks.ml index 558a0a19f..0dfb171e4 100644 --- a/infer/src/labs/01_integer_domain/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/labs/02_domain_join/ResourceLeaks.ml b/infer/src/labs/02_domain_join/ResourceLeaks.ml index 558a0a19f..0dfb171e4 100644 --- a/infer/src/labs/02_domain_join/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/labs/03_domain_top/ResourceLeaks.ml b/infer/src/labs/03_domain_top/ResourceLeaks.ml index 558a0a19f..0dfb171e4 100644 --- a/infer/src/labs/03_domain_top/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/labs/04_interprocedural/ResourceLeaks.ml b/infer/src/labs/04_interprocedural/ResourceLeaks.ml index cba985c20..272685e36 100644 --- a/infer/src/labs/04_interprocedural/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/labs/05_access_paths_interprocedural/ResourceLeaks.ml b/infer/src/labs/05_access_paths_interprocedural/ResourceLeaks.ml index bafc8af34..16b6e7306 100644 --- a/infer/src/labs/05_access_paths_interprocedural/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/labs/ResourceLeaks.ml b/infer/src/labs/ResourceLeaks.ml index 36c14cfef..fda4bc86f 100644 --- a/infer/src/labs/ResourceLeaks.ml +++ b/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) = - {payloads with lab_resource_leaks= Some resources_payload} - - - let of_payloads {Payloads.lab_resource_leaks} = lab_resource_leaks + let field = Payloads.Fields.lab_resource_leaks end) module TransferFunctions (CFG : ProcCfg.S) = struct diff --git a/infer/src/pulse/Pulse.ml b/infer/src/pulse/Pulse.ml index 616f9aa2e..68a84aad7 100644 --- a/infer/src/pulse/Pulse.ml +++ b/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 of_payloads (payloads : Payloads.t) = payloads.pulse + let field = Payloads.Fields.pulse end) module PulseTransferFunctions = struct diff --git a/infer/src/quandary/TaintAnalysis.ml b/infer/src/quandary/TaintAnalysis.ml index e0ee63b4c..5a9f79079 100644 --- a/infer/src/quandary/TaintAnalysis.ml +++ b/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) = - {payloads with quandary= Some quandary_payload} - - - let of_payloads (payloads : Payloads.t) = payloads.quandary + let field = Payloads.Fields.quandary end) module Domain = TaintDomain diff --git a/opam b/opam index 193840cea..730a6f0ae 100644 --- a/opam +++ b/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} diff --git a/scripts/toplevel_init b/scripts/toplevel_init index 4fb86cc80..7d918e607 100644 --- a/scripts/toplevel_init +++ b/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";;