Compiler: modernize js parser (part 2)

Author: hhugo

compiler/lib/driver.ml

@@ -216,20 +216,21 @@ let gen_missing js missing =
               , dot (EVar (ident Constant.global_object_)) prim
               , EFun
                   ( None
-                  , { async = false; generator = false }
-                  , []
-                  , [ ( Expression_statement
-                          (call
-                             (EVar (ident_s "caml_failwith"))
-                             [ EBin
-                                 ( Plus
-                                 , EStr prim
-                                 , EStr (Utf8_string.of_string_exn " not implemented") )
-                             ]
-                             N)
-                      , N )
-                    ]
-                  , N ) )
+                  , fun_
+                      []
+                      [ ( Expression_statement
+                            (call
+                               (EVar (ident_s "caml_failwith"))
+                               [ EBin
+                                   ( Plus
+                                   , EStr prim
+                                   , EStr (Utf8_string.of_string_exn " not implemented")
+                                   )
+                               ]
+                               N)
+                        , N )
+                      ]
+                      N ) )
           , N ) )
         :: acc)
       missing
@@ -435,14 +436,8 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
       else js
     in
 
-    let efun args body =
-      J.EFun (None, { async = false; generator = false }, args, body, J.U)
-    in
-    let sfun name args body =
-      ( J.Function_declaration
-          (name, { async = false; generator = false }, args, body, J.U)
-      , J.U )
-    in
+    let efun args body = J.EFun (None, J.fun_ args body J.U) in
+    let sfun name args body = J.Function_declaration (name, J.fun_ args body J.U), J.U in
     let mk f =
       let js = export_shim js in
       let js = old_global_object_shim js in
@@ -451,7 +446,7 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
         then expr (J.EStr (Utf8_string.of_string_exn "use strict")) :: js
         else js
       in
-      f [ J.param Constant.global_object_ ] js
+      f [ J.ident Constant.global_object_ ] js
     in
     match wrap_with_fun with
     | `Anonymous -> expr (mk efun)

compiler/lib/dune

@@ -35,9 +35,7 @@
   --unused-token
   T_AT
   --unused-token
-  T_POUND
-  --unused-token
-  T_TEMPLATE_PART))
+  T_POUND))
 
 (menhir
  (modules annot_parser)

compiler/lib/flow_lexer.ml

@@ -7,6 +7,13 @@
 
 open Js_token
 
+module Lex_mode = struct
+  type t =
+    | NORMAL
+    | BACKQUOTE
+    | REGEXP
+end
+
 module Loc = struct
   (* line numbers are 1-indexed; column numbers are 0-indexed *)
 
@@ -41,6 +48,7 @@ module Lex_env = struct
     { lex_source : string option
     ; lex_lb : Sedlexing.lexbuf
     ; lex_state : lex_state
+    ; lex_mode_stack : Lex_mode.t list
     }
   [@@ocaml.warning "-69"]
 
@@ -55,9 +63,24 @@ module Lex_env = struct
       | "" -> None
       | s -> Some s
     in
-    { lex_source; lex_lb; lex_state = empty_lex_state }
+    { lex_source
+    ; lex_lb
+    ; lex_state = empty_lex_state
+    ; lex_mode_stack = [ Lex_mode.NORMAL ]
+    }
 end
 
+let push_mode env mode =
+  { env with Lex_env.lex_mode_stack = mode :: env.Lex_env.lex_mode_stack }
+
+let pop_mode env =
+  { env with
+    Lex_env.lex_mode_stack =
+      (match env.Lex_env.lex_mode_stack with
+      | [] -> []
+      | _ :: xs -> xs)
+  }
+
 module Lex_result = struct
   type t =
     { lex_token : Js_token.t
@@ -424,7 +447,8 @@ let rec string_quote env q buf lexbuf =
   | '\\', line_terminator_sequence -> string_quote env q buf lexbuf
   | '\\' ->
       let env, str = string_escape env lexbuf in
-      if String.get q 0 <> String.get str 0 then Buffer.add_string buf "\\";
+      if String.equal str "" || String.get q 0 <> String.get str 0
+      then Buffer.add_string buf "\\";
       Buffer.add_string buf str;
       string_quote env q buf lexbuf
   | '\n' ->
@@ -444,47 +468,6 @@ let rec string_quote env q buf lexbuf =
       string_quote env q buf lexbuf
   | _ -> failwith "unreachable string_quote"
 
-let rec template_part env cooked raw literal lexbuf =
-  match%sedlex lexbuf with
-  | eof ->
-      let env = illegal env (loc_of_lexbuf env lexbuf) in
-      env, true
-  | '`' ->
-      Buffer.add_char literal '`';
-      env, true
-  | "${" ->
-      Buffer.add_string literal "${";
-      env, false
-  | '\\' ->
-      Buffer.add_char raw '\\';
-      Buffer.add_char literal '\\';
-      let env, str = string_escape env lexbuf in
-      Buffer.add_string raw str;
-      Buffer.add_string literal str;
-      template_part env cooked raw literal lexbuf
-  (* ECMAScript 6th Syntax, 11.8.6.1 Static Semantics: TV's and TRV's
-   * Long story short, <LF> is 0xA, <CR> is 0xA, and <CR><LF> is 0xA
-   * *)
-  | "\r\n" ->
-      Buffer.add_string raw "\r\n";
-      Buffer.add_string literal "\r\n";
-      Buffer.add_string cooked "\n";
-      template_part env cooked raw literal lexbuf
-  | "\n" | "\r" ->
-      let lf = lexeme lexbuf in
-      Buffer.add_string raw lf;
-      Buffer.add_string literal lf;
-      Buffer.add_char cooked '\n';
-      template_part env cooked raw literal lexbuf
-  (* match multi-char substrings that don't contain the start chars of the above patterns *)
-  | Plus (Compl (eof | '`' | '$' | '\\' | '\r' | '\n')) | any ->
-      let c = lexeme lexbuf in
-      Buffer.add_string raw c;
-      Buffer.add_string literal c;
-      Buffer.add_string cooked c;
-      template_part env cooked raw literal lexbuf
-  | _ -> failwith "unreachable template_part"
-
 let token (env : Lex_env.t) lexbuf : result =
   match%sedlex lexbuf with
   | line_terminator_sequence -> Continue env
@@ -519,15 +502,8 @@ let token (env : Lex_env.t) lexbuf : result =
         , T_STRING (Stdlib.Utf8_string.of_string_exn (Buffer.contents buf), p2 - p1 - 1)
         )
   | '`' ->
