Literal quotations for OCaml 4.02

Implements (partially) ocaml-ppx#83.

ast_convenience.ml

@@ -142,6 +142,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 (fun (attr_name, _) -> attr_name.txt = s) attrs with
+  | exception Not_found -> None
+  | (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

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

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)))

ppx_metaquot.ml

@@ -56,7 +56,9 @@
 
 *)
 
-module Main : sig end = struct
+module Main : sig
+  val main : unit -> unit
+end = struct
   open Asttypes
   open Parsetree
   open Ast_helper
@@ -70,7 +72,7 @@ module Main : sig end = struct
 
   let append ?loc ?attrs e e' =
     let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in
-    Exp.apply ?loc ?attrs (Exp.ident fn) [Asttypes.Nolabel, e; Asttypes.Nolabel, e']
+    Exp.apply ?loc ?attrs (Exp.ident fn) ["", e; "", e']
 
   class exp_builder =
     object
@@ -122,6 +124,46 @@ 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.int" ->
+        Some (construct (Longident.Lident "Const_int") [arg])
+    | "lit.int32" ->
+        Some (construct (Longident.Lident "Const_int32") [arg])
+    | "lit.int64" ->
+        Some (construct (Longident.Lident "Const_int64") [arg])
+    | "lit.char" ->
+        Some (construct (Longident.Lident "Const_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 "Const_string")
+          [arg; quotation_delimiter])
+    | "lit.float" ->
+        Some (construct (Longident.Lident "Const_float") [arg])
+    | _ -> None
+
   let exp_lifter loc map =
     let map = map.Ast_mapper.expr map in
     object
@@ -132,9 +174,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)
@@ -165,8 +227,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
@@ -242,5 +321,5 @@ module Main : sig end = struct
     in
     {super with expr; pat; structure; structure_item}
 
-  let () = Ast_mapper.run_main expander
+  let main () = Ast_mapper.run_main expander
 end

ppx_tools.opam

@@ -0,0 +1,15 @@
+opam-version: "2.0"
+synopsis: "Tools for authors of ppx rewriters and other syntactic tools"
+maintainer: "[email protected]"
+authors: "Alain Frisch <[email protected]>"
+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.04.0" & < "4.05.0"}
+  "dune" {>= "1.6"}
+]

tests/test_metaquot_lit/dune

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

tests/test_metaquot_lit/test_metaquot_lit.ml

@@ -0,0 +1,76 @@
+let () =
+  match [%expr [%lit.int 10]] with
+  | { pexp_desc = Pexp_constant (Const_int 10); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (Const_int 10) with
+  | [%expr [%lit.int? 0]] -> assert false
+  | [%expr [%lit.int? 10]] -> ()
+  | _ -> assert false
+
+let () =
+  match [%expr [%lit.int32 10l]] with
+  | { pexp_desc = Pexp_constant (Const_int32 10l); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (Const_int32 10l) with
+  | [%expr [%lit.int32? 0l]] -> assert false
+  | [%expr [%lit.int32? 10l]] -> ()
+  | _ -> assert false
+
+let () =
+  match [%expr [%lit.int64 10L]] with
+  | { pexp_desc = Pexp_constant (Const_int64 10L); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (Const_int64 10L) with
+  | [%expr [%lit.int64? 0L]] -> assert false
+  | [%expr [%lit.int64? 10L]] -> ()
+  | _ -> assert false
+
+let () =
+  match [%expr [%lit.char 'c']] with
+  | { pexp_desc = Pexp_constant (Const_char 'c'); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (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 (Const_string ("s", None)); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (Const_string ("s", None)) 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 (Const_string ("s", Some "t")); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (Const_string ("s", Some "t")) 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 (Const_float "1.0"); _ } -> ()
+  | _ -> assert false
+
+let () =
+  match Ast_helper.Exp.constant (Const_float "1.0") with
+  | [%expr [%lit.float? "0.0"]] -> assert false
+  | [%expr [%lit.float? "1.0"]] -> ()
+  | _ -> assert false