open Migrate_parsetree open Ast_408 open Parsetree let ocaml_version = Versions.ocaml_408 (* Traversal: - when crossing a module or let-binding, remember the name to construct a path - when crossing a function, remember that to log the call when we reach the body *) let camtrail_prim = Longident.Ldot (Longident.Lident "Camtrail", "enter") let traverse_fun path mapper = let rec aux expr = match expr.pexp_desc with | Pexp_fun (label, default, pattern, body) -> let default = match default with | None -> None | Some expr -> Some (Ast_mapper.default_mapper.expr mapper expr) in let pattern = Ast_mapper.default_mapper.pat mapper pattern in let body = aux body in {expr with pexp_desc = Pexp_fun (label, default, pattern, body)} | Pexp_function cases -> let cases = List.map (fun { pc_lhs; pc_guard; pc_rhs } -> let pc_lhs = Ast_mapper.default_mapper.pat mapper pc_lhs in let pc_guard = match pc_guard with | None -> None | Some expr -> Some (Ast_mapper.default_mapper.expr mapper expr) in let pc_rhs = aux pc_rhs in { pc_lhs; pc_guard; pc_rhs } ) cases in {expr with pexp_desc = Pexp_function cases} | Pexp_newtype (name, body) -> {expr with pexp_desc = Pexp_newtype (name, aux body)} | _ -> let open Ast_helper in let loc = {expr.pexp_loc with loc_ghost = true} in let name = let pos = loc.loc_start in "\000\000\000\000" ^ String.concat "." (List.rev path) ^ ":" ^ string_of_int pos.pos_lnum ^ "." ^ string_of_int (pos.pos_cnum - pos.pos_bol) in Exp.sequence ~loc:expr.pexp_loc (Exp.apply ~loc (Exp.ident (Location.mkloc camtrail_prim loc)) [Asttypes.Nolabel, Exp.constant ~loc (Const.string name)]) (Ast_mapper.default_mapper.expr mapper expr) in aux let rec mapper_for_path path = { Ast_mapper.default_mapper with expr = (fun self expr -> match expr.pexp_desc with | Pexp_fun _ | Pexp_function _ -> traverse_fun path self expr | Pexp_letmodule (name, mexpr, body) -> let mexpr = let path = name.txt :: path in let mapper = mapper_for_path path in mapper.Ast_mapper.module_expr mapper mexpr in let body = Ast_mapper.default_mapper.expr self body in {expr with pexp_desc = Pexp_letmodule (name, mexpr, body)} | _ -> Ast_mapper.default_mapper.expr self expr ); module_binding = (fun _self mb -> let mapper = mapper_for_path (mb.pmb_name.txt :: path) in Ast_mapper.default_mapper.module_binding mapper mb ); value_binding = (fun self vb -> let mapper = match vb.pvb_pat.ppat_desc with | Ppat_var name -> mapper_for_path (name.txt :: path) | _ -> self in Ast_mapper.default_mapper.value_binding mapper vb ); } let () = Driver.register ~name:"camtrail.ppx" ocaml_version (fun _ _ -> {Ast_mapper.default_mapper with structure = fun _ -> function | [] -> [] | (x :: _) as str -> let name = x.pstr_loc.loc_start.pos_fname in let name = Filename.basename name in let name = Filename.remove_extension name in let name = String.capitalize_ascii name in let mapper = mapper_for_path [name] in mapper.structure mapper str })