playground: reason syntax and react ppx

.github/workflows/opam-build.yml

@@ -57,6 +57,11 @@ jobs:
           opam update
           make opam-install-test
 
+      - name: Test playground
+        working-directory: melange
+        run: |
+          make playground-test
+
       - name: Clone melange-opam-template
         run: |
           git clone https://github.com/melange-re/melange-opam-template.git

Makefile

@@ -40,3 +40,19 @@ opam-install-dev: opam-install-test ## Install development dependencies
 
 .PHONY: opam-init
 opam-init: opam-create-switch opam-install-test ## Configure everything to develop this repository in local
+
+.PHONY: playground
+playground:
+	opam exec -- dune build --profile=browser bin/jsoo_main.bc.js
+
+.PHONY: playground-dev
+playground-dev:
+	opam exec -- dune build --profile=browser-dev bin/jsoo_main.bc.js
+
+.PHONY: playground-dev-test
+playground-dev-test:
+	opam exec -- dune build --profile=browser-dev @@test/blackbox-tests/playground
+
+.PHONY: playground-test
+playground-test:
+	opam exec -- dune build --profile=browser @@test/blackbox-tests/playground

bin/dune

@@ -13,3 +13,10 @@
  (package melange)
  (modules melppx)
  (libraries melange.ppx ppxlib))
+
+(executable
+ (name jsoo_main)
+ (flags :standard -open Melange_compiler_libs)
+ (modules jsoo_main jsoo_common)
+ (libraries core melange_compiler_libs melange_ppx reactjs-jsx-ppx reason)
+ (modes js))

bin/jsoo_common.ml

@@ -6,6 +6,8 @@ module Js = struct
     external get : 'a -> 'b -> 'c = "caml_js_get"
     external set : 'a -> 'b -> 'c -> unit = "caml_js_set"
     external pure_js_expr : string -> 'a = "caml_pure_js_expr"
+    external js_expr : string -> 'a = "caml_js_expr"
+    external fun_call : 'a -> any array -> 'b = "caml_js_fun_call"
 
     let global = pure_js_expr "joo_global_object"
 
@@ -25,27 +27,125 @@ module Js = struct
 
   type +'a t
   type js_string
+  type number
+  type 'a optdef = 'a
 
   external string : string -> js_string t = "caml_js_from_string"
   external to_string : js_string t -> string = "caml_js_to_string"
   external create_file : js_string t -> js_string t -> unit = "caml_create_file"
   external to_bytestring : js_string t -> string = "caml_js_to_byte_string"
