From 60d0694e9f9242b351c9e72105604a606b3bed72 Mon Sep 17 00:00:00 2001
From: Alain Frisch <alain@frisch.fr>
Date: Wed, 13 Jun 2012 08:00:27 +0000
Subject: [PATCH] #5634: parstree rewriters (merge with ast_rewriter branch).

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12597 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 Changes                           |   4 +
 driver/main.ml                    |   1 +
 driver/main_args.ml               |   8 ++
 driver/main_args.mli              |   2 +
 driver/optmain.ml                 |   1 +
 driver/pparse.ml                  |  44 +++++++-
 experimental/frisch/Makefile      |  11 ++
 experimental/frisch/test_trace.ml |  15 +++
 experimental/frisch/tracer.ml     | 169 ++++++++++++++++++++++++++++++
 tools/ocamlcp.ml                  |   1 +
 utils/clflags.ml                  |   1 +
 utils/clflags.mli                 |   1 +
 12 files changed, 257 insertions(+), 1 deletion(-)
 create mode 100644 experimental/frisch/Makefile
 create mode 100644 experimental/frisch/test_trace.ml
 create mode 100644 experimental/frisch/tracer.ml

diff --git a/Changes b/Changes
index 021fbf331..e06ea2892 100644
--- a/Changes
+++ b/Changes
@@ -1,11 +1,15 @@
 Next version
 ------------
 
+Compilers:
+- PR#5634: parsetree rewriter (-ppx flag)
+
 Bug fixes:
 - PR#5327: (Windows) Unix.select blocks if same socket listed in first and
   third arguments
 - PR#5551: Avoid repeated lookups for missing cmi files
 
+
 OCaml 4.00.0:
 -------------
 
diff --git a/driver/main.ml b/driver/main.ml
index 9d448baa1..1c19d6cd5 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -121,6 +121,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _output_obj () = output_c_object := true; custom_runtime := true
   let _pack = set make_package
   let _pp s = preprocessor := Some s
+  let _ppx s = ppx := s :: !ppx
   let _principal = set principal
   let _rectypes = set recursive_types
   let _runtime_variant s = runtime_variant := s
diff --git a/driver/main_args.ml b/driver/main_args.ml
index fa0b83ff4..7d11090e7 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -209,6 +209,10 @@ let mk_pp f =
   "-pp", Arg.String f, "<command>  Pipe sources through preprocessor <command>"
 ;;
 
+let mk_ppx f =
+  "-ppx", Arg.String f, "<command>  Pipe abstract syntax trees through preprocessor <command>"
+;;
+
 let mk_principal f =
   "-principal", Arg.Unit f, " Check principality of type inference"
 ;;
@@ -428,6 +432,7 @@ module type Bytecomp_options = sig
   val _output_obj : unit -> unit
   val _pack : unit -> unit
   val _pp : string -> unit
+  val _ppx : string -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
   val _runtime_variant : string -> unit
@@ -517,6 +522,7 @@ module type Optcomp_options = sig
   val _p : unit -> unit
   val _pack : unit -> unit
   val _pp : string -> unit
+  val _ppx : string -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
   val _runtime_variant : string -> unit
@@ -644,6 +650,7 @@ struct
     mk_output_obj F._output_obj;
     mk_pack_byt F._pack;
     mk_pp F._pp;
+    mk_ppx F._ppx;
     mk_principal F._principal;
     mk_rectypes F._rectypes;
     mk_runtime_variant F._runtime_variant;
@@ -741,6 +748,7 @@ struct
     mk_p F._p;
     mk_pack_opt F._pack;
     mk_pp F._pp;
+    mk_ppx F._ppx;
     mk_principal F._principal;
     mk_rectypes F._rectypes;
     mk_runtime_variant F._runtime_variant;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index b7984cab4..371cb48c6 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -44,6 +44,7 @@ module type Bytecomp_options =
     val _output_obj : unit -> unit
     val _pack : unit -> unit
     val _pp : string -> unit
