ppx_playaround

Makefile

build: clean
	ocamlbuild -use-ocamlfind -package compiler-libs.common,ppx_tools.metaquot \
	ppx_vb.native

infer:
	ocamlbuild -use-ocamlfind -package compiler-libs.common,ppx_tools.metaquot \
	ppx_vb.inferred.mli

test: build
	ocamlopt -I lib -ppx ./ppx_vb.native ./test_vb.ml -o ./test_vb.native

clean:
	rm -f *.cmi *.cmx *.o *.native

ppx_vb.ml

open Ast_mapper
open Ast_helper
open Asttypes
open Parsetree
open Longident
open Location

let get_vb stru_item = 
  match stru_item with
  |{pstr_desc =
     Pstr_value (Nonrecursive,
      [{pvb_pat  = {ppat_desc = Ppat_var {txt = id}};
        pvb_expr = _}])} -> Some id
  | _ -> None

let stru_mapper = fun mapper stru_items ->
  match stru_items with
  | [] -> []
  | stru_item :: rs ->
     match stru_item with
     | {pstr_desc = Pstr_extension (({txt ="getvb"}, PStr [stru_item']), _)}->
         begin
         match get_vb stru_item' with
         | Some id -> stru_item' :: [%str let p () = print_endline id]
         | None -> stru_item' :: rs 
         end
     | {pstr_desc = _} -> stru_items
  | _ -> failwith "error"

let getvb_mapper argv =
  {default_mapper with structure = stru_mapper}

let () = Ast_mapper.register "getvb" getvb_mapper

test_vb's AST

[{pstr_desc =
   Pstr_extension
    (({txt = "getvb"},
      PStr
       [{pstr_desc =
          Pstr_value (Nonrecursive,
           [{pvb_pat = {ppat_desc = Ppat_var {txt = "f"}};
             pvb_expr =
              {pexp_desc =
                Pexp_fun ("", None, {ppat_desc = Ppat_var {txt = "x"}},
                 {pexp_desc =
                   Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "+"}},
                    [("", {pexp_desc = Pexp_ident {txt = Lident "x"}});
                     ("", {pexp_desc = Pexp_constant (Const_int 1)})])})}}])}]),
    ...)};
 {pstr_desc =
   Pstr_value (Nonrecursive,
    [{pvb_pat = {ppat_desc = Ppat_construct ({txt = Lident "()"}, None)};
      pvb_expr =
       {pexp_desc =
         Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "p"}},
          [("", {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})])}}])}]

test_vb.ml

let%getvb f x = x + 1

let () = p ()