+  external number_of_float : float -> number t = "caml_js_from_float"
+
+  let undefined : 'a optdef = Unsafe.pure_js_expr "undefined"
+end
+
+module Reason = struct
+  (* Adapted from https://github.com/reasonml/reason/blob/da280770cf905502d4b99788d9f3d1462893b53e/js/refmt.ml *)
+  module RE = Reason_toolchain.RE
+  module ML = Reason_toolchain.ML
+
+  let locationToJsObj (loc : Location.t) =
+    let _file, start_line, start_char = Location.get_pos_info loc.loc_start in
+    let _, end_line, end_char = Location.get_pos_info loc.loc_end in
+    (* The right way of handling ocaml syntax error locations. Do do this at home
+       copied over from
+       https://github.com/BuckleScript/bucklescript/blob/2ad2310f18567aa13030cdf32adb007d297ee717/jscomp/super_errors/super_location.ml#L73
+    *)
+    let normalizedRange =
+      if start_char == -1 || end_char == -1 then
+        (* happens sometimes. Syntax error for example *)
+        None
+      else if start_line = end_line && start_char >= end_char then
+        (* in some errors, starting char and ending char can be the same. But
+           since ending char was supposed to be exclusive, here it might end up
+           smaller than the starting char if we naively did start_char + 1 to
+           just the starting char and forget ending char *)
+        let same_char = start_char + 1 in
+        Some ((start_line, same_char), (end_line, same_char))
+      else
+        (* again: end_char is exclusive, so +1-1=0 *)
+        Some ((start_line, start_char + 1), (end_line, end_char))
+    in
+    match normalizedRange with
+    | None -> Js.undefined
+    | Some ((start_line, start_line_start_char), (end_line, end_line_end_char))
+      ->
+        let intToJsFloatToAny i =
+          i |> float_of_int |> Js.number_of_float |> Js.Unsafe.inject
+        in
+        Js.Unsafe.obj
+          [|
+            ("startLine", intToJsFloatToAny start_line);
+            ("startLineStartChar", intToJsFloatToAny start_line_start_char);
+            ("endLine", intToJsFloatToAny end_line);
+            ("endLineEndChar", intToJsFloatToAny end_line_end_char);
+          |]
+
+  let parseWith f code =
+    (* you can't throw an Error here. jsoo parses the string and turns it
+       into something else *)
+    let throwAnything = Js.Unsafe.js_expr "function(a) {throw a}" in
+    let code =
+      (* Add ending new line as otherwise reason parser chokes with inputs such as "//" *)
+      Js.to_string code ^ "\n"
+    in
+    try code |> Lexing.from_string |> f
+    with (* from ocaml and reason *)
+    | Reason_errors.Reason_error (err, loc) ->
+      let jsLocation = locationToJsObj loc in
+      Reason_errors.report_error ~loc Format.str_formatter err;
+      let errorString = Format.flush_str_formatter () in
+      let jsError =
+        Js.Unsafe.obj
+          [|
+            ("message", Js.Unsafe.inject (Js.string errorString));
+            ("location", Js.Unsafe.inject jsLocation);
+          |]
+      in
+      Js.Unsafe.fun_call throwAnything [| Js.Unsafe.inject jsError |]
+
+  let parseRE = parseWith RE.implementation_with_comments
+  let parseREI = parseWith RE.interface_with_comments
+  let parseML = parseWith ML.implementation_with_comments
+  let parseMLI = parseWith ML.interface_with_comments
+
+  let printWith f structureAndComments =
+    f Format.str_formatter structureAndComments;
+    Format.flush_str_formatter () |> Js.string
+
+  let printRE = printWith RE.print_implementation_with_comments
+  let printREI = printWith RE.print_interface_with_comments
+  let printML = printWith ML.print_implementation_with_comments
+  let printMLI = printWith ML.print_interface_with_comments
 end
 
-let mk_js_error (loc : Location.t) (msg : string) =
+let mk_js_error (error : Location.report) =
+  let kind, type_ =
+    match error.kind with
+    | Location.Report_error -> ("Error", "error")
+    | Report_warning w -> (Printf.sprintf "Warning: %s" w, "warning")
+    | Report_warning_as_error w ->
+        (Printf.sprintf "Error: (warning %s)" w, "warning_as_error")
+    | Report_alert w -> (Printf.sprintf "Alert: %s" w, "alert")
+    | Report_alert_as_error w ->
+        (Printf.sprintf "Error: (alert %s)" w, "alert_as_error")
+  in
+  let txt = Format.asprintf "@[%t@]" error.main.txt in
+  let loc = error.main.loc in
   let _file, line, startchar = Location.get_pos_info loc.Location.loc_start in
   let _file, endline, endchar = Location.get_pos_info loc.Location.loc_end in
   Js.Unsafe.(
     obj
       [|
         ( "js_error_msg",
           inject
-          @@ Js.string (Printf.sprintf "Line %d, %d:\n  %s" line startchar msg)
+          @@ Js.string
+               (Printf.sprintf "Line %d, %d:\n  %s %s" line startchar kind txt)
         );
         ("row", inject (line - 1));
         ("column", inject startchar);
         ("endRow", inject (endline - 1));
         ("endColumn", inject endchar);
-        ("text", inject @@ Js.string msg);
-        ("type", inject @@ Js.string "error");
+        ("text", inject @@ Js.string txt);
+        ("type", inject @@ Js.string type_);
       |])

bin/jsoo_common.mli

@@ -34,7 +34,25 @@ module Js : sig
   external to_bytestring : js_string t -> string = "caml_js_to_byte_string"
 end
 
+module Reason : sig
+  val parseRE :
+    Js.js_string Js.t ->
+    Reason_toolchain_conf.Parsetree.structure * Reason_comment.t list
+
+  val parseML :
+    Js.js_string Js.t ->
+    Reason_toolchain_conf.Parsetree.structure * Reason_comment.t list
+
+  val printRE :
+    Reason_toolchain_conf.Parsetree.structure * Reason_comment.t list ->
+    Js.js_string Js.t
+
+  val printML :
+    Reason_toolchain_conf.Parsetree.structure * Reason_comment.t list ->
+    Js.js_string Js.t
+end
+
 (*
-Creates a Js Error object for given location with and a certain error message
+Creates a Js Error object for given location report
 *)
-val mk_js_error : Location.t -> string -> Js.Unsafe.obj
+val mk_js_error : Location.report -> Js.Unsafe.obj

bin/jsoo_main.ml

@@ -23,17 +23,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 module Js = Jsoo_common.Js
-(** *)
 
-(*
- Error:
-     *  {
-     *    row: 12,
-     *    column: 2, //can be undefined
-     *    text: "Missing argument",
-     *    type: "error" // or "warning" or "info"
-     *  }
-*)
 let () =
   Bs_conditional_initial.setup_env ();
   Clflags.binary_annotations := false
@@ -43,7 +33,12 @@ let error_of_exn e =
   | Some (`Ok e) -> Some e
   | Some `Already_displayed | None -> None
 
-let implementation ~use_super_errors impl str : Js.Unsafe.obj =
+module Convert =
+  Ppxlib_ast.Convert
+    (Ppxlib_ast__.Versions.OCaml_414)
+    (Ppxlib_ast__.Versions.OCaml_current)
+
+let compile impl str : Js.Unsafe.obj =
   let modulename = "Test" in
   (* let env = !Toploop.toplevel_env in *)
   (* Res_compmisc.init_path false; *)
@@ -54,71 +49,65 @@ let implementation ~use_super_errors impl str : Js.Unsafe.obj =
   (* Question ?? *)
   (* let finalenv = ref Env.empty in *)
   let types_signature = ref [] in
-  if use_super_errors then (
-    Misc.Color.setup (Some Always);
-    Lazy.force Super_main.setup);
-
   try
-    Js_config.jsx_version := 3;
     (* default *)
     let ast = impl (Lexing.from_string str) in
-    let ast = Ppx_entry.rewrite_implementation ast in
+    let ast : Parsetree.structure =
+      let ppxlib_ast : Ppxlib_ast__.Versions.OCaml_414.Ast.Parsetree.structure =
+        Obj.magic (ast : Parsetree.structure)
+      in
+      let converted =
+        Convert.copy_structure (Ppxlib.Driver.map_structure ppxlib_ast)
+      in
+      (Obj.magic converted : Parsetree.structure)
+    in
     let typed_tree =
-      let a, b, _, signature =
+      let { Typedtree.structure; coercion; shape = _; signature }, _finalenv =
         Typemod.type_implementation_more modulename modulename modulename env
           ast
       in
       (* finalenv := c ; *)
       types_signature := signature;
-      (a, b)
+      (structure, coercion)
     in
     typed_tree |> Translmod.transl_implementation modulename
-    |> (* Printlambda.lambda ppf *) fun { Lambda.code = lam } ->
+    |> (* Printlambda.lambda ppf *) fun { Lambda.code = lam; _ } ->
     let buffer = Buffer.create 1000 in
     let () =
       Js_dump_program.pp_deps_program ~output_prefix:""
-        (* does not matter here *) NodeJS
-        (Lam_compile_main.compile "" lam)
+        ~package_info:Js_packages_info.empty
+        ~output_info:{ Js_packages_info.module_system = NodeJS; suffix = Js }
         (Ext_pp.from_buffer buffer)
+        (Lam_compile_main.compile "" lam)
     in
     let v = Buffer.contents buffer in
     Js.Unsafe.(obj [| ("js_code", inject @@ Js.string v) |])
     (* Format.fprintf output_ppf {| { "js_code" : %S }|} v ) *)
   with e -> (
     match error_of_exn e with
-    | Some error ->
-        Location.report_error Format.err_formatter error;
-        Jsoo_common.mk_js_error error.loc error.msg
+    | Some error -> Jsoo_common.mk_js_error error
     | None ->
         Js.Unsafe.(
           obj [| ("js_error_msg", inject @@ Js.string (Printexc.to_string e)) |]))
 
-let compile impl ~use_super_errors = implementation ~use_super_errors impl
 let export (field : string) v = Js.Unsafe.set Js.Unsafe.global field v
 
 (* To add a directory to the load path *)
 
-let dir_directory d = Config.load_path := d :: !Config.load_path
-let () = dir_directory "/static"
+let () = Load_path.add_dir "/static"
 
-let make_compiler name impl =
-  export name
+let () =
+  export "ocaml"
     Js.Unsafe.(
       obj
         [|
           ( "compile",
             inject
             @@ Js.wrap_meth_callback (fun _ code ->
-                   compile impl ~use_super_errors:false (Js.to_string code)) );
-          ( "compile_super_errors",
-            inject
-            @@ Js.wrap_meth_callback (fun _ code ->
-                   compile impl ~use_super_errors:true (Js.to_string code)) );
-          ("version", Js.Unsafe.inject (Js.string Bs_version.version));
+                   compile Parse.implementation (Js.to_string code)) );
+          ("version", inject @@ Js.string Melange_version.version);
+          ("parseRE", inject @@ Jsoo_common.Reason.parseRE);
+          ("parseML", inject @@ Jsoo_common.Reason.parseML);
+          ("printRE", inject @@ Jsoo_common.Reason.printRE);
+          ("printML", inject @@ Jsoo_common.Reason.printML);
         |])
