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

[sledge] Update trace and ppx_trace

Browse Source 
Reviewed By: mbouaziz

Differential Revision: D9846738

fbshipit-source-id: 14adee4c4
master
Josh Berdine 6 years ago committed by Facebook Github Bot
parent 91888c4c41
commit 6a7c21e7c9
3 changed files with 92 additions and 50 deletions
Show Stats Download Patch File Download Diff File

17
sledge/src/ppx_trace/ppx_trace.ml
Unescape View File

@ -20,8 +20,8 @@
For example, this enables writing
[[%Trace.call fun pf -> pf "%a" fmt_arg_type arg] ; f arg |>
[%Trace.retn fun pf -> pf "%a" fmt_result_type]]
[%Trace.call fun {pf} -> pf "%a" pp_arg_type arg] ; func arg |>
[%Trace.retn fun {pf} -> pf "%a" pp_result_type]
to trace calls to [f] in debug mode while completely compiling out the
debug code in non-debug builds.
@ -32,14 +32,14 @@
Additionally, [[%debug]] is rewritten to the compile-time boolean
constant determined by whether or not [--debug] is passed. *)
open Ppx_core
open Ppxlib
open Ast_builder.Default
module Ast_mapper = Selected_ast.Ast.Ast_mapper
let debug = ref false
;;
Ppx_driver.add_arg "--debug" (Caml.Arg.Set debug)
Driver.add_arg "--debug" (Caml.Arg.Set debug)
~doc:"Enable debug tracing output"
let rec get_fun_name pat =
@ -54,19 +54,17 @@ let rec get_fun_name pat =
(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_exn !stack ;
stack := List.tl !stack ;
r
in
let top () = List.hd_exn !stack in
let top () = List.hd !stack in
(with_, top)
let mapper =
let value_binding (m : Ast_mapper.mapper) vb =
vb_stack_with vb.pvb_pat ~f:(fun () ->
@ -115,8 +113,7 @@ let mapper =
in
{Ast_mapper.default_mapper with expr; value_binding}
let impl = Selected_ast.Ast.map_structure mapper
;;
Ppx_driver.register_transformation "trace" ~impl
Driver.register_transformation "trace" ~impl

101
sledge/src/trace/trace.ml
Unescape View File

@ -7,52 +7,81 @@
(** Debug trace logging *)
type 'a printf = ('a, Format.formatter, unit) format -> 'a
type 'a printf = ('a, Formatter.t, unit) format -> 'a
type pf = {pf: 'a. 'a printf}
let ff = Format.err_formatter
let fs = Format.err_formatter
let flush = Format.pp_print_newline fs
let flush = Format.pp_print_newline ff
type trace_mod_funs =
{trace_mod: bool option; trace_funs: bool Map.M(String).t}
let margin = 100
type config =
{trace_all: bool; trace_mods_funs: trace_mod_funs Map.M(String).t}
let trace_all = ref false
let config : config ref =
ref {trace_all= false; trace_mods_funs= Map.empty (module String)}
let init ~trace_all:ta =
let init ?(margin = 160) ~config:c () =
Format.set_margin margin ;
Format.set_max_indent (margin - 1) ;
Format.pp_set_margin ff margin ;
Format.pp_set_max_indent ff (margin - 1) ;
Format.pp_open_vbox ff 0 ;
Format.pp_set_margin fs margin ;
Format.pp_set_max_indent fs (margin - 1) ;
Format.pp_open_vbox fs 0 ;
Caml.at_exit flush ;
trace_all := ta
(* selective tracing not yet implemented *)
let enabled _ = !trace_all
config := c
let unwrap s =
let rec index 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 Some (i + 1)
in
match index s (String.length s - 2) with
| Some pos -> String.subo s ~pos
| None -> s
let enabled mod_name fun_name =
let {trace_all; trace_mods_funs} = !config in
match Map.find trace_mods_funs (unwrap mod_name) with
| Some {trace_mod; trace_funs} -> (
match Map.find trace_funs fun_name with
| Some fun_enabled -> fun_enabled
| None -> (
match trace_mod with
| Some mod_enabled -> mod_enabled
| None -> trace_all ) )
| None -> trace_all
let info mod_name fun_name fmt =
if enabled [fun_name; mod_name] then (
Format.fprintf ff "@\n@[<2>| " ;
Format.kfprintf (fun ff -> Format.fprintf ff "@]") ff fmt )
else Format.ifprintf ff fmt
let incf rev_prefix name fmt =
if enabled (name :: rev_prefix) then (
Format.fprintf ff "@\n@[<2>@[( %s: " name ;
Format.kfprintf (fun ff -> Format.fprintf ff "@]") ff fmt )
else Format.ifprintf ff fmt
let decf rev_prefix name fmt =
if enabled (name :: rev_prefix) then (
Format.fprintf ff "@]@\n@[<2>) %s:@ " name ;
Format.kfprintf (fun ff -> Format.fprintf ff "@]") ff fmt )
else Format.ifprintf ff fmt
let call mod_name fun_name k = k (incf [mod_name] fun_name)
if enabled mod_name fun_name then (
Format.fprintf fs "@\n@[<2>| " ;
Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt )
else Format.ifprintf fs fmt
let incf mod_name fun_name fmt =
if enabled mod_name fun_name then (
Format.fprintf fs "@\n@[<2>@[<hv 2>( %s:@ " fun_name ;
Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt )
else Format.ifprintf fs fmt
let decf mod_name fun_name fmt =
if enabled mod_name fun_name then (
Format.fprintf fs "@]@\n@[<2>) %s:@ " fun_name ;
Format.kfprintf (fun fs -> Format.fprintf fs "@]") fs fmt )
else Format.ifprintf fs fmt
let call mod_name fun_name k =
k {pf= (fun fmt -> incf mod_name fun_name fmt)}
let retn mod_name fun_name k result =
k (decf [mod_name] fun_name) result ;
k {pf= (fun fmt -> decf mod_name fun_name fmt)} result ;
result
let report fmt =
Format.fprintf fs "@\n@[<2>| " ;
Format.kfprintf (fun fs -> Format.fprintf fs "@]" ; false) fs fmt
let%test_module _ =
(module struct let () = init ~margin:70 ~config:!config () end)

