Literal quotations for OCaml 4.11

Implements (partially) ocaml-ppx#83.

Author: thierry-martinez

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

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

ppx_metaquot.ml

@@ -127,6 +127,54 @@ 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
+        let inside_loc =
+          match find_attr_loc "loc" attrs with
+          | Some attr -> of_payload attr.loc attr.txt
+          | None -> loc_exp in
+        Some (construct (Longident.Lident "Pconst_string")
+          [arg; inside_loc; 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 +185,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)
@@ -188,8 +258,25 @@ end = struct
         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

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.10.0"}
   "dune" {>= "1.6"}

tests/test_metaquot_lit/dune

@@ -0,0 +1,4 @@
+(test
+  (name test_metaquot_lit)
+  (flags -dsource)
+  (preprocess (staged_pps ppx_tools.metaquot)))

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