[ppx_trace] Refactor: Avoid using Ast_mapper for ppxlib 0.16 compatibility

Summary:
Use `Ppxlib.Ast_traverse.map` instead of
`Ppxlib.Selected_ast.Ast.Ast_mapper` which is included from
`Migrate_parsetree` since `Ppxlib.Selected_ast.Ast` reexports one of
the `Migrate_parsetree.Versions` modules. This change is needed to be
compatible with (ocaml-migrate-parsetree 2.0 and) ppxlib 0.16 since it
no longer re-exports the `Ast_mapper` module from
`Migrate_parsetree`. This ppxlib change is one of the headline
simplification enablers noted in the (announcement of
ocaml-migrate-parsetree
2.0)[https://discuss.ocaml.org/t/ocaml-migrate-parsetree-2-0-0/5991].

Reviewed By: jvillard

Differential Revision: D23636203

fbshipit-source-id: 71e24b46b
master
Josh Berdine 4 years ago committed by Facebook GitHub Bot
parent 936ad83650
commit 77f2b7a02f

@ -40,7 +40,6 @@
open Ppxlib
open Ast_builder.Default
module Ast_mapper = Selected_ast.Ast.Ast_mapper
let debug = ref false
@ -75,56 +74,57 @@ let vb_stack_with, vb_stack_top =
(with_, top)
let mapper =
let value_binding (m : Ast_mapper.mapper) vb =
vb_stack_with vb.pvb_pat ~f:(fun () ->
Ast_mapper.default_mapper.value_binding m vb )
in
let expr (m : Ast_mapper.mapper) 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 ()))
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
in
(Nolabel, mod_name) :: (Nolabel, fun_name) :: args
in
match exp.pexp_desc with
| Pexp_extension ({txt= "debug"; loc}, PStr []) -> ebool ~loc !debug
| Pexp_extension
( { txt=
( "Trace.info" | "Trace.infok" | "Trace.printf"
| "Trace.fprintf" | "Trace.kprintf" ) as txt
; loc }
, PStr [{pstr_desc= Pstr_eval (arg, []); _}] ) ->
if not !debug then eunit ~loc:exp.pexp_loc
else
let args =
match arg.pexp_desc with
| Pexp_apply (op, args) -> (Nolabel, op) :: args
| _ -> [(Nolabel, arg)]
in
pexp_apply ~loc:exp.pexp_loc (evar ~loc txt)
(append_here_args args)
| Pexp_extension
( {txt= "Trace.call"; loc= call_loc}
, PStr [{pstr_desc= Pstr_eval (call_fun, []); _}] ) ->
if not !debug then eunit ~loc:exp.pexp_loc
else
pexp_apply ~loc:exp.pexp_loc
(evar ~loc:call_loc "Trace.call")
(append_here_args [(Nolabel, call_fun)])
| Pexp_extension
( {txt= "Trace.retn"; loc= retn_loc}
, PStr [{pstr_desc= Pstr_eval (retn_fun, []); _}] ) ->
if not !debug then evar ~loc:exp.pexp_loc "Stdlib.Fun.id"
else
pexp_apply ~loc:exp.pexp_loc
(evar ~loc:retn_loc "Trace.retn")
(append_here_args [(Nolabel, retn_fun)])
| _ -> Ast_mapper.default_mapper.expr m exp
in
{Ast_mapper.default_mapper with expr; value_binding}
let impl = Selected_ast.Ast.map_structure mapper
match exp.pexp_desc with
| Pexp_extension ({txt= "debug"; loc}, PStr []) -> ebool ~loc !debug
| Pexp_extension
( { txt=
( "Trace.info" | "Trace.infok" | "Trace.printf"
| "Trace.fprintf" | "Trace.kprintf" ) as txt
; loc }
, PStr [{pstr_desc= Pstr_eval (arg, []); _}] ) ->
if not !debug then eunit ~loc:exp.pexp_loc
else
let args =
match arg.pexp_desc with
| Pexp_apply (op, args) -> (Nolabel, op) :: args
| _ -> [(Nolabel, arg)]
in
pexp_apply ~loc:exp.pexp_loc (evar ~loc txt)
(append_here_args args)
| Pexp_extension
( {txt= "Trace.call"; loc= call_loc}
, PStr [{pstr_desc= Pstr_eval (call_fun, []); _}] ) ->
if not !debug then eunit ~loc:exp.pexp_loc
else
pexp_apply ~loc:exp.pexp_loc
(evar ~loc:call_loc "Trace.call")
(append_here_args [(Nolabel, call_fun)])
| Pexp_extension
( {txt= "Trace.retn"; loc= retn_loc}
, PStr [{pstr_desc= Pstr_eval (retn_fun, []); _}] ) ->
if not !debug then evar ~loc:exp.pexp_loc "Stdlib.Fun.id"
else
pexp_apply ~loc:exp.pexp_loc
(evar ~loc:retn_loc "Trace.retn")
(append_here_args [(Nolabel, retn_fun)])
| _ -> super#expression exp
end
let impl = mapper#structure
;;
Driver.register_transformation "trace" ~impl

Loading…
Cancel
Save