-      let cooked = Buffer.create 127 in
-      let raw = Buffer.create 127 in
-      let literal = Buffer.create 127 in
-      lexeme_to_buffer lexbuf literal;
-      let env, is_tail = template_part env cooked raw literal lexbuf in
-      Token
-        ( env
-        , T_TEMPLATE_PART (Stdlib.Utf8_string.of_string_exn (Buffer.contents raw), is_tail)
-        )
+      let env = push_mode env BACKQUOTE in
+      Token (env, T_BACKQUOTE)
   | binbigint, word ->
       (* Numbers cannot be immediately followed by words *)
       recover env lexbuf ~f:(fun env lexbuf ->
@@ -632,8 +608,12 @@ let token (env : Lex_env.t) lexbuf : result =
           | _ -> failwith "unreachable token wholenumber")
   | wholenumber | floatnumber -> Token (env, T_NUMBER (NORMAL, lexeme lexbuf))
   (* Syntax *)
-  | "{" -> Token (env, T_LCURLY)
-  | "}" -> Token (env, T_RCURLY)
+  | "{" ->
+      let env = push_mode env NORMAL in
+      Token (env, T_LCURLY)
+  | "}" ->
+      let env = pop_mode env in
+      Token (env, T_RCURLY)
   | "(" -> Token (env, T_LPAREN)
   | ")" -> Token (env, T_RPAREN)
   | "[" -> Token (env, T_LBRACKET)
@@ -811,6 +791,31 @@ let regexp env lexbuf =
       Token (env, T_ERROR (lexeme lexbuf))
   | _ -> failwith "unreachable regexp"
 
