From 6ad7bbe7f15a8247d53e6fd3a74c309d42d96bd2 Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Mon, 29 Mar 2021 14:00:07 -0700 Subject: [PATCH] [sledge] Simplify ppx_trace using Stdlib.__FUNCTION__ Summary: OCaml 4.12 added ``` val __FUNCTION__ : string __FUNCTION__ returns the name of the current function or method, including any enclosing modules or classes. ``` This diff simplifies ppx_trace using `__FUNCTION__` to obtain the name of the function containing each call to a `Trace` function. Before this diff this is done by maintaining a stack of function names obtained by parsing value binding patterns during preprocessing. This technique is not entirely robust and does not deal with some cases (if calls to `Trace` functions appear in some places, preprocessing fails with an exception). Reviewed By: jvillard Differential Revision: D27396915 fbshipit-source-id: da7aa2945 --- opam/sledge.opam | 2 +- sledge/ppx_trace/ppx_trace.ml | 33 +---------- sledge/ppx_trace/trace/trace.ml | 95 ++++++++++++++++++++------------ sledge/ppx_trace/trace/trace.mli | 25 ++++----- 4 files changed, 75 insertions(+), 80 deletions(-) diff --git a/opam/sledge.opam b/opam/sledge.opam index c75ee4be1..65cf748bc 100644 --- a/opam/sledge.opam +++ b/opam/sledge.opam @@ -9,7 +9,7 @@ build: [ [make "-C" "sledge" "release"] ] depends: [ - "ocaml" + "ocaml" {>= "4.12.0"} "apron" {>= "v0.9.13"} "base" "containers" diff --git a/sledge/ppx_trace/ppx_trace.ml b/sledge/ppx_trace/ppx_trace.ml index 808b7e3f6..7352c6a47 100644 --- a/sledge/ppx_trace/ppx_trace.ml +++ b/sledge/ppx_trace/ppx_trace.ml @@ -80,29 +80,6 @@ let debug_rule = Context_free.Rule.extension debug_extension ;; Driver.register_transformation ~rules:[debug_rule] "debug" -let rec get_fun_name pat = - match pat.ppat_desc with - | Ppat_var {txt; _} -> txt - | Ppat_alias (pat, _) | Ppat_constraint (pat, _) -> get_fun_name pat - | _ -> - Location.raise_errorf ~loc:pat.ppat_loc - "Unexpected pattern in binding containing [%%Trace]: %a" - (fun f p -> - Ocaml_common.Pprintast.pattern f - (Selected_ast.To_ocaml.copy_pattern p) ) - pat - -let vb_stack_with, vb_stack_top = - let stack = ref [] in - let with_ x ~f = - stack := x :: !stack ; - let r = f () in - stack := List.tl !stack ; - r - in - let top () = List.hd !stack in - (with_, top) - (* (fun x -> x) *) let fun_id loc = pexp_fun ~loc Nolabel None (pvar ~loc "x") (evar ~loc "x") @@ -115,16 +92,10 @@ let mapper = object inherit Ast_traverse.map as super - method! value_binding vb = - vb_stack_with vb.pvb_pat ~f:(fun () -> super#value_binding vb) - method! expression exp = let append_here_args args = - let mod_name = evar ~loc:Location.none "Stdlib.__MODULE__" in - let fun_name = - estring ~loc:Location.none (get_fun_name (vb_stack_top ())) - in - (Nolabel, mod_name) :: (Nolabel, fun_name) :: args + let fun_name = evar ~loc:Location.none "Stdlib.__FUNCTION__" in + (Nolabel, fun_name) :: args in match exp.pexp_desc with | Pexp_apply diff --git a/sledge/ppx_trace/trace/trace.ml b/sledge/ppx_trace/trace/trace.ml index 63458cbab..ea87f598e 100644 --- a/sledge/ppx_trace/trace/trace.ml +++ b/sledge/ppx_trace/trace/trace.ml @@ -132,20 +132,46 @@ let init ?(colors = false) ?(margin = 240) ?config:(c = none) () = at_exit flush ; config := {c with colors} -let unwrap s = - let rec index s i = +(** split a string such as + [Dune__exe__Module.Submodule.Subsubmodule.function.subfunction] into + [(Module, function.subfunction)] *) +let split_mod_fun_name s = + let fun_name_end = String.length s in + let rec fun_name_start_ s i = + match String.rindex_from_opt s i '.' with + | Some j -> + if Char.is_uppercase s.[j + 1] then fun_name_start_ s j else j + 1 + | None -> 0 + in + let fun_name_start = fun_name_start_ s (fun_name_end - 1) in + let fun_name = + String.sub s ~pos:fun_name_start ~len:(fun_name_end - fun_name_start) + in + let mod_name_end = + match String.index_from_opt s 0 '.' with + | Some i -> i + | None -> fun_name_end + in + let rec mod_name_start_ s i = if i <= 1 then None - else if not (Char.equal '_' s.[i]) then index s (i - 1) - else if not (Char.equal '_' s.[i - 1]) then index s (i - 2) + else if not (Char.equal '_' s.[i]) then mod_name_start_ s (i - 1) + else if not (Char.equal '_' s.[i - 1]) then mod_name_start_ s (i - 2) else Some (i + 1) in - match index s (String.length s - 2) with - | Some pos -> String.subo s ~pos - | None -> s + let mod_name_start = + match mod_name_start_ s (mod_name_end - 2) with + | Some pos -> pos + | None -> 0 + in + let mod_name = + String.sub s ~pos:mod_name_start ~len:(mod_name_end - mod_name_start) + in + (mod_name, fun_name) -let enabled mod_name fun_name = +let enabled mod_fun_name = + let mod_name, fun_name = split_mod_fun_name mod_fun_name in let {trace_all; trace_mods_funs; _} = !config in - match Map.find (unwrap mod_name) trace_mods_funs with + match Map.find mod_name trace_mods_funs with | {trace_mod; trace_funs} -> ( try Map.find fun_name trace_funs with Not_found -> ( @@ -154,42 +180,42 @@ let enabled mod_name fun_name = | None -> trace_all ) ) | exception Not_found -> trace_all -let kprintf mod_name fun_name k fmt = - if enabled mod_name fun_name then Format.kfprintf k fs fmt +let kprintf mod_fun_name k fmt = + if enabled mod_fun_name then Format.kfprintf k fs fmt else Format.ifprintf fs fmt -let fprintf mod_name fun_name fs fmt = - if enabled mod_name fun_name then Format.fprintf fs fmt +let fprintf mod_fun_name fs fmt = + if enabled mod_fun_name then Format.fprintf fs fmt else Format.ifprintf fs fmt -let printf mod_name fun_name fmt = fprintf mod_name fun_name fs fmt +let printf mod_fun_name fmt = fprintf mod_fun_name fs fmt -let info mod_name fun_name fmt = - if enabled mod_name fun_name then ( +let info mod_fun_name fmt = + if enabled mod_fun_name then ( Format.fprintf fs "@\n@[<2>| " ; Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt ) else Format.ifprintf fs fmt -let infok mod_name fun_name k = - k {pf= (fun fmt -> info mod_name fun_name fmt)} +let infok mod_fun_name k = k {pf= (fun fmt -> info mod_fun_name fmt)} -let incf mod_name fun_name fmt = - if not (enabled mod_name fun_name) then Format.ifprintf fs fmt - else ( +let incf mod_fun_name fmt = + if not (enabled mod_fun_name) then Format.ifprintf fs fmt + else + let _, fun_name = split_mod_fun_name mod_fun_name in Format.fprintf fs "@\n@[<2>@[( %s:" fun_name ; - Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt ) + Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt -let decf mod_name fun_name fmt = - if not (enabled mod_name fun_name) then Format.ifprintf fs fmt - else ( +let decf mod_fun_name fmt = + if not (enabled mod_fun_name) then Format.ifprintf fs fmt + else + let _, fun_name = split_mod_fun_name mod_fun_name in Format.fprintf fs "@]@\n@[<2>) %s:@ " fun_name ; - Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt ) + Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt -let call mod_name fun_name k = - k {pf= (fun fmt -> incf mod_name fun_name fmt)} +let call mod_fun_name k = k {pf= (fun fmt -> incf mod_fun_name fmt)} -let retn mod_name fun_name k result = - k {pf= (fun fmt -> decf mod_name fun_name fmt)} result ; +let retn mod_fun_name k result = + k {pf= (fun fmt -> decf mod_fun_name fmt)} result ; result let trace : @@ -197,24 +223,23 @@ let trace : -> ?retn:(pf -> 'a -> unit) -> ?rais:(pf -> exn -> Printexc.raw_backtrace -> unit) -> string - -> string -> (unit -> 'a) -> 'a = - fun ?call ?retn ?rais mod_name fun_name k -> + fun ?call ?retn ?rais mod_fun_name k -> let call = Option.value call ~default:(fun {pf} -> pf "") in let retn = Option.value retn ~default:(fun {pf} _ -> pf "") in let rais = Option.value rais ~default:(fun {pf} exc _ -> pf "%s" (Printexc.to_string exc) ) in - call {pf= (fun fmt -> incf mod_name fun_name fmt)} ; + call {pf= (fun fmt -> incf mod_fun_name fmt)} ; match k () with | result -> - retn {pf= (fun fmt -> decf mod_name fun_name fmt)} result ; + retn {pf= (fun fmt -> decf mod_fun_name fmt)} result ; result | exception exc -> let bt = Printexc.get_raw_backtrace () in - rais {pf= (fun fmt -> decf mod_name fun_name fmt)} exc bt ; + rais {pf= (fun fmt -> decf mod_fun_name fmt)} exc bt ; Printexc.raise_with_backtrace exc bt let raisef ?margin exn fmt = diff --git a/sledge/ppx_trace/trace/trace.mli b/sledge/ppx_trace/trace/trace.mli index 7bae592c3..80b501f18 100644 --- a/sledge/ppx_trace/trace/trace.mli +++ b/sledge/ppx_trace/trace/trace.mli @@ -24,25 +24,25 @@ val pp_styled : [`Bold | `Cyan | `Magenta] -> ('a, unit) fmt -> Format.formatter -> 'a (** If config.colors is set to true, print in the specified color *) -val printf : string -> string -> 'a printf +val printf : string -> 'a printf (** Like [Format.printf], if enabled, otherwise like [Format.iprintf]. *) -val fprintf : string -> string -> Format.formatter -> 'a printf +val fprintf : string -> Format.formatter -> 'a printf (** Like [Format.fprintf], if enabled, otherwise like [Format.ifprintf]. *) -val kprintf : string -> string -> (Format.formatter -> unit) -> 'a printf +val kprintf : string -> (Format.formatter -> unit) -> 'a printf (** Like [Format.kprintf], if enabled, otherwise like [Format.ifprintf]. *) -val info : string -> string -> 'a printf +val info : string -> 'a printf (** Emit a message at the current indentation level, if enabled. *) -val infok : string -> string -> (pf -> 'a) -> 'a +val infok : string -> (pf -> 'a) -> 'a (** Emit a message at the current indentation level, if enabled. *) -val call : string -> string -> (pf -> 'a) -> 'a +val call : string -> (pf -> 'a) -> 'a (** Increase indentation level and emit a message, if enabled. *) -val retn : string -> string -> (pf -> 'a -> unit) -> 'a -> 'a +val retn : string -> (pf -> 'a -> unit) -> 'a -> 'a (** Decrease indentation level and emit a message, if enabled. *) val trace : @@ -50,14 +50,13 @@ val trace : -> ?retn:(pf -> 'a -> unit) -> ?rais:(pf -> exn -> Printexc.raw_backtrace -> unit) -> string - -> string -> (unit -> 'a) -> 'a -(** [trace ~call ~retn ~rais mod_name fun_name k] either simply invokes - [k ()], when not enabled, or else increases the indentation level and - emits the [call] message, then invokes [k ()], then decreases the - indentation level and either emits the [retn] or [rais] message, - depending on whether [k ()] returned normally or exceptionally. *) +(** [trace ~call ~retn ~rais function_name k] either simply invokes [k ()], + when not enabled, or else increases the indentation level and emits the + [call] message, then invokes [k ()], then decreases the indentation + level and either emits the [retn] or [rais] message, depending on + whether [k ()] returned normally or exceptionally. *) val flush : unit -> unit (** Flush the internal buffers. *)