Literal quotations for OCaml 4.03

thierry-martinez · thierry-martinez · commit 7b52174cdd14 · 2020-05-27T15:21:12.000+02:00
Implements (partially) ocaml-ppx#83.
diff --git a/.merlin b/.merlin
diff --git 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 (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
diff --git 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
@@ -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
@@ -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_metaquot_main.ml b/ppx_metaquot_main.ml
@@ -0,0 +1 @@
+let () = Ppx_metaquot.Main.main ()
diff --git a/ppx_tools.opam 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 <alain.frisch@lexifi.com>"
+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"}
+]
diff --git a/tests/test_metaquot_lit/dune b/tests/test_metaquot_lit/dune
@@ -0,0 +1,3 @@
+(test
+  (name test_metaquot_lit)
+  (preprocess (staged_pps ppx_tools.metaquot)))
diff --git a/tests/test_metaquot_lit/test_metaquot_lit.ml 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

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+(test`
	`2`	`+ (name test_metaquot_lit)`
	`3`	`+ (preprocess (staged_pps ppx_tools.metaquot)))`