+(*****************************************************************************)
+(* Rule backquote *)
+(*****************************************************************************)
+
+let backquote env lexbuf =
+  match%sedlex lexbuf with
+  | '`' ->
+      let env = pop_mode env in
+      Token (env, T_BACKQUOTE)
+  | "${" ->
+      let env = push_mode env NORMAL in
+      Token (env, T_DOLLARCURLY)
+  | Plus (Compl ('`' | '$' | '\\')) -> Token (env, T_ENCAPSED_STRING (lexeme lexbuf))
+  | '$' -> Token (env, T_ENCAPSED_STRING (lexeme lexbuf))
+  | '\\' ->
+      let buf = Buffer.create 127 in
+      Buffer.add_char buf '\\';
+      let env, str = string_escape env lexbuf in
+      Buffer.add_string buf str;
+      Token (env, T_ENCAPSED_STRING (Buffer.contents buf))
+  | eof -> Token (env, T_EOF)
+  | _ ->
+      let env = illegal env (loc_of_lexbuf env lexbuf) in
+      Token (env, T_ERROR (lexeme lexbuf))
+
 let wrap f =
   let f env =
     let start, _ = Sedlexing.lexing_positions env.Lex_env.lex_lb in
@@ -843,3 +848,11 @@ let wrap f =
 let regexp = wrap regexp
 
 let token = wrap token
+
+let backquote = wrap backquote
+
+let lex env =
+  match env.Lex_env.lex_mode_stack with
+  | Lex_mode.NORMAL :: _ | [] -> token env
+  | Lex_mode.BACKQUOTE :: _ -> backquote env
+  | Lex_mode.REGEXP :: _ -> regexp env

compiler/lib/flow_lexer.mli

@@ -5,6 +5,13 @@
  * LICENSE file in the root directory of this source tree.
  *)
 
+module Lex_mode : sig
+  type t =
+    | NORMAL
+    | BACKQUOTE
+    | REGEXP
+end
+
 module Parse_error : sig
   type t
 
@@ -41,4 +48,6 @@ val regexp : Lex_env.t -> Lex_env.t * Lex_result.t
 
 val token : Lex_env.t -> Lex_env.t * Lex_result.t
 
+val lex : Lex_env.t -> Lex_env.t * Lex_result.t
+
 val is_valid_identifier_name : string -> bool

compiler/lib/generate.ml

@@ -1014,10 +1014,10 @@ let generate_apply_fun ctx { arity; exact; cps } =
   let params' = List.map params ~f:(fun x -> J.EVar x) in
   J.EFun
     ( None
-    , { async = false; generator = false }
-    , List.map ~f:J.param' (f :: params)
-    , [ J.Return_statement (Some (apply_fun_raw ctx f' params' exact cps)), J.N ]
-    , J.N )
+    , J.fun_
+        (f :: params)
+        [ J.Return_statement (Some (apply_fun_raw ctx f' params' exact cps)), J.N ]
+        J.N )
 
 let apply_fun ctx f params exact cps loc =
   (* We always go through an intermediate function when doing CPS
@@ -1246,14 +1246,7 @@ let rec translate_expr ctx queue loc in_tail_position e level : _ * J.statement_
         | (st, J.N) :: rem -> (st, J.U) :: rem
         | _ -> clo
       in
-      let clo =
-        J.EFun
-          ( None
-          , { async = false; generator = false }
-          , List.map args ~f:(fun v -> J.param' (J.V v))
-          , clo
-          , loc )
-      in
+      let clo = J.EFun (None, J.fun_ (List.map args ~f:(fun v -> J.V v)) clo loc) in
       (clo, flush_p, queue), []
   | Constant c ->
       let js, instrs = constant ~ctx c level in
@@ -1422,12 +1415,7 @@ let rec translate_expr ctx queue loc in_tail_position e level : _ * J.statement_
                 loc
             in
             let e =
-              J.EFun
-                ( Some f
-                , { async = false; generator = false }
-                , List.map ~f:J.param' args
-                , [ J.Return_statement (Some call), J.N ]
-                , J.N )
+              J.EFun (Some f, J.fun_ args [ J.Return_statement (Some call), J.N ] J.N)
             in
             e, const_p, queue
         | Extern "caml_alloc_dummy_function", _ -> assert false
@@ -2085,8 +2073,7 @@ let generate_shared_value ctx =
         (Share.AppMap.bindings ctx.Ctx.share.Share.vars.Share.applies)
         ~f:(fun (desc, v) ->
           match generate_apply_fun ctx desc with
-          | J.EFun (_, k, param, body, nid) ->
-              J.Function_declaration (v, k, param, body, nid), J.U
+          | J.EFun (_, decl) -> J.Function_declaration (v, decl), J.U
           | _ -> assert false)
     in
     strings :: applies