24
sledge/src/trace/trace.mli
Unescape View File

@ -7,19 +7,35 @@
(** Debug trace logging *)
val init : trace_all:bool -> unit
(** Tracing configuration for a toplevel module. *)
type trace_mod_funs =
{ trace_mod: bool option
(** Enable/disable tracing of all functions in module *)
; trace_funs: bool Map.M(String).t
(** Enable/disable tracing of individual functions *) }
type config =
{ trace_all: bool (** Enable all tracing *)
; trace_mods_funs: trace_mod_funs Map.M(String).t
(** Specify tracing of individual toplevel modules *) }
val init : ?margin:int -> config:config -> unit -> unit
(** Initialize the configuration of debug tracing. *)
type 'a printf = ('a, Format.formatter, unit) format -> 'a
type 'a printf = ('a, Formatter.t, unit) format -> 'a
type pf = {pf: 'a. 'a printf}
val info : string -> string -> 'a printf
(** Emit a message at the current indentation level, if enabled. *)
val call : string -> string -> ('a printf -> 'b) -> 'b
val call : string -> string -> (pf -> 'b) -> 'b
(** Increase indentation level and emit a message, if enabled. *)
val retn : string -> string -> ('a printf -> 'b -> unit) -> 'b -> 'b
val retn : string -> string -> (pf -> 'b -> unit) -> 'b -> 'b
(** Decrease indentation level and emit a message, if enabled. *)
val flush : unit -> unit
(** Flush the internal buffers. *)
val report : ('a, Formatter.t, unit, bool) format4 -> 'a
(** Emit a message at the current indentation level, and return [false]. *)

Write Preview
Loading…
Cancel
Save