From 6a7c21e7c9cd23b5ba7416ed6587baf984c1253f Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Fri, 12 Oct 2018 09:03:58 -0700 Subject: [PATCH] [sledge] Update trace and ppx_trace Reviewed By: mbouaziz Differential Revision: D9846738 fbshipit-source-id: 14adee4c4 --- sledge/src/ppx_trace/ppx_trace.ml | 17 +++-- sledge/src/trace/trace.ml | 101 +++++++++++++++++++----------- sledge/src/trace/trace.mli | 24 +++++-- 3 files changed, 92 insertions(+), 50 deletions(-) diff --git a/sledge/src/ppx_trace/ppx_trace.ml b/sledge/src/ppx_trace/ppx_trace.ml index 55b7bd015..a567e750d 100644 --- a/sledge/src/ppx_trace/ppx_trace.ml +++ b/sledge/src/ppx_trace/ppx_trace.ml @@ -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 diff --git a/sledge/src/trace/trace.ml b/sledge/src/trace/trace.ml index 43c5500af..85833d8b6 100644 --- a/sledge/src/trace/trace.ml +++ b/sledge/src/trace/trace.ml @@ -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>@[( %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) diff --git a/sledge/src/trace/trace.mli b/sledge/src/trace/trace.mli index 4409cbb41..5fa008037 100644 --- a/sledge/src/trace/trace.mli +++ b/sledge/src/trace/trace.mli @@ -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]. *)