diff --git a/ast_convenience.ml b/ast_convenience.ml index 62dc655..80d6a53 100644 --- a/ast_convenience.ml +++ b/ast_convenience.ml @@ -109,6 +109,12 @@ let find_attr s attrs = try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) with Not_found -> None +let find_attr_loc s attrs = + match List.find_opt (fun {attr_name=x;_} -> x.txt = s) attrs with + | None -> None + | Some attr -> + Some { Location.txt = attr.attr_payload; loc = attr.attr_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/ppx_metaquot.ml b/ppx_metaquot.ml index 943c06a..7320315 100644 --- a/ppx_metaquot.ml +++ b/ppx_metaquot.ml @@ -127,6 +127,50 @@ end = struct Location.print_report Format.err_formatter report; 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 @@ -137,9 +181,31 @@ 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_loc_stack" }, + exp_construct loc (Lident "[]") []; + { 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) @@ -184,12 +250,29 @@ end = struct | "pexp_loc_stack" | "ppat_loc_stack" | "ptyp_loc_stack" -> name, Pat.any () | _ -> name, pat) fields - in + in builder#record n fields (* 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 diff --git a/ppx_tools.opam b/ppx_tools.opam index 7579749..1e01684 100644 --- a/ppx_tools.opam +++ b/ppx_tools.opam @@ -7,7 +7,8 @@ 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] +build: ["dune" "build" "-p" name "-j" jobs + "@runtest" {with-test}] depends: [ "ocaml" {>= "4.08.0"} "dune" {>= "1.6"} diff --git a/tests/test_metaquot_lit/dune b/tests/test_metaquot_lit/dune new file mode 100644 index 0000000..cb87acb --- /dev/null +++ b/tests/test_metaquot_lit/dune @@ -0,0 +1,4 @@ +(test + (name test_metaquot_lit) + (flags -dsource) + (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