+    val _ppx : string -> unit
     val _principal : unit -> unit
     val _rectypes : unit -> unit
     val _runtime_variant : string -> unit
@@ -134,6 +135,7 @@ module type Optcomp_options = sig
   val _p : unit -> unit
   val _pack : unit -> unit
   val _pp : string -> unit
+  val _ppx : string -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
   val _runtime_variant : string -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index b6b86bbba..ede89c865 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -132,6 +132,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _p = set gprofile
   let _pack = set make_package
   let _pp s = preprocessor := Some s
+  let _ppx s = ppx := s :: !ppx
   let _principal = set principal
   let _rectypes = set recursive_types
   let _runtime_variant s = runtime_variant := s
diff --git a/driver/pparse.ml b/driver/pparse.ml
index dae174cea..1d8c57c7c 100644
--- a/driver/pparse.ml
+++ b/driver/pparse.ml
@@ -47,6 +47,48 @@ let remove_preprocessed_if_ast inputfile =
 
 exception Outdated_version
 
+let write_ast magic ast =
+  let fn = Filename.temp_file "camlppx" "" in
+  let oc = open_out_bin fn in
+  output_string oc magic;
+  output_value oc !Location.input_name;
+  output_value oc ast;
+  close_out oc;
+  fn
+
+let apply_rewriter fn_in ppx =
+  let fn_out = Filename.temp_file "camlppx" "" in
+  let comm = Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) in
+  let ok = Ccomp.command comm = 0 in
+  Misc.remove_file fn_in;
+  if not ok then begin
+    Misc.remove_file fn_out;
+    raise Error;
+  end;
+  if not (Sys.file_exists fn_out) then raise Error;
+  fn_out
+
+let read_ast magic fn =
+  let ic = open_in_bin fn in
+  try
+    let buffer = Misc.input_bytes ic (String.length magic) in
+    if buffer <> magic then
+      Misc.fatal_error "OCaml and preprocessor have incompatible versions";
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    Misc.remove_file fn;
+    ast
+  with exn ->
+    close_in ic;
+    Misc.remove_file fn;
+    raise exn
+
+let apply_rewriters magic ast ppxs =
+  if ppxs = [] then ast
+  else let fn = List.fold_left apply_rewriter (write_ast magic ast) ppxs in
+  read_ast magic fn
+
 let file ppf inputfile parse_fun ast_magic =
   let ic = open_in_bin inputfile in
   let is_ast_file =
@@ -79,4 +121,4 @@ let file ppf inputfile parse_fun ast_magic =
     with x -> close_in ic; raise x
   in
   close_in ic;
