pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

[sledge] Simplify ppx_trace using Stdlib.__FUNCTION__

Browse Source 
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
master
Josh Berdine 4 years ago committed by Facebook GitHub Bot
parent 673c944fc3
commit 6ad7bbe7f1
4 changed files with 75 additions and 80 deletions
Show Stats Download Patch File Download Diff File

2
opam/sledge.opam
Unescape View File

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

33
sledge/ppx_trace/ppx_trace.ml
Unescape View File

@ -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

95
sledge/ppx_trace/trace/trace.ml
Unescape View File

@ -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>@[<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 =
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 =

25
sledge/ppx_trace/trace/trace.mli
Unescape View File

@ -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. *)

Write Preview
Loading…
Cancel
Save