mirror of
https://github.com/ocaml-tracing/ocaml-trace.git
synced 2026-03-09 12:23:32 -04:00
114 lines
3.6 KiB
OCaml
114 lines
3.6 KiB
OCaml
open Ppxlib
|
|
|
|
let location_errorf ~loc fmt =
|
|
Format.kasprintf
|
|
(fun err ->
|
|
raise (Ocaml_common.Location.Error (Ocaml_common.Location.error ~loc err)))
|
|
fmt
|
|
|
|
(** {2 let expression} *)
|
|
|
|
let expand_let ~ctxt (var : [ `Var of label loc | `Unit ]) (name : string) body
|
|
=
|
|
let loc = Expansion_context.Extension.extension_point_loc ctxt in
|
|
Ast_builder.Default.(
|
|
let var_pat =
|
|
match var with
|
|
| `Var v -> ppat_var ~loc:v.loc v
|
|
| `Unit -> ppat_var ~loc { loc; txt = "_trace_span" }
|
|
in
|
|
let var_exp =
|
|
match var with
|
|
| `Var v -> pexp_ident ~loc:v.loc { txt = lident v.txt; loc = v.loc }
|
|
| `Unit -> [%expr _trace_span]
|
|
in
|
|
[%expr
|
|
let [%p var_pat] =
|
|
Trace_core.enter_span ~__FILE__ ~__LINE__ [%e estring ~loc name]
|
|
in
|
|
try
|
|
let res = [%e body] in
|
|
Trace_core.exit_span [%e var_exp];
|
|
res
|
|
with exn ->
|
|
Trace_core.exit_span [%e var_exp];
|
|
raise exn])
|
|
|
|
let extension_let =
|
|
Extension.V3.declare "trace" Extension.Context.expression
|
|
(let open! Ast_pattern in
|
|
single_expr_payload
|
|
(pexp_let nonrecursive
|
|
(value_binding ~constraint_:none
|
|
~pat:
|
|
(let pat_var = ppat_var __' |> map ~f:(fun f v -> f (`Var v)) in
|
|
let pat_unit =
|
|
as__ @@ ppat_construct (lident (string "()")) none
|
|
|> map ~f:(fun f _ -> f `Unit)
|
|
in
|
|
alt pat_var pat_unit)
|
|
~expr:(estring __)
|
|
^:: nil)
|
|
__))
|
|
expand_let
|
|
|
|
let rule_let = Ppxlib.Context_free.Rule.extension extension_let
|
|
|
|
(** {2 Toplevel binding} *)
|
|
|
|
let expand_top_let ~ctxt rec_flag (vbs : _ list) =
|
|
let loc = Expansion_context.Extension.extension_point_loc ctxt in
|
|
Ast_builder.Default.(
|
|
(* go in functions, and add tracing around the body *)
|
|
let rec push_into_fun (e : expression) : expression =
|
|
match e.pexp_desc with
|
|
| Pexp_function (args, ty, Pfunction_body body) ->
|
|
pexp_function ~loc args ty @@ Pfunction_body (push_into_fun body)
|
|
| Pexp_function (_args, _ty, Pfunction_cases _) ->
|
|
(* explicitly fail on [let%trace foo = function …], for now *)
|
|
Ast_helper.Exp.extension
|
|
( { txt = "ocaml.error"; loc },
|
|
PStr
|
|
[
|
|
pstr_eval ~loc
|
|
(pexp_constant ~loc
|
|
(Pconst_string
|
|
( "ppxtrace: cannot trace `function`, please unsugar \
|
|
to `fun`+`match`.",
|
|
loc,
|
|
None )))
|
|
[];
|
|
] )
|
|
| _ ->
|
|
[%expr
|
|
let _trace_span =
|
|
Trace_core.enter_span ~__FILE__ ~__LINE__ __FUNCTION__
|
|
in
|
|
match [%e e] with
|
|
| res ->
|
|
Trace_core.exit_span _trace_span;
|
|
res
|
|
| exception exn ->
|
|
let bt = Stdlib.Printexc.get_raw_backtrace () in
|
|
Trace_core.exit_span _trace_span;
|
|
Stdlib.Printexc.raise_with_backtrace exn bt]
|
|
in
|
|
|
|
let tr_vb (vb : value_binding) : value_binding =
|
|
let expr = push_into_fun vb.pvb_expr in
|
|
{ vb with pvb_expr = expr }
|
|
in
|
|
|
|
let vbs = List.map tr_vb vbs in
|
|
pstr_value ~loc rec_flag vbs)
|
|
|
|
let extension_top_let =
|
|
Extension.V3.declare "trace" Extension.Context.structure_item
|
|
(let open! Ast_pattern in
|
|
pstr (pstr_value __ __ ^:: nil))
|
|
expand_top_let
|
|
|
|
let rule_top_let = Ppxlib.Context_free.Rule.extension extension_top_let
|
|
|
|
let () =
|
|
Driver.register_transformation ~rules:[ rule_let; rule_top_let ] "ppx_trace"
|