-  ast
+  apply_rewriters ast_magic ast !Clflags.ppx
diff --git a/experimental/frisch/Makefile b/experimental/frisch/Makefile
new file mode 100644
index 000000000..c64992a41
--- /dev/null
+++ b/experimental/frisch/Makefile
@@ -0,0 +1,11 @@
+ROOT=../..
+OCAMLC=$(ROOT)/boot/ocamlrun $(ROOT)/ocamlc -I $(ROOT)/stdlib -I $(ROOT)/parsing -I $(ROOT)/utils -w A-4
+
+tracer.exe: tracer.ml
+	$(OCAMLC) -o tracer.exe $(ROOT)/compilerlibs/ocamlcommon.cma tracer.ml
+
+test_trace.exe: tracer.exe test_trace.ml
+	$(OCAMLC) -o test_trace.exe -ppx ./tracer.exe test_trace.ml
+
+clean:
+	rm -f *.exe *.cm*
diff --git a/experimental/frisch/test_trace.ml b/experimental/frisch/test_trace.ml
new file mode 100644
index 000000000..3d785e142
--- /dev/null
+++ b/experimental/frisch/test_trace.ml
@@ -0,0 +1,15 @@
+type t = int
+
+module A =
+  struct
+    let () = print_endline "FOO"
+  end
+
+module B =
+  struct
+    let () = print_endline "BAR"
+
+    module C =
+      struct
+      end
+  end
diff --git a/experimental/frisch/tracer.ml b/experimental/frisch/tracer.ml
new file mode 100644
index 000000000..142fb064d
--- /dev/null
+++ b/experimental/frisch/tracer.ml
@@ -0,0 +1,169 @@
+(* An example of a simple AST -> AST rewriter *)
+
+
+open Location
+open Config
+open Parsetree
+open Asttypes
+
+(* First, some helpers to build AST fragments *)
+
+let map_flatten f l = List.flatten (List.map f l)
+
+let str ?(loc = Location.none) x = {pstr_desc = x; pstr_loc = loc}
+let str_eval ?loc e = str ?loc (Pstr_eval e)
+let str_value ?loc r pel = str ?loc (Pstr_value (r, pel))
+let str_module ?loc s m = str ?loc (Pstr_module (s, m))
+
+module E = struct
+  let mk ?(loc = Location.none) x = {pexp_desc = x; pexp_loc = loc}
+  let ident ?loc x = mk ?loc (Pexp_ident x)
+  let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc)
+  let let_ ?loc r pel e = mk ?loc (Pexp_let (r, pel, e))
+  let app ?loc f el = mk ?loc (Pexp_apply (f, List.map (fun e -> ("", e)) el))
+  let const ?loc x = mk ?loc (Pexp_constant x)
+  let strconst ?loc x = const ?loc (Const_string x)
+end
+
+let pmod ?(loc = Location.none) x = {pmod_desc = x; pmod_loc = loc}
+let mod_ident ?loc x = pmod ?loc (Pmod_ident x)
+let mod_structure ?loc x = pmod ?loc (Pmod_structure x)
+
+
+(* Now, a generic AST mapper class, to be extended to cover all kinds
+   and cases of the OCaml grammar.  The default behavior of the mapper
+   is the identity. *)
+
+class ast_mapper =
+  object(this)
+    method run fn_in fn_out =
+      let ic = open_in_bin fn_in in
+      let magic = String.create (String.length ast_impl_magic_number) in
+      really_input ic magic 0 (String.length magic);
+      if magic <> ast_impl_magic_number && magic <> ast_intf_magic_number then
+        failwith "Bad magic";
+      let input_name = input_value ic in
+      let ast = input_value ic in
+      close_in ic;
+
+      let (input_name, ast) =
+        if magic = ast_impl_magic_number
+        then Obj.magic (this # implementation input_name (Obj.magic ast))
+        else Obj.magic (this # interface input_name (Obj.magic ast))
+      in
+      let oc = open_out_bin fn_out in
+      output_string oc magic;
+      output_value oc input_name;
+      output_value oc ast;
+      close_out oc
+
+    method implementation = this # default_implementation
+    method default_implementation (input_name : string) ast = (input_name, this # structure ast)
+
+    method interface = this # default_interface
+    method default_interface (input_name : string) ast = (input_name, this # signature ast)
+
+    method structure = this # default_structure
+    method default_structure l = map_flatten (this # structure_item) l
+
+    method signature = this # default_signature
+    method default_signature l = map_flatten (this # signature_item) l
+
+        (* signature items *)
+    method signature_item = this # default_signature_item
+    method default_signature_item (x : signature_item) = [ x ] (* todo *)
+
+        (* structure items *)
+    method structure_item = this # default_structure_item
+    method default_structure_item ({pstr_loc = loc; pstr_desc = desc} as x) : structure_item list =
+      match desc with
+      | Pstr_eval x -> this # str_eval loc x
+      | Pstr_value (r, pel) -> this # str_value loc r pel
+      | Pstr_module (s, m) -> this # str_module loc s m
+            (* ... *)
+      | _ -> [ x ]
+
+    method str_eval = this # default_str_eval
+    method default_str_eval loc x = [ str_eval ~loc (this # expr x) ]
+
+    method str_value = this # default_str_value
+    method default_str_value loc r pel = [ str_value ~loc r (List.map (fun (p, e) -> this # pat p, this # expr e) pel) ]
+
+    method str_module = this # default_str_module
+    method default_str_module loc s m = [ str_module ~loc s (this # module_expr m) ]
+
+        (* patterns *)
+    method pat = this # default_pat
+    method default_pat p = p
+
+        (* expressions *)
+    method expr = this # default_expr
+    method default_expr ({pexp_loc = loc; pexp_desc = desc} as x) =
+      match desc with
+      | Pexp_ident x -> this # exp_ident loc x
+      | Pexp_let (r, pel, e) -> this # exp_let loc r pel e
+            (* ... *)
+      | _ -> x
+
+    method exp_ident = this # default_exp_ident
+    method default_exp_ident loc x = E.ident ~loc x
+
+    method exp_let = this # default_exp_let
+    method default_exp_let loc r pel e = E.let_ ~loc r pel e
+
+        (* module exprs *)
+
+    method module_expr = this # default_module_expr
+    method default_module_expr ({pmod_loc = loc; pmod_desc = desc} as x) =
+      match desc with
+      | Pmod_ident x -> this # mod_ident loc x
+      | Pmod_structure str -> this # mod_structure loc str
+            (* ... *)
+      | _ -> x
+
+    method mod_ident = this # default_mod_ident
+    method default_mod_ident loc x = mod_ident ~loc x
+
+    method mod_structure = this # default_mod_structure
+    method default_mod_structure loc x = mod_structure ~loc (this # structure x)
+  end
+
+
+
+(*********************************************************************)
+
+(* To define a concrete AST rewriter, we can inherit from the generic
+   mapper, and redefine the cases we are interested in.  In the
+   example below, we insert in the AST some debug statements around
+   each module structure. We also keep track of the current "path" in
+   the compilation unit.  *)
+
+let trace s =
+  str_eval E.(app (lid "Pervasives.print_endline") [strconst s])
+
+class tracer =
+  object
+    inherit ast_mapper as super
+    val path = ""
+
+    method! implementation input_name structure =
+      let path = String.capitalize (Filename.chop_extension input_name) in
+      {< path = path >} # default_implementation input_name structure
+
+    method! str_module loc s m =
+      {< path = path ^ "." ^ s.txt >} # default_str_module loc s m
+
+    method! structure l =
+      trace (Printf.sprintf "Entering module %s" path) ::
+      (super # structure l) @
+      [ trace (Printf.sprintf "Leaving module %s" path) ]
+  end
+
+let () =
+  try
+    match Sys.argv with
+    | [| _; fn_in; fn_out |] -> new tracer # run fn_in fn_out
+    | _ -> prerr_endline "Usage: tracer <infile> <outfile>"; exit 1
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 8f09cc134..885117e10 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -73,6 +73,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _output_obj = option "-output-obj"
   let _pack = option "-pack"
   let _pp s = incompatible "-pp"
+  let _ppx s = incompatible "-ppx"
   let _principal = option "-principal"
   let _rectypes = option "-rectypes"
   let _runtime_variant s = option_with_arg "-runtime-variant" s
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 0b3f6bebc..ab10bcf4c 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -33,6 +33,7 @@ and ccopts = ref ([] : string list)     (* -ccopt *)
 and classic = ref false                 (* -nolabels *)
 and nopervasives = ref false            (* -nopervasives *)
 and preprocessor = ref(None : string option) (* -pp *)
+and ppx = ref ([] : string list)        (* -ppx *)
 let annotations = ref false             (* -annot *)
 let binary_annotations = ref false      (* -annot *)
 and use_threads = ref false             (* -thread *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 4ec62cc8d..06111fa48 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -30,6 +30,7 @@ val ccopts : string list ref
 val classic : bool ref
 val nopervasives : bool ref
 val preprocessor : string option ref
+val ppx : string list ref
 val annotations : bool ref
 val binary_annotations : bool ref
 val use_threads : bool ref