diff --git a/.merlin b/.merlin deleted file mode 100644 index c50d78d..0000000 --- a/.merlin +++ /dev/null @@ -1,3 +0,0 @@ -PKG compiler-libs - -FLG -safe-string \ No newline at end of file diff --git a/ast_convenience.ml b/ast_convenience.ml index fe3c4a2..8d763dd 100644 --- a/ast_convenience.ml +++ b/ast_convenience.ml @@ -109,6 +109,12 @@ let find_attr s attrs = try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) with Not_found -> None +let find_attr_loc s attrs = + match List.find_opt (fun (attr_name, _) -> attr_name.txt = s) attrs with + | None -> None + | Some (attr_name, payload) -> + Some { Location.txt = payload; loc = attr_name.loc } + let expr_of_payload = function | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e | _ -> None diff --git a/ast_convenience.mli b/ast_convenience.mli index 3ac31fd..120c4e5 100644 --- a/ast_convenience.mli +++ b/ast_convenience.mli @@ -107,4 +107,5 @@ val get_lid: expression -> string option val has_attr: string -> attributes -> bool val find_attr: string -> attributes -> payload option +val find_attr_loc: string -> attributes -> payload Location.loc option val find_attr_expr: string -> attributes -> expression option diff --git a/dune b/dune new file mode 100644 index 0000000..a9f71c9 --- /dev/null +++ b/dune @@ -0,0 +1,57 @@ +(library + (public_name ppx_tools) + (synopsis "Tools for authors of ppx rewriters and other syntactic tools") + (wrapped false) + (modules ast_convenience ast_mapper_class) + (libraries compiler-libs.common)) + +(library + (name ppx_metaquot) + (public_name ppx_tools.metaquot) + (synopsis "Meta-quotation: Parsetree manipulation using concrete syntax") + (wrapped false) + (kind ppx_rewriter) + (modules ppx_metaquot) + (ppx.driver (main Ppx_metaquot.Main.main)) + (ppx_runtime_libraries ppx_tools) + (libraries compiler-libs.common ppx_tools ast_lifter)) + +(executable + (name genlifter) + (modules genlifter) + (libraries compiler-libs.common ppx_tools)) + +(executable + (name dumpast) + (modules dumpast) + (libraries compiler-libs.common compiler-libs.bytecomp ast_lifter)) + +(executable + (name ppx_metaquot_main) + (modules ppx_metaquot_main) + (libraries ppx_metaquot)) + +(executable + (name rewriter) + (modules rewriter) + (libraries compiler-libs.common)) + +(rule + (with-stdout-to ast_lifter.ml + (run ./genlifter.exe -I +compiler-libs Parsetree.expression))) + +(library + (name ast_lifter) + (public_name ppx_tools.ast_lifter) + (wrapped false) + (modules ast_lifter) + (flags :standard -w -17) + (libraries compiler-libs.common)) + +(install + (section libexec) + (files + (genlifter.exe as genlifter) + (dumpast.exe as dumpast) + (ppx_metaquot_main.exe as ppx_metaquot) + (rewriter.exe as rewriter))) diff --git a/ppx_metaquot.ml b/ppx_metaquot.ml index c63dbf1..6b414da 100644 --- a/ppx_metaquot.ml +++ b/ppx_metaquot.ml @@ -59,7 +59,9 @@ *) -module Main : sig end = struct +module Main : sig + val main : unit -> unit +end = struct open Asttypes open Parsetree open Ast_helper @@ -125,6 +127,50 @@ module Main : sig end = struct Location.print_error loc; exit 2 + let exp_construct loc txt args = + Ast_helper.with_default_loc loc @@ fun () -> + match args with + | [] -> Ast_helper.Exp.construct { loc; txt } None + | [arg] -> Ast_helper.Exp.construct { loc; txt } (Some arg) + | _ -> + Ast_helper.Exp.construct { loc; txt } + (Some (Ast_helper.Exp.tuple args)) + + let pat_construct loc txt args = + Ast_helper.with_default_loc loc @@ fun () -> + match args with + | [] -> Ast_helper.Pat.construct { loc; txt } None + | [arg] -> Ast_helper.Pat.construct { loc; txt } (Some arg) + | _ -> + Ast_helper.Pat.construct { loc; txt } + (Some (Ast_helper.Pat.tuple args)) + + let get_literal_extension ~construct ~none ~loc_exp:_ ~of_payload name attrs + arg = + match name with + | "lit.integer" -> + let suffix = + match find_attr_loc "suffix" attrs with + | Some attr -> of_payload attr.loc attr.txt + | None -> none in + Some (construct (Longident.Lident "Pconst_integer") [arg; suffix]) + | "lit.char" -> + Some (construct (Longident.Lident "Pconst_char") [arg]) + | "lit.string" -> + let quotation_delimiter = + match find_attr_loc "quotation_delimiter" attrs with + | Some attr -> of_payload attr.loc attr.txt + | None -> none in + Some (construct (Longident.Lident "Pconst_string") + [arg; quotation_delimiter]) + | "lit.float" -> + let suffix = + match find_attr_loc "suffix" attrs with + | Some attr -> of_payload attr.loc attr.txt + | None -> none in + Some (construct (Longident.Lident "Pconst_float") [arg; suffix]) + | _ -> None + let exp_lifter loc map = let map = map.Ast_mapper.expr map in object @@ -135,9 +181,29 @@ module Main : sig end = struct method! lift_Location_t _ = loc (* Support for antiquotations *) - method! lift_Parsetree_expression = function + method! lift_Parsetree_expression x = + let loc_exp = loc in + match x with | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) - | x -> super # lift_Parsetree_expression x + | {pexp_desc=Pexp_extension({txt;loc}, e); pexp_attributes; _} -> + begin match + get_literal_extension txt pexp_attributes (get_exp loc e) + ~construct:(exp_construct loc) + ~none:(exp_construct loc (Lident "None") []) ~loc_exp + ~of_payload:get_exp + with + | Some e -> + let e = Ast_helper.Exp.record [ + { loc; + txt = Longident.Ldot (Lident "Parsetree", "pexp_desc") }, + exp_construct loc (Lident "Pexp_constant") [e]; + { loc; txt = Lident "pexp_loc" }, loc_exp; + { loc; txt = Lident "pexp_attributes" }, + exp_construct loc (Lident "[]") []] None in + map e + | _ -> super # lift_Parsetree_expression x + end + | _ -> super # lift_Parsetree_expression x method! lift_Parsetree_pattern = function | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) @@ -177,8 +243,25 @@ module Main : sig end = struct method! lift_Parsetree_attributes _ = Pat.any () (* Support for antiquotations *) - method! lift_Parsetree_expression = function + method! lift_Parsetree_expression x = + match x with | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) + | {pexp_desc=Pexp_extension({txt;loc}, e); pexp_attributes; _} -> + begin match + get_literal_extension txt pexp_attributes (get_pat loc e) + ~construct:(pat_construct loc) + ~none:(Ast_helper.Pat.any ~loc ()) + ~loc_exp:(Ast_helper.Pat.any ~loc ()) + ~of_payload:get_pat + with + | Some e -> + let e = Ast_helper.Pat.record [ + { loc; + txt = Longident.Ldot (Lident "Parsetree", "pexp_desc") }, + pat_construct loc (Lident "Pexp_constant") [e]] Open in + map e + | _ -> super # lift_Parsetree_expression x + end | x -> super # lift_Parsetree_expression x method! lift_Parsetree_pattern = function @@ -273,5 +356,5 @@ module Main : sig end = struct in {super with expr; pat; structure; structure_item; signature; signature_item} - let () = Ast_mapper.run_main expander + let main () = Ast_mapper.run_main expander end diff --git a/ppx_tools.opam b/ppx_tools.opam new file mode 100644 index 0000000..c49caee --- /dev/null +++ b/ppx_tools.opam @@ -0,0 +1,15 @@ +opam-version: "2.0" +synopsis: "Tools for authors of ppx rewriters and other syntactic tools" +maintainer: "alain.frisch@lexifi.com" +authors: "Alain Frisch " +license: "MIT" +tags: [ "syntax" ] +homepage: "https://github.com/ocaml-ppx/ppx_tools" +bug-reports: "https://github.com/ocaml-ppx/ppx_tools/issues" +dev-repo: "git://github.com/ocaml-ppx/ppx_tools.git" +build: ["dune" "build" "-p" name "-j" jobs + "@runtest" {with-test}] +depends: [ + "ocaml" {>= "4.05.0" & < "4.06.0"} + "dune" {>= "1.6"} +] diff --git a/tests/test_metaquot_lit/dune b/tests/test_metaquot_lit/dune new file mode 100644 index 0000000..f96cb05 --- /dev/null +++ b/tests/test_metaquot_lit/dune @@ -0,0 +1,3 @@ +(test + (name test_metaquot_lit) + (preprocess (staged_pps ppx_tools.metaquot))) \ No newline at end of file diff --git a/tests/test_metaquot_lit/test_metaquot_lit.ml b/tests/test_metaquot_lit/test_metaquot_lit.ml new file mode 100644 index 0000000..7afb0b5 --- /dev/null +++ b/tests/test_metaquot_lit/test_metaquot_lit.ml @@ -0,0 +1,80 @@ +let () = + match [%expr [%lit.integer "10"]] with + | { pexp_desc = Pexp_constant (Pconst_integer ("10", None)); _ } -> () + | _ -> assert false + +let () = + match Ast_helper.Exp.constant (Ast_helper.Const.integer "10") with + | [%expr [%lit.integer? "0"]] -> assert false + | [%expr [%lit.integer? "10"]] -> () + | _ -> assert false + +let () = + match [%expr [%lit.integer "10"] [@suffix Some 'l']] with + | { pexp_desc = Pexp_constant (Pconst_integer ("10", Some 'l')); _ } -> () + | _ -> assert false + +let () = + match + Ast_helper.Exp.constant (Ast_helper.Const.integer "10" ~suffix:'l') + with + | [%expr [%lit.integer? "10"] [@suffix? None]] -> assert false + | [%expr [%lit.integer? "10"] [@suffix? Some 'l']] -> () + | _ -> assert false + +let () = + match [%expr [%lit.char 'c']] with + | { pexp_desc = Pexp_constant (Pconst_char 'c'); _ } -> () + | _ -> assert false + +let () = + match Ast_helper.Exp.constant (Ast_helper.Const.char 'c') with + | [%expr [%lit.char? 'a']] -> assert false + | [%expr [%lit.char? 'c']] -> () + | _ -> assert false + +let () = + match [%expr [%lit.string "s"]] with + | { pexp_desc = Pexp_constant (Pconst_string ("s", None)); _ } -> () + | _ -> assert false + +let () = + match Ast_helper.Exp.constant (Ast_helper.Const.string "s") with + | [%expr [%lit.string? ""]] -> assert false + | [%expr [%lit.string? "s"]] -> () + | _ -> assert false + +let () = + match [%expr [%lit.string "s"] [@quotation_delimiter Some "t"]] with + | { pexp_desc = Pexp_constant (Pconst_string ("s", Some "t")); _ } -> () + | _ -> assert false + +let () = + match + Ast_helper.Exp.constant + (Ast_helper.Const.string ~quotation_delimiter:"t" "s") with + | [%expr [%lit.string? "s"] [@quotation_delimiter? None]] -> assert false + | [%expr [%lit.string? "s"] [@quotation_delimiter? Some "t"]] -> () + | _ -> assert false + +let () = + match [%expr [%lit.float "1.0"]] with + | { pexp_desc = Pexp_constant (Pconst_float ("1.0", None)); _ } -> () + | _ -> assert false + +let () = + match Ast_helper.Exp.constant (Ast_helper.Const.float "1.0") with + | [%expr [%lit.float? "0.0"]] -> assert false + | [%expr [%lit.float? "1.0"]] -> () + | _ -> assert false + +let () = + match [%expr [%lit.float "1.0"] [@suffix Some 'f']] with + | { pexp_desc = Pexp_constant (Pconst_float ("1.0", Some 'f')); _ } -> () + | _ -> assert false + +let () = + match Ast_helper.Exp.constant (Ast_helper.Const.float "1.0" ~suffix:'f') with + | [%expr [%lit.float? "1.0"] [@suffix? None]] -> assert false + | [%expr [%lit.float? "1.0"] [@suffix? Some 'f']] -> () + | _ -> assert false