Move some tools to a dedicated external project (https://github.com/alainfrisch/ppx_tools).

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

4 files changed, 0 insertions, 465 deletions

diff --git a/experimental/frisch/Makefile b/experimental/frisch/Makefile
index 2e4a65eb70..90d1a2f1f1 100644
--- a/experimental/frisch/Makefile
+++ b/experimental/frisch/Makefile
@@ -33,22 +33,6 @@ minidoc:
 	$(OCAMLC) -c -bin-annot testdoc.mli
 	./minidoc.exe testdoc.cmti
 
-## Lifting the OCaml AST, used for:
-## (i)   creating a printer for Parsetree values
-## (ii)  quasi-quotations
-
-.PHONY: lifter
-lifter:
-	$(OCAMLC) -w +A-4-44-45 -custom -o genlifter.exe $(COMMON) genlifter.ml
-	./genlifter.exe -I ../../parsing -I ../../stdlib Parsetree.expression > ast_lifter.ml
-	$(OCAMLC) -c -w +A-17 ast_lifter.ml
-	$(OCAMLC) -c dumpast.ml
-	$(OCAMLC) -o dumpast.exe $(COMMON) ast_lifter.cmo dumpast.cmo
-	./dumpast.exe "fun x -> 1 + 3 * x" -p "x as y"
-	$(OCAMLC) -custom -o metaquot.exe -w +A-4 $(COMMON) ast_lifter.cmo metaquot.ml
-	$(OCAMLC) -custom -o metaquot_test.exe -w +A -ppx ./metaquot.exe $(COMMON) metaquot_test.ml
-	./metaquot_test.exe
-
 ## Using the OCaml toplevel to evaluate expression during compilation
 
 .PHONY: eval
diff --git a/experimental/frisch/dumpast.ml b/experimental/frisch/dumpast.ml
deleted file mode 100644
index 1ab6ecf066..0000000000
--- a/experimental/frisch/dumpast.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-(* Illustrate how to use AST lifting to create a pretty-printer *)
-
-open Outcometree
-
-class out_value_builder =
-  object
-    method record (_ty : string) x = Oval_record (List.map (fun (l, s) -> (Oide_ident l, s)) x)
-    method constr (_ty : string) (c, args) = Oval_constr (Oide_ident c, args)
-    method list x = Oval_list x
-    method array x = Oval_list (Array.to_list x)
-    method tuple x = Oval_tuple x
-    method int x = Oval_int x
-    method string x = Oval_string x
-    method char x = Oval_char x
-    method int32 x = Oval_int32 x
-    method int64 x = Oval_int64 x
-    method nativeint x = Oval_nativeint x
-  end
-
-let lift =
-  object
-    inherit [_] Ast_lifter.lifter
-    inherit out_value_builder
-    method! lift_Location_t _ = Oval_ellipsis
-        (* Special mapping for the Location.t type *)
-  end
-
-let show lifter parse s =
-  let v = lifter (parse (Lexing.from_string s)) in
-  Format.printf "%s@.==>@.%a@.=========@." s !Oprint.out_value v
-
-let show_expr = show (lift # lift_Parsetree_expression) Parse.expression
-let show_pat = show (lift # lift_Parsetree_pattern) Parse.pattern
-
-let args =
-  let open Arg in
-  [
-   "-e", String show_expr,
-   "<expr> Dump AST for expression <expr>.";
-
-   "-p", String show_pat,
-   "<pat> Dump AST for pattern <pat>."
-  ]
-
-let usage =
-  Printf.sprintf "%s [options]\n" Sys.argv.(0)
-
-let () =
-  Arg.parse (Arg.align args) show_expr usage
-
-
diff --git a/experimental/frisch/genlifter.ml b/experimental/frisch/genlifter.ml
deleted file mode 100644
index 48e795d531..0000000000
--- a/experimental/frisch/genlifter.ml
+++ /dev/null
@@ -1,175 +0,0 @@
-(* Generate code to lift values of a certain type.
-   This illustrates how to build fragments of Parsetree through
-   Ast_helper and more local helper functions. *)
-
-module Main : sig end = struct
-
-open Location
-open Types
-open Asttypes
-open Ast_helper
-open Ast_helper.Convenience
-
-let selfcall ?(this = "this") m args = app (Exp.send (evar this) m) args
-
-(*************************************************************************)
-
-
-let env = Env.initial
-
-let clean s =
-  let s = String.copy s in
-  for i = 0 to String.length s - 1 do
-    if s.[i] = '.' then s.[i] <- '_'
-  done;
-  s
-
-let print_fun s = "lift_" ^ clean s
-
-let printed = Hashtbl.create 16
-let meths = ref []
-
-let rec gen ty =
-  if Hashtbl.mem printed ty then ()
-  else let tylid = Longident.parse ty in
-  let (_, td) =
-    try Env.lookup_type tylid env
-    with Not_found ->
-      Format.eprintf "** Cannot resolve type %s" ty;
-      exit 2
-  in
-  let prefix =
-    let open Longident in
-    match tylid with
-    | Ldot (m, _) -> String.concat "." (Longident.flatten m) ^ "."
-    | Lident _ -> ""
-    | Lapply _ -> assert false
-  in
-  Hashtbl.add printed ty ();
-  let params = List.mapi (fun i _ -> Printf.sprintf "f%i" i) td.type_params in
-  let env = List.map2 (fun s t -> t.id, evar s) params td.type_params in
-  let tyargs = List.map Typ.var params in
-  let t = Typ.(arrow "" (constr (lid ty) tyargs) (var "res")) in
-  let t =
-    List.fold_right
-      (fun s t ->
-        Typ.(arrow "" (arrow "" (var s) (var "res")) t))
-      params t
-  in
-  let t = Typ.poly params t in
-  let concrete e =
-    let e = List.fold_right lam (List.map pvar params) e in
-    let body = Exp.poly e (Some t) in
-    meths := Cf.(method_ (mknoloc (print_fun ty)) Public (concrete Fresh body)) :: !meths
-  in
-  match td.type_kind, td.type_manifest with
-  | Type_record (l, _), _ ->
-      let field (s, _, t) =
-        let s = Ident.name s in
-        (lid (prefix ^ s), pvar s),
-        tuple[str s; tyexpr env t (evar s)]
-      in
-      let l = List.map field l in
-      concrete
-        (lam
-           (Pat.record (List.map fst l) Closed)
-           (selfcall "record" [str ty; list (List.map snd l)]))
-  | Type_variant l, _ ->
-      let case (c, tyl, _) =
-        let c = Ident.name c in
-        let qc = prefix ^ c in
-        let p, args = gentuple env tyl in
-        pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]]
-      in
-      concrete (func (List.map case l))
-  | Type_abstract, Some t ->
-      concrete (tyexpr_fun env t)
-  | Type_abstract, None ->
-      (* Generate an abstract method to lift abstract types *)
-      meths := Cf.(method_ (mknoloc (print_fun ty)) Public (virtual_ t)) :: !meths
-
-and gentuple env tl =
-  let arg i t =
-    let x = Printf.sprintf "x%i" i in
-    pvar x, tyexpr env t (evar x)
-  in
-  List.split (List.mapi arg tl)
-
-and tyexpr env ty x =
-  match ty.desc with
-  | Tvar _ ->
-      let f =
-        try List.assoc ty.id env
-        with Not_found -> assert false
-      in
-      app f [x]
-  | Ttuple tl ->
-      let p, e = gentuple env tl in
-      let_in [Vb.mk (Pat.tuple p) x] (selfcall "tuple" [list e])
-  | Tconstr (path, [t], _) when Path.same path Predef.path_list ->
-      selfcall "list" [app (evar "List.map") [tyexpr_fun env t; x]]
-  | Tconstr (path, [t], _) when Path.same path Predef.path_array ->
-      selfcall "array" [app (evar "Array.map") [tyexpr_fun env t; x]]
-  | Tconstr (path, [], _) when Path.same path Predef.path_string ->
-      selfcall "string" [x]
-  | Tconstr (path, [], _) when Path.same path Predef.path_int ->
-      selfcall "int" [x]
-  | Tconstr (path, [], _) when Path.same path Predef.path_char ->
-      selfcall "char" [x]
-  | Tconstr (path, [], _) when Path.same path Predef.path_int32 ->
-      selfcall "int32" [x]
-  | Tconstr (path, [], _) when Path.same path Predef.path_int64 ->
-      selfcall "int64" [x]
-  | Tconstr (path, [], _) when Path.same path Predef.path_nativeint ->
-      selfcall "nativeint" [x]
-  | Tconstr (path, tl, _) ->
-      let ty = Path.name path in
-      gen ty;
-      selfcall (print_fun ty) (List.map (tyexpr_fun env) tl @ [x])
-  | _ ->
-      Format.eprintf "** Cannot deal with type %a@." Printtyp.type_expr ty;
-      exit 2
-
-and tyexpr_fun env ty =
-  lam (pvar "x") (tyexpr env ty (evar "x"))
-
-let simplify =
-  (* (fun x -> <expr> x) ====> <expr> *)
-  object
-    inherit Ast_mapper.mapper as super
-    method! expr e =
-      let e = super # expr e in
-      let open Longident in
-      let open Parsetree in
-      match e.pexp_desc with
-      | Pexp_fun
-          ("", None,
-           {ppat_desc = Ppat_var{txt=id;_};_},
-           {pexp_desc =
-            Pexp_apply
-              (f,
-               ["",{pexp_desc=
-                    Pexp_ident{txt=Lident id2;_};_}]);_}) when id = id2 -> f
-      | _ -> e
-  end
-
-let args =
-  let open Arg in
-  [
-   "-I", String (fun s -> Config.load_path := s :: !Config.load_path),
-   "<dir> Add <dir> to the list of include directories";
-  ]
-
-let usage =
-  Printf.sprintf "%s [options] <type names>\n" Sys.argv.(0)
-
-let () =
-  Config.load_path := [];
-  Arg.parse (Arg.align args) gen usage;
-  let cl = Cstr.mk (pvar "this") !meths in
-  let params = [mknoloc "res", Invariant] in
-  let cl = Ci.mk ~virt:Virtual ~params (mknoloc "lifter") (Cl.structure cl) in
-  let s = [Str.class_ [cl]] in
-  Format.printf "%a@." Pprintast.structure (simplify # structure s)
-
-end
diff --git a/experimental/frisch/metaquot.ml b/experimental/frisch/metaquot.ml
deleted file mode 100644
index 7daf6bd39c..0000000000
--- a/experimental/frisch/metaquot.ml
+++ /dev/null
@@ -1,223 +0,0 @@
-(* A -ppx rewriter to be used to write Parsetree-generating code
-   (including other -ppx rewriters) using concrete syntax.
-
-   See metaquot_test.ml for an example.
-
-   We support the following extensions in expression position:
-
-   [%expr ...]  maps to code which creates the expression represented by ...
-   [%pat? ...] maps to code which creates the pattern represented by ...
-   [%str ...] maps to code which creates the structure represented by ...
-   [%type: ...] maps to code which creates the core type represented by ...
-
-   Quoted code can refer to expressions representing AST fragments,
-   using the following extensions:
-
-     [%e ...] where ... is an expression of type Parsetree.expression
-     [%t ...] where ... is an expression of type Parsetree.core_type
-     [%p ...] where ... is an expression of type Parsetree.pattern
-
-
-   All locations generated by the meta quotation are by default set
-   to [Ast_helper.default_loc].  This can be overriden by providing a custom
-   expression which will be inserted whereever a location is required
-   in the generated AST.  This expression can be specified globally
-   (for the current structure) as a structure item attribute:
-
-     ;;[@@metaloc ...]
-
-   or locally for the scope of an expression:
-
-     e [@metaloc ...]
-
-
-
-   Support is also provided to use concrete syntax in pattern
-   position.  The location and attribute fields are currently ignored
-   by patterns generated from meta quotations.
-
-   We support the following extensions in pattern position:
-
-   [%expr ...]  maps to code which creates the expression represented by ...
-   [%pat? ...] maps to code which creates the pattern represented by ...
-   [%str ...] maps to code which creates the structure represented by ...
-   [%type: ...] maps to code which creates the core type represented by ...
-
-   Quoted code can refer to expressions representing AST fragments,
-   using the following extensions:
-
-     [%e? ...] where ... is a pattern of type Parsetree.expression
-     [%t? ...] where ... is a pattern of type Parsetree.core_type
-     [%p? ...] where ... is a pattern of type Parsetree.pattern
-
-*)
-
-module Main : sig end = struct
-  open Asttypes
-  open Parsetree
-  open Ast_helper
-  open Ast_helper.Convenience
-
-  let prefix ty s =
-    let open Longident in
-    match parse ty with
-    | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s
-    | _ -> s
-
-  class exp_builder =
-    object
-      method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x)
-      method constr ty (c, args) = constr (prefix ty c) args
-      method list = list
-      method tuple = tuple
-      method int = int
-      method string = str
-      method char = char
-      method int32 x = Exp.constant (Const_int32 x)
-      method int64 x = Exp.constant (Const_int64 x)
-      method nativeint x = Exp.constant (Const_nativeint x)
-    end
-
-  class pat_builder =
-    object
-      method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x)
-      method constr ty (c, args) = pconstr (prefix ty c) args
-      method list = plist
-      method tuple = ptuple
-      method int = pint
-      method string = pstr
-      method char = pchar
-      method int32 x = Pat.constant (Const_int32 x)
-      method int64 x = Pat.constant (Const_int64 x)
-      method nativeint x = Pat.constant (Const_nativeint x)
-    end
-
-
-  let get_exp loc = function
-    | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
-    | _ ->
-        Format.eprintf "%aExpression expected@."
-          Location.print_error loc;
-        exit 2
-
-  let get_typ loc = function
-    | PTyp t -> t
-    | _ ->
-        Format.eprintf "%aType expected@."
-          Location.print_error loc;
-        exit 2
-
-  let get_pat loc = function
-    | PPat (t, None) -> t
-    | _ ->
-        Format.eprintf "%aPattern expected@."
-          Location.print_error loc;
-        exit 2
-
-  let exp_lifter loc =
-    object
-      inherit [_] Ast_lifter.lifter as super
-      inherit exp_builder
-
-          (* Special support for location in the generated AST *)
-      method! lift_Location_t _ = loc
-
-          (* Support for antiquotations *)
-      method! lift_Parsetree_expression = function
-        | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> get_exp loc e
-        | x -> super # lift_Parsetree_expression x
-
-      method! lift_Parsetree_pattern = function
-        | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> get_exp loc e
-        | x -> super # lift_Parsetree_pattern x
-
-      method! lift_Parsetree_core_type = function
-        | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> get_exp loc e
-        | x -> super # lift_Parsetree_core_type x
-    end
-
-  let pat_lifter =
-    object
-      inherit [_] Ast_lifter.lifter as super
-      inherit pat_builder
-
-          (* Special support for location and attributes in the generated AST *)
-      method! lift_Location_t _ = Pat.any ()
-      method! lift_Parsetree_attributes _ = Pat.any ()
-
-          (* Support for antiquotations *)
-      method! lift_Parsetree_expression = function
-        | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> get_pat loc e
-        | x -> super # lift_Parsetree_expression x
-
-      method! lift_Parsetree_pattern = function
-        | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> get_pat loc e
-        | x -> super # lift_Parsetree_pattern x
-
-      method! lift_Parsetree_core_type = function
-        | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> get_pat loc e
-        | x -> super # lift_Parsetree_core_type x
-    end
-
-  let loc = ref (app (evar "Pervasives.!") [evar "Ast_helper.default_loc"])
-
-  let handle_attr = function
-    | {txt="metaloc";loc=l}, e -> loc := get_exp l e
-    | _ -> ()
-
-  let with_loc ?(attrs = []) f =
-    let old_loc = !loc in
-    List.iter handle_attr attrs;
-    let r = f () in
-    loc := old_loc;
-    r
-
-  let expander = object
-    inherit Ast_mapper.mapper as super
-
-    method! expr e =
-      with_loc ~attrs:e.pexp_attributes
-        (fun () ->
-          match e.pexp_desc with
-          | Pexp_extension({txt="expr";loc=l}, e) ->
-              (exp_lifter !loc) # lift_Parsetree_expression (get_exp l e)
-          | Pexp_extension({txt="pat";loc=l}, e) ->
-              (exp_lifter !loc) # lift_Parsetree_pattern (get_pat l e)
-          | Pexp_extension({txt="str";_}, PStr e) ->
-              (exp_lifter !loc) # lift_Parsetree_structure e
-          | Pexp_extension({txt="type";loc=l}, e) ->
-              (exp_lifter !loc) # lift_Parsetree_core_type (get_typ l e)
-          | _ ->
-              super # expr e
-        )
-
-    method! pat p =
-      with_loc ~attrs:p.ppat_attributes
-        (fun () ->
-          match p.ppat_desc with
-          | Ppat_extension({txt="expr";loc=l}, e) ->
-              pat_lifter # lift_Parsetree_expression (get_exp l e)
-          | Ppat_extension({txt="pat";loc=l}, e) ->
-              pat_lifter # lift_Parsetree_pattern (get_pat l e)
-          | Ppat_extension({txt="str";_}, PStr e) ->
-              pat_lifter # lift_Parsetree_structure e
-          | Ppat_extension({txt="type";loc=l}, e) ->
-              pat_lifter # lift_Parsetree_core_type (get_typ l e)
-          | _ ->
-              super # pat p
-        )
-
-    method! structure l =
-      with_loc
-        (fun () -> super # structure l)
-
-    method! structure_item x =
-      begin match x.pstr_desc with
-      | Pstr_attribute x -> handle_attr x
-      | _ -> ()
-      end;
-      super # structure_item x
-  end
-
-  let () = Ast_mapper.main expander
-end