-
-let () = make_compiler "ocaml" Parse.implementation
-
-(* local variables: *)
-(* compile-command: "ocamlbuild -use-ocamlfind -pkg compiler-libs -no-hygiene driver.cmo" *)
-(* end: *)

bin/jsoo_main.mli

@@ -21,5 +21,3 @@
  * You should have received a copy of the GNU Lesser General Public License
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-val make_compiler : string -> (Lexing.lexbuf -> Parsetree.structure) -> unit

dune

@@ -8,4 +8,12 @@
   (env-vars
    (CPPO_FLAGS -D=BS_RELEASE_BUILD))
   (ocamlopt_flags
-   (:standard -O3 -unbox-closures))))
+   (:standard -O3 -unbox-closures)))
+ (browser
+  (env-vars
+   (CPPO_FLAGS -D=BS_BROWSER)))
+ (browser-dev
+  (js_of_ocaml
+   (compilation_mode separate))
+  (env-vars
+   (CPPO_FLAGS -D=BS_BROWSER))))

dune-project

@@ -44,6 +44,7 @@
   (cppo :build)
   (ounit :with-test)
   (reason :with-test)
+  (js_of_ocaml :with-test)
   ppxlib
   menhir
   (reactjs-jsx-ppx :with-test)))

jscomp/core/js_dump_program.mli

@@ -32,3 +32,11 @@ val dump_deps_program :
   J.deps_program ->
   out_channel ->
   unit
+
+val pp_deps_program :
+  package_info:Js_packages_info.t ->
+  output_info:Js_packages_info.output_info ->
+  output_prefix:string ->
+  Ext_pp.t ->
+  J.deps_program ->
+  unit

jscomp/core/js_name_of_module_id.ml

@@ -159,19 +159,3 @@ let string_of_module_id ~package_info ~output_info
                   ~to_:(Ext_path.absolute_cwd_path dirname)
                   basename
             | None -> Bs_exception.error (Js_not_found js_file))))
-;;
-
-(* Override it in browser *)
-#ifdef BS_BROWSER
-
-let string_of_module_id_in_browser (x : Lam_module_ident.t) =
-  match x.kind with
-  | External { name } -> name
-  | Runtime | Ml -> "./stdlib/" ^ String.uncapitalize_ascii x.id.name ^ ".js"
-
-let string_of_module_id ~package_info:_ ~output_info:_ (id : Lam_module_ident.t)
-    ~output_dir:(_ : string) : string =
-  string_of_module_id_in_browser id
-;;
-
-#endif