Translate into AST compatible with react ppx

andreypopp · andreypopp · commit 58c8ab4fc1b4 · 2023-09-01T20:23:03.000+04:00
diff --git a/.rgignore b/.rgignore
@@ -0,0 +1,2 @@
+merlin
+merlin-extend
diff --git a/mlx/jsx_helper.ml b/mlx/jsx_helper.ml
@@ -0,0 +1,44 @@
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+
+let make_loc (startpos, endpos) =
+  {
+    Location.loc_start = startpos;
+    Location.loc_end = endpos;
+    Location.loc_ghost = false;
+  }
+
+let mkloc = Location.mkloc
+let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
+
+let mkjsxexp ~loc e =
+  let e = mkexp ~loc e in
+  let attr =
+    let loc = make_loc loc in
+    Attr.mk ~loc { txt = "JSX"; loc } (PStr [])
+  in
+  { e with pexp_attributes = [ attr ] }
+
+let make_jsx_element ~loc ~tag ~props ~children () =
+  let tag = mkexp ~loc (Pexp_ident tag) in
+  let props =
+    List.map
+      (function
+        | loc, `Prop_punned name ->
+            let id = mkloc (Lident name) (make_loc loc) in
+            Labelled name, mkexp ~loc (Pexp_ident id)
+        | _loc, `Prop (name, expr) -> Labelled name, expr)
+      props
+  in
+  let unit =
+    mkexp ~loc
+      (Pexp_construct ({ txt = Lident "()"; loc = make_loc loc }, None))
+  in
+  let props =
+    match children with
+    | None -> props
+    | Some children -> (Labelled "children", children) :: props
+  in
+  Pexp_apply (tag, (Nolabel, unit) :: props)
diff --git a/mlx/parser.mly b/mlx/parser.mly
@@ -2389,6 +2389,7 @@ simple_expr:
   | simple_expr_attrs
     { let desc, attrs = $1 in
       mkexp_attrs ~loc:$sloc desc attrs }
+  | e = jsx_element { Jsx_helper.mkjsxexp ~loc:$loc(e) e }
   | mkexp(simple_expr_)
       { $1 }
 ;
@@ -2499,36 +2500,23 @@ simple_expr:
   | mod_longident DOT
     LPAREN MODULE ext_attributes module_expr COLON error
       { unclosed "(" $loc($3) ")" $loc($8) }
-  | e = jsx_element { e }
 ;
 jsx_element:
     tag=mkrhs(jsx_longident) props=llist(jsx_prop) SLASHGREATER {
-      let tag = mkexp ~loc:$loc(tag) (Pexp_ident tag) in
-      let head = mkexp ~loc:$loc(tag) (Pexp_apply (tag, props)) in
-      Pexp_extension (mkloc "jsx" (make_loc $sloc), PStr [mkstrexp head []])
-    }
+      Jsx_helper.make_jsx_element () ~loc:$loc(tag) ~tag ~props ~children:None }
   | tag=mkrhs(jsx_longident) props=llist(jsx_prop) 
-    GREATER children=llist(jsx_content) LESSSLASH mkrhs(val_longident) GREATER {
-      let tag = mkexp ~loc:$loc(tag) (Pexp_ident tag) in
-      let head = mkexp ~loc:$loc(tag) (Pexp_apply (tag, props)) in
-      let children = List.map (fun e -> mkstrexp e []) children in
-      Pexp_extension (mkloc "jsx_with_children" (make_loc $sloc), PStr ((mkstrexp head [])::children))
+    GREATER children=llist(simple_expr) LESSSLASH mkrhs(val_longident) GREATER {
+      let children = 
+        let children, loc = mktailexp $loc(children) children in
+        mkexp ~loc children
+      in
+      Jsx_helper.make_jsx_element () ~loc:$loc(tag) ~tag ~props ~children:(Some children)
     }
 ;
-jsx_content:
-    LPAREN seq_expr RPAREN
-      { reloc_exp ~loc:$sloc $2 }
-  | mkexp(simple_expr_)
-      { $1 }
-;
 jsx_prop:
-   id=LIDENT
-    { let id = mkloc (Lident id) (make_loc $loc(id)) in
-      let e = mkexp ~loc:$loc(id) (Pexp_ident id) in
-      (Nolabel, e) }
-  | k=LIDENT EQUAL e=simple_expr
-      { (Labelled k, e) }
-
+    name=LIDENT { $loc(name), `Prop_punned name }
+  | name=LIDENT EQUAL expr=simple_expr { $loc(name), `Prop (name, expr) }
+;
 labeled_simple_expr:
     simple_expr %prec below_HASH
       { (Nolabel, $1) }
diff --git a/mlx/pp.ml b/mlx/pp.ml
@@ -1,6 +1,17 @@
+let print_ml = ref false
+let input = ref None
+let speclist = [ "-print-ml", Arg.Set print_ml, "Print .ml syntax" ]
+
 let () =
-  let fname = Sys.argv.(1) in
-  let src = In_channel.with_open_bin fname In_channel.input_all in
+  Arg.parse speclist
+    (fun input' -> input := Some input')
+    "mlx-pp [-print-ml] <input-file>";
+  let fname, src =
+    match !input with
+    | None -> "*stdin*", In_channel.input_all stdin
+    | Some fname ->
+        fname, In_channel.with_open_bin fname In_channel.input_all
+  in
   let lexbuf = Lexing.from_string src in
   Lexing.set_filename lexbuf fname;
   let str =
@@ -12,10 +23,12 @@ let () =
   in
   match str with
   | Ok str ->
-      let oc = stdout in
-      output_string oc Config.ast_impl_magic_number;
-      output_value oc fname;
-      output_value oc str
+      if !print_ml then Format.printf "%a@." Pprintast.structure str
+      else
+        let oc = stdout in
+        output_string oc Config.ast_impl_magic_number;
+        output_value oc fname;
+        output_value oc str
   | Error `Already_displayed -> exit 1
   | Error (`Ok error) ->
       Format.eprintf "%a@." Location.print_report error;
diff --git a/ocamlmerlin_mlx/dune b/ocamlmerlin_mlx/dune
@@ -46,6 +46,8 @@
  (action
   (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
 
+(copy_files# ../mlx/jsx_helper.ml)
+
 (copy_files# ../merlin-extend/*[!extend_helper].{ml,mli})
 
 (copy_files# ../merlin/src/kernel/extension.{ml,mli})
diff --git a/ocamlmerlin_mlx/parser_raw.mly b/ocamlmerlin_mlx/parser_raw.mly
@@ -2533,6 +2533,7 @@ let_pattern [@recovery default_pattern ()]:
   | simple_expr_attrs
     { let desc, attrs = $1 in
       mkexp_attrs ~loc:$sloc desc attrs }
+  | e = jsx_element { Jsx_helper.mkjsxexp ~loc:$loc(e) e }
   | mkexp(simple_expr_)
       { $1 }
 ;
@@ -2672,35 +2673,22 @@ let_pattern [@recovery default_pattern ()]:
     LPAREN MODULE ext_attributes module_expr COLON error
       { unclosed "(" $loc($3) ")" $loc($8) }
   *)
-  | e = jsx_element { e }
 ;
 jsx_element:
     tag=mkrhs(jsx_longident) props=llist(jsx_prop) SLASHGREATER {
-      let tag = mkexp ~loc:$loc(tag) (Pexp_ident tag) in
-      let head = mkexp ~loc:$loc(tag) (Pexp_apply (tag, props)) in
-      Pexp_extension (mkloc "jsx" (make_loc $sloc), PStr [mkstrexp head []])
-    }
+      Jsx_helper.make_jsx_element () ~loc:$loc(tag) ~tag ~props ~children:None }
   | tag=mkrhs(jsx_longident) props=llist(jsx_prop) 
-    GREATER children=llist(jsx_content) LESSSLASH mkrhs(val_longident) GREATER {
-      let tag = mkexp ~loc:$loc(tag) (Pexp_ident tag) in
-      let head = mkexp ~loc:$loc(tag) (Pexp_apply (tag, props)) in
-      let children = List.map (fun e -> mkstrexp e []) children in
-      Pexp_extension (mkloc "jsx_with_children" (make_loc $sloc), PStr ((mkstrexp head [])::children))
+    GREATER children=llist(simple_expr) LESSSLASH mkrhs(val_longident) GREATER {
+      let children = 
+        let children, loc = mktailexp $loc(children) children in
+        mkexp ~loc children
+      in
+      Jsx_helper.make_jsx_element () ~loc:$loc(tag) ~tag ~props ~children:(Some children)
     }
 ;
-jsx_content:
-    LPAREN seq_expr RPAREN
-      { reloc_exp ~loc:$sloc $2 }
-  | mkexp(simple_expr_)
-      { $1 }
-;
 jsx_prop:
-   id=LIDENT
-    { let id = mkloc (Lident id) (make_loc $loc(id)) in
-      let e = mkexp ~loc:$loc(id) (Pexp_ident id) in
-      (Nolabel, e) }
-  | k=LIDENT EQUAL e=simple_expr
-      { (Labelled k, e) }
+    name=LIDENT { $loc(name), `Prop_punned name }
+  | name=LIDENT EQUAL expr=simple_expr { $loc(name), `Prop (name, expr) }
 ;
 labeled_simple_expr:
     simple_expr %prec below_HASH
diff --git a/test/dune b/test/dune
@@ -0,0 +1,3 @@
+(cram
+ (deps (package mlx) ./mlx))
+
diff --git a/test/mlx b/test/mlx
@@ -0,0 +1,3 @@
+#!/bin/bash
+
+mlx-pp -print-ml | ocamlformat - --impl --enable-outside-detected-project
diff --git a/test/mlx.t b/test/mlx.t
@@ -0,0 +1,9 @@
+
+  $ echo 'let _ = <div />' | ./mlx
+  let _ = div () [@JSX]
+
+  $ echo 'let _ = <div>hello world</div>' | ./mlx
+  let _ = div () ~children:[ hello; world ] [@JSX]
+
+  $ echo 'let _ = <div attr with_value=1 />' | ./mlx
+  let _ = div () ~attr ~with_value:1 [@JSX]

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+(cram`
	`2`	`+ (deps (package mlx) ./mlx))`
	`3`	`+`
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+#!/bin/bash`
	`2`	`+`
	`3`	`+mlx-pp -print-ml \| ocamlformat - --impl --enable-outside-detected-project`