Cherry-pick 15062,15063,15064 from 4.02 (#6497).

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15068 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 165 insertions, 14 deletions

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 1b33d9649..f44b12330 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -18,6 +18,8 @@
 *)
 
 
+open Asttypes
+open Longident
 open Parsetree
 open Ast_helper
 open Location
@@ -615,13 +617,85 @@ let default_mapper =
 
 let rec extension_of_error {loc; msg; if_highlight; sub} =
   { loc; txt = "ocaml.error" },
-  PStr ([Str.eval (Exp.constant (Asttypes.Const_string (msg, None)));
-         Str.eval (Exp.constant (Asttypes.Const_string (if_highlight, None)))] @
+  PStr ([Str.eval (Exp.constant (Const_string (msg, None)));
+         Str.eval (Exp.constant (Const_string (if_highlight, None)))] @
         (List.map (fun ext -> Str.extension (extension_of_error ext)) sub))
 
 let attribute_of_warning loc s =
   { loc; txt = "ocaml.ppwarning" },
-  PStr ([Str.eval ~loc (Exp.constant (Asttypes.Const_string (s, None)))])
+  PStr ([Str.eval ~loc (Exp.constant (Const_string (s, None)))])
+
+let tool_name_ref = ref "_none_"
+
+let tool_name () = !tool_name_ref
+
+let restore_ppx_context payload =
+  let fields =
+    match payload with
+    | PStr [{pstr_desc = Pstr_eval
+                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
+        fields
+    | _ ->
+        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
+  in
+  let field name payload =
+    let rec get_string = function
+      | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str
+      | _ ->
+          raise_errorf
+            "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax"
+            name
+    and get_bool pexp =
+      match pexp with
+      | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} ->
+          true
+      | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} ->
+          false
+      | _ ->
+          raise_errorf
+            "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax"
+            name
+    and get_list elem = function
+      | {pexp_desc =
+           Pexp_construct ({txt = Longident.Lident "::"},
+                           Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+          elem exp :: get_list elem rest
+      | {pexp_desc =
+           Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+          []
+      | _ ->
+          raise_errorf
+            "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax"
+            name
+    and get_option elem = function
+      | { pexp_desc =
+            Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+          Some (elem exp)
+      | { pexp_desc =
+            Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+          None
+      | _ ->
+          raise_errorf
+            "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax"
+            name
+    in
+    match name with
+    | "tool_name" ->
+        tool_name_ref := get_string payload
+    | "include_dirs" ->
+        Clflags.include_dirs := get_list get_string payload
+    | "load_path" ->
+        Config.load_path := get_list get_string payload
+    | "open_modules" ->
+        Clflags.open_modules := get_list get_string payload
+    | "for_package" ->
+        Clflags.for_package := get_option get_string payload
+    | "debug" ->
+        Clflags.debug := get_bool payload
+    | _ ->
+        ()
+  in
+  List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
 
 let apply ~source ~target mapper =
   let ic = open_in_bin source in
@@ -635,23 +709,41 @@ let apply ~source ~target mapper =
   let ast = input_value ic in
   close_in ic;
 
-  let ast =
+  let implem ast =
     try
-      if magic = Config.ast_impl_magic_number
-      then Obj.magic (mapper.structure mapper (Obj.magic ast))
-      else Obj.magic (mapper.signature mapper (Obj.magic ast))
+      begin match ast with
+      | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ ->
+          restore_ppx_context x
+      | _ -> ()
+      end;
+      mapper.structure mapper ast
     with exn ->
       match error_of_exn exn with
       | Some error ->
-          if magic = Config.ast_impl_magic_number
-          then Obj.magic [{pstr_desc = Pstr_extension (extension_of_error error,
-                                                       []);
-                           pstr_loc  = Location.none}]
-          else Obj.magic [{psig_desc = Psig_extension (extension_of_error error,
-                                                       []);
-                           psig_loc  = Location.none}]
+          [{pstr_desc = Pstr_extension (extension_of_error error, []);
+            pstr_loc  = Location.none}]
       | None -> raise exn
   in
+  let iface ast =
+    try
+      begin match ast with
+      | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ ->
+          restore_ppx_context x
+      | _ -> ()
+      end;
+      mapper.signature mapper ast
+    with exn ->
+      match error_of_exn exn with
+      | Some error ->
+          [{psig_desc = Psig_extension (extension_of_error error, []);
+            psig_loc  = Location.none}]
+      | None -> raise exn
+  in
+  let ast =
+    if magic = Config.ast_impl_magic_number
+    then Obj.magic (implem (Obj.magic ast))
+    else Obj.magic (iface (Obj.magic ast))
+  in
   let oc = open_out_bin target in
   output_string oc magic;
   output_value oc !Location.input_name;
@@ -682,3 +774,38 @@ let run_main mapper =
 
 let register_function = ref (fun _name f -> run_main f)
 let register name f = !register_function name f
+
+
+let ppx_context ~tool_name () =
+  let open Longident in
+  let open Asttypes in
+  let open Ast_helper in
+  let lid name = { txt = Lident name; loc = Location.none } in
+  let make_string x = Exp.constant (Const_string (x, None)) in
+  let make_bool x =
+    if x
+    then Exp.construct (lid "true") None
+    else Exp.construct (lid "false") None
+  in
+  let rec make_list f lst =
+    match lst with
+    | x :: rest ->
+      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+    | [] ->
+      Exp.construct (lid "[]") None
+  in
+  let make_option f opt =
+    match opt with
+    | Some x -> Exp.construct (lid "Some") (Some (f x))
+    | None   -> Exp.construct (lid "None") None
+  in
+  { txt = "ocaml.ppx.context"; loc = Location.none },
+    Parsetree.PStr [Str.eval (
+      Exp.record ([
+        lid "tool_name",    make_string tool_name;
+        lid "include_dirs", make_list make_string !Clflags.include_dirs;
+        lid "load_path",    make_list make_string !Config.load_path;
+        lid "open_modules", make_list make_string !Clflags.open_modules;
+        lid "for_package",  make_option make_string !Clflags.for_package;
+        lid "debug",        make_bool !Clflags.debug;
+      ]) None)]
diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
index d8780d6d9..786c37d6b 100644
--- a/parsing/ast_mapper.mli
+++ b/parsing/ast_mapper.mli
@@ -72,6 +72,16 @@ val default_mapper: mapper
 
 (** {2 Apply mappers to compilation units} *)
 
+val tool_name: unit -> string
+(** Can be used within a ppx preprocessor to know which tool is
+    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
+    ["ocaml"], ...  Some global variables that reflect command-line
+    options are automatically synchronized between the calling tool
+    and the ppx preprocessor: [Clflags.include_dirs],
+    [Config.load_path], [Clflags.open_modules], [Clflags.for_package],
+    [Clflags.debug]. *)
+
+
 val apply: source:string -> target:string -> mapper -> unit
 (** Apply a mapper (parametrized by the unit name) to a dumped
     parsetree found in the [source] file and put the result in the
@@ -121,3 +131,11 @@ val attribute_of_warning: Location.t -> string -> attribute
 (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
     inserted in a generated Parsetree.  The compiler will be
     responsible for reporting the warning. *)
+
+(** {2 Helper functions to call external mappers} *)
+
+val ppx_context: tool_name:string -> unit -> Parsetree.attribute
+(** Extract information from the current environment and encode it
+    into an attribute an attribute which can be prepended to
+    signature/structure items of an AST to pass the information to an
+    external processor. *)
diff --git a/parsing/location.ml b/parsing/location.ml
index f0bad88d9..c6d1704f1 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -377,3 +377,6 @@ let () =
       | Error e -> Some e
       | _ -> None
     )
+
+let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
+  Printf.ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
diff --git a/parsing/location.mli b/parsing/location.mli
index 5e412b1f5..1a7feeb4d 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -96,6 +96,9 @@ val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
 val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, unit, string, error) format4 -> 'a
 
+val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
+            -> ('a, unit, string, 'b) format4 -> 'a
+
 val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
 
 val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error