[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

@@ -9,7 +9,7 @@ build: [
   [make "-C" "sledge" "release"]
 ]
 depends: [
-  "ocaml"
+  "ocaml" {>= "4.12.0"}
   "apron" {>= "v0.9.13"}
   "base"
   "containers"

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 = evar ~loc:Location.none "Stdlib.__FUNCTION__" in
-        let fun_name =
+        (Nolabel, fun_name) :: args
-          estring ~loc:Location.none (get_fun_name (vb_stack_top ()))
-        in
-        (Nolabel, mod_name) :: (Nolabel, fun_name) :: args
       in
       match exp.pexp_desc with
       | Pexp_apply

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 =
+(** split a string such as
-  let rec index s i =
+    [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]) then mod_name_start_ s (i - 1)
-    else if not (Char.equal '_' s.[i - 1]) then index s (i - 2)
+    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
+  let mod_name_start =
-  | Some pos -> String.subo s ~pos
+    match mod_name_start_ s (mod_name_end - 2) with
-  | None -> s
+    | 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 =
+let kprintf mod_fun_name k fmt =
-  if enabled mod_name fun_name then Format.kfprintf k fs 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 =
+let fprintf mod_fun_name fs fmt =
-  if enabled mod_name fun_name then Format.fprintf 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 =
+let info mod_fun_name fmt =
-  if enabled mod_name fun_name then (
+  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 =
+let infok mod_fun_name k = k {pf= (fun fmt -> info mod_fun_name fmt)}
-  k {pf= (fun fmt -> info mod_name fun_name fmt)}
 
-let incf mod_name fun_name fmt =
+let incf mod_fun_name fmt =
-  if not (enabled mod_name fun_name) then Format.ifprintf fs fmt
+  if not (enabled mod_fun_name) then Format.ifprintf fs fmt
-  else (
+  else
+    let _, fun_name = split_mod_fun_name mod_fun_name in
     Format.fprintf fs "@\n@[<2>@[<hv 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 =
+let decf mod_fun_name fmt =
-  if not (enabled mod_name fun_name) then Format.ifprintf fs fmt
+  if not (enabled mod_fun_name) then Format.ifprintf fs fmt
-  else (
+  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 =
+let call mod_fun_name k = k {pf= (fun fmt -> incf mod_fun_name fmt)}
-  k {pf= (fun fmt -> incf mod_name fun_name fmt)}
 
-let retn mod_name fun_name k result =
+let retn mod_fun_name k result =
-  k {pf= (fun fmt -> decf mod_name fun_name fmt)} 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 =

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
+(** [trace ~call ~retn ~rais function_name k] either simply invokes [k ()],
-    [k ()], when not enabled, or else increases the indentation level and
+    when not enabled, or else increases the indentation level and emits the
-    emits the [call] message, then invokes [k ()], then decreases the
+    [call] message, then invokes [k ()], then decreases the indentation
-    indentation level and either emits the [retn] or [rais] message,
+    level and either emits the [retn] or [rais] message, depending on
-    depending on whether [k ()] returned normally or exceptionally. *)
+    whether [k ()] returned normally or exceptionally. *)
 
 val flush : unit -> unit
 (** Flush the internal buffers. *)