diff --git a/infer/src/backend/Payloads.ml b/infer/src/backend/Payloads.ml index fcb5def73..97fda6321 100644 --- a/infer/src/backend/Payloads.ml +++ b/infer/src/backend/Payloads.ml @@ -27,56 +27,36 @@ type t = ; uninit: UninitDomain.Summary.t option } [@@deriving fields] -let pp pe fmt - { annot_map - ; biabduction - ; buffer_overrun_analysis - ; buffer_overrun_checker - ; class_loads - ; cost - ; lab_resource_leaks - ; litho - ; pulse - ; purity - ; quandary - ; racerd - ; siof - ; starvation - ; typestate - ; uninit } = - let pp_opt prefix pp fmt = function - | Some x -> - F.fprintf fmt "%s: %a@\n" prefix pp x - | None -> - () - in - F.fprintf fmt "%a%a%a%a%a%a%a%a%a%a%a%a%a%a%a%a@\n" - (pp_opt "AnnotationReachability" AnnotReachabilityDomain.pp) - annot_map - (pp_opt "Biabduction" (BiabductionSummary.pp pe)) - biabduction - (pp_opt "BufferOverrunAnalysis" BufferOverrunAnalysisSummary.pp) - buffer_overrun_analysis - (pp_opt "BufferOverrunChecker" BufferOverrunCheckerSummary.pp) - buffer_overrun_checker - (pp_opt "ClassLoads" ClassLoadsDomain.pp_summary) - class_loads - (pp_opt "Cost" CostDomain.pp_summary) - cost (pp_opt "Litho" LithoDomain.pp) litho (pp_opt "Pulse" PulseSummary.pp) pulse - (pp_opt "Purity" PurityDomain.pp_summary) - purity - (pp_opt "Quandary" QuandarySummary.pp) - quandary - (pp_opt "RacerD" RacerDDomain.pp_summary) - racerd - (pp_opt "Resource Leaks Lab" ResourceLeakDomain.pp) - lab_resource_leaks - (pp_opt "Siof" SiofDomain.Summary.pp) - siof - (pp_opt "Starvation" StarvationDomain.pp_summary) - starvation (pp_opt "TypeState" TypeState.pp) typestate - (pp_opt "Uninitialised" UninitDomain.Summary.pp) - uninit +type 'a pp = Pp.env -> F.formatter -> 'a -> unit + +type field = F : {field: (t, 'a option) Field.t; name: string; pp: 'a pp} -> field + +let fields = + let mk field name pp = F {field; name; pp= (fun _ -> pp)} in + let mk_pe field name pp = F {field; name; pp} in + Fields.to_list + ~annot_map:(fun f -> mk f "AnnotationReachability" AnnotReachabilityDomain.pp) + ~biabduction:(fun f -> mk_pe f "Biabduction" BiabductionSummary.pp) + ~buffer_overrun_analysis:(fun f -> mk f "BufferOverrunAnalysis" BufferOverrunAnalysisSummary.pp) + ~buffer_overrun_checker:(fun f -> mk f "BufferOverrunChecker" BufferOverrunCheckerSummary.pp) + ~class_loads:(fun f -> mk f "ClassLoads" ClassLoadsDomain.pp_summary) + ~cost:(fun f -> mk f "Cost" CostDomain.pp_summary) + ~litho:(fun f -> mk f "Litho" LithoDomain.pp) + ~pulse:(fun f -> mk f "Pulse" PulseSummary.pp) + ~purity:(fun f -> mk f "Purity" PurityDomain.pp_summary) + ~quandary:(fun f -> mk f "Quandary" QuandarySummary.pp) + ~racerd:(fun f -> mk f "RacerD" RacerDDomain.pp_summary) + ~lab_resource_leaks:(fun f -> mk f "Resource Leaks Lab" ResourceLeakDomain.pp) + ~siof:(fun f -> mk f "Siof" SiofDomain.Summary.pp) + ~starvation:(fun f -> mk f "Starvation" StarvationDomain.pp_summary) + ~typestate:(fun f -> mk f "TypeState" TypeState.pp) + ~uninit:(fun f -> mk f "Uninitialised" UninitDomain.Summary.pp) + + +let pp pe f payloads = + List.iter fields ~f:(fun (F {field; name; pp}) -> + Field.get field payloads |> Option.iter ~f:(fun x -> F.fprintf f "%s: %a@\n" name (pp pe) x) + ) let empty =