Compiler: small refactoring around parsing js

CHANGES.md

@@ -18,6 +18,7 @@
 * Compiler: fix sourcemap warning for empty cma (#1169)
 * Compiler: Strengthen bound checks. (#1172)
 * Compiler: fix `--wrap-with-fun` under node (#653, #1171)
+* Compiler: fix parsing of annotaions in js stubs (#1212, fix #1213)
 * Ppx: allow apostrophe in lident (fix #1183) (#1192)
 * Runtime: fix float parsing in hexadecimal form
 * Graphics: fix mouse_{x,y} (#1206)

compiler/lib/annot_parser.mly

@@ -33,17 +33,17 @@ annot:
   | TProvides TSemi id=TIdent opt=option(prim_annot)
     args=option(delimited(LPARENT, separated_list(TComma,arg_annot),RPARENT))
     endline
-    { `Provides (None,id,(match opt with None -> `Mutator | Some k -> k),args) }
+    { `Provides (id,(match opt with None -> `Mutator | Some k -> k),args) }
   | TRequires TSemi l=separated_nonempty_list(TComma,TIdent) endline
-    { `Requires (None,l) }
+    { `Requires (l) }
   | TVersion TSemi l=separated_nonempty_list(TComma,version) endline
-    { `Version (None,l) }
-  | TWeakdef endline { `Weakdef None }
-  | TAlways endline { `Always None }
+    { `Version (l) }
+  | TWeakdef endline { `Weakdef   }
+  | TAlways endline { `Always   }
   | TIf TSemi name=TIdent endline
-    { `If (None,name) }
+    { `If (name) }
   | TIf TSemi TBang name=TIdent endline
-                           { `Ifnot (None,name) }
+                           { `Ifnot (name) }
 prim_annot:
   | TA_Pure {`Pure}
   | TA_Const {`Pure}

compiler/lib/javascript.ml

@@ -280,6 +280,8 @@ and function_body = source_elements
 
 and program = source_elements
 
+and program_with_annots = ((source_element * location) * Js_token.Annot.t list) list
+
 and source_elements = (source_element * location) list
 
 and source_element =

compiler/lib/javascript.mli

@@ -232,6 +232,8 @@ and program = source_elements
 
 and source_elements = (source_element * location) list
 
+and program_with_annots = ((source_element * location) * Js_token.Annot.t list) list
+
 and source_element =
   | Statement of statement
   | Function_declaration of function_declaration

compiler/lib/js_parser.mly

@@ -96,6 +96,7 @@ T_NOT T_BIT_NOT T_INCR T_DECR T_INCR_NB T_DECR_NB T_DELETE T_TYPEOF T_VOID
 (*-----------------------------------------*)
 
 %token <Parse_info.t> T_VIRTUAL_SEMICOLON
+%token <Js_token.Annot.t> TAnnot
 %token <string * Parse_info.t> TUnknown
 %token <string * Parse_info.t> TComment
 %token <string * Parse_info.t> TCommentLineDirective
@@ -130,7 +131,7 @@ T_IN T_INSTANCEOF
 (* 1 Rules type declaration                                              *)
 (*************************************************************************)
 
-%start <Javascript.program> program
+%start <Javascript.program_with_annots> program
 %start <Javascript.expression> standalone_expression
 
 %%
@@ -140,11 +141,17 @@ T_IN T_INSTANCEOF
 (*************************************************************************)
 
 program:
- | l=source_element* EOF { l }
+ | l=source_element_with_annot* EOF { l }
 
 standalone_expression:
  | e=expression EOF { e }
 
+annot:
+  | a=TAnnot { a }
+
+source_element_with_annot:
+ | annots=annot* s=source_element {s,annots}
+
 source_element:
  | statement
    { let statement, pi = $1 in Statement statement, pi }
@@ -184,7 +191,7 @@ statement:
  | s=statement_need_semi either(T_SEMICOLON, T_VIRTUAL_SEMICOLON) { s }
 
 labeled_statement:
-| l=label T_COLON s=statement { Labelled_statement (l, s), N }
+| l=label T_COLON s=statement { Labelled_statement (fst l, s), Pi (snd l)}
 
 block:
  | block=curly_block(statement*)
@@ -243,10 +250,10 @@ initializer_no_in:
  | T_ASSIGN assignment_expression_no_in { $2, Pi $1 }
 
 continue_statement:
- | pi=T_CONTINUE label? { (Continue_statement $2,Pi pi) }
+ | pi=T_CONTINUE label? { (Continue_statement (Stdlib.Option.map ~f:fst $2),Pi pi) }
 
 break_statement:
- | pi=T_BREAK label? { (Break_statement $2, Pi pi) }
+ | pi=T_BREAK label? { (Break_statement (Stdlib.Option.map ~f:fst $2), Pi pi) }
 
 return_statement:
  | pi=T_RETURN expression? { (Return_statement $2, Pi pi) }
@@ -594,7 +601,7 @@ variable_with_loc:
  | i=T_IDENTIFIER { let name, pi = i in var pi name, pi }
 
 label:
- | T_IDENTIFIER { Label.of_string (fst $1) }
+ | T_IDENTIFIER { Label.of_string (fst $1), snd $1 }
 
 property_name:
  | i=identifier_or_kw { PNI i }

compiler/lib/js_token.ml

@@ -19,6 +19,10 @@
 
 open! Stdlib
 
+module Annot = struct
+  type t = string * Parse_info.t * Primitive.t
+end
+
 type t =
   | T_WITH of Parse_info.t
   | T_WHILE of Parse_info.t
@@ -108,11 +112,13 @@ type t =
   | TUnknown of (string * Parse_info.t)
   | TComment of (string * Parse_info.t)
   | TCommentLineDirective of (string * Parse_info.t)
+  | TAnnot of Annot.t
   | EOF of Parse_info.t
 
 type token = t
 
 let info = function
+  | TAnnot (_, ii, _) -> ii
   | TUnknown (_, ii) -> ii
   | TComment (_, ii) -> ii
   | TCommentLineDirective (_, ii) -> ii
@@ -204,6 +210,7 @@ let info = function
   | T_VIRTUAL_SEMICOLON ii -> ii
 
 let to_string = function
+  | TAnnot (s, _, _) -> s
   | TUnknown (s, _) -> s
   | TComment (s, _) -> s
   | TCommentLineDirective (s, _) -> s
@@ -304,9 +311,5 @@ let to_string_extra x =
   | T_DECR_NB _ -> " (DECR_NB)"
   | T_DECR _ -> " (DECR)"
   | T_VIRTUAL_SEMICOLON _ -> " (virtual)"
+  | TAnnot _ -> "(annot)"
   | _ -> ""
-
-let is_comment = function
-  | TComment _ -> true
-  | TCommentLineDirective _ -> true
-  | _ -> false

compiler/lib/js_token.mli

@@ -15,6 +15,9 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
+module Annot : sig
+  type t = string * Parse_info.t * Primitive.t
+end
 
 type t =
   | T_WITH of Parse_info.t
@@ -105,6 +108,7 @@ type t =
   | TUnknown of (string * Parse_info.t)
   | TComment of (string * Parse_info.t)
   | TCommentLineDirective of (string * Parse_info.t)
+  | TAnnot of Annot.t
   | EOF of Parse_info.t
 
 type token = t
@@ -114,5 +118,3 @@ val info : t -> Parse_info.t
 val to_string : t -> string
 
 val to_string_extra : t -> string
-
-val is_comment : t -> bool

compiler/lib/linker.ml

@@ -23,8 +23,7 @@ open! Stdlib
 module Fragment = struct
   type fragment_ =
     { provides :
-        (Parse_info.t option * string * Primitive.kind * Primitive.kind_arg list option)
-        option
+        (Parse_info.t * string * Primitive.kind * Primitive.kind_arg list option) option
     ; requires : string list
     ; version_constraint : ((int -> int -> bool) * string) list list
     ; weakdef : bool
@@ -47,32 +46,14 @@ end
 
 let loc pi =
   match pi with
-  | Some { Parse_info.src = Some src; line; _ }
-  | Some { Parse_info.name = Some src; line; _ } -> Printf.sprintf "%s:%d" src line
-  | None | Some _ -> "unknown location"
-
-let parse_annot loc s =
-  match String.drop_prefix ~prefix:"//" s with
-  | None -> None
-  | Some s -> (
-      let buf = Lexing.from_string s in
-      try
-        match Annot_parser.annot Annot_lexer.main buf with
-        | `Requires (_, l) -> Some (`Requires (Some loc, l))
-        | `Provides (_, n, k, ka) -> Some (`Provides (Some loc, n, k, ka))
-        | `Version (_, l) -> Some (`Version (Some loc, l))
-        | `Weakdef _ -> Some (`Weakdef (Some loc))
-        | `Always _ -> Some (`Always (Some loc))
-        | `If (_, name) -> Some (`If (Some loc, name))
-        | `Ifnot (_, name) -> Some (`Ifnot (Some loc, name))
-      with
-      | Not_found -> None
-      | _ -> None)
+  | { Parse_info.src = Some src; line; _ } | { Parse_info.name = Some src; line; _ } ->
+      Printf.sprintf "%s:%d" src line
+  | _ -> "unknown location"
 
 let error s = Format.ksprintf (fun s -> failwith s) s
 
 let parse_from_lex ~filename lex =
-  let program, _prev, comments =
+  let program, _ =
     try Parse_js.parse' lex
     with Parse_js.Parsing_error pi ->
       let name =
@@ -87,54 +68,22 @@ let parse_from_lex ~filename lex =
         pi.Parse_info.line
         pi.Parse_info.col
   in
-  let rec take_annot_before loc acc = function
-    | [] -> acc, []
-    | x :: l ->
-        if (Js_token.info x).Parse_info.idx <= loc.Parse_info.idx
-        then
-          let acc =
-            match x with
-            | Js_token.TComment (str, info) -> (
-                match parse_annot info str with
-                | None -> acc
-                | Some a -> a :: acc)
-            | Js_token.TCommentLineDirective (_, _) -> []
-            | _ -> acc
-          in
-          take_annot_before loc acc l
-        else acc, x :: l
-  in
-  let status, blocks, _comments =
-    List.fold_left
-      program
-      ~init:(`Annot [], [], comments)
-      ~f:(fun (status, blocks, comments) t ->
-        match t with
-        | _, Javascript.Pi loc ->
-            let a, rest = take_annot_before loc [] comments in
-            let status, blocks =
-              match a, status with
-              | [], `Code (annot, code) -> `Code (annot, t :: code), blocks
-              | annot1, `Annot annot2 -> `Code (annot1 @ annot2, [ t ]), blocks
-              | annot1, `Code (annot2, code2) ->
-                  `Code (annot1, [ t ]), (List.rev annot2, List.rev code2) :: blocks
-            in
-            status, blocks, rest
-        | _, Javascript.N ->
-            (* FIXME: This is not correct *)
-            let status, blocks =
-              match status with
-              | `Code (annot, code) -> `Code (annot, t :: code), blocks
-              | `Annot annot -> `Code (annot, [ t ]), blocks
-            in
-            status, blocks, comments
-        | _, Javascript.U -> assert false)
+  let rec collect_without_annot acc = function
+    | [] -> List.rev acc, []
+    | (x, []) :: program -> collect_without_annot (x :: acc) program
+    | (_, _ :: _) :: _ as program -> List.rev acc, program
   in
-  let blocks =
-    match status with
-    | `Annot _ -> blocks
-    | `Code (annot, code) -> (List.rev annot, List.rev code) :: blocks
+  let rec collect acc program =
+    match program with
+    | [] -> List.rev acc
+    | (x, []) :: program ->
+        let code, program = collect_without_annot [ x ] program in
+        collect (([], code) :: acc) program
+    | (x, annots) :: program ->
+        let code, program = collect_without_annot [ x ] program in
+        collect ((annots, code) :: acc) program
   in
+  let blocks = collect [] program in
   let res =
     List.rev_map blocks ~f:(fun (annot, code) ->
         match annot with
@@ -155,19 +104,18 @@ let parse_from_lex ~filename lex =
               List.fold_left
                 annot
                 ~init:initial_fragment
-                ~f:(fun (fragment : Fragment.fragment_) a ->
+                ~f:(fun (fragment : Fragment.fragment_) (_, pi, a) ->
                   match a with
-                  | `Provides (pi, name, kind, ka) ->
+                  | `Provides (name, kind, ka) ->
                       { fragment with provides = Some (pi, name, kind, ka) }
-                  | `Requires (_, mn) ->
-                      { fragment with requires = mn @ fragment.requires }
-                  | `Version (_, l) ->
+                  | `Requires mn -> { fragment with requires = mn @ fragment.requires }
+                  | `Version l ->
                       { fragment with
                         version_constraint = l :: fragment.version_constraint
                       }
-                  | `Weakdef _ -> { fragment with weakdef = true }
-                  | `Always _ -> { fragment with always = true }
-                  | (`Ifnot (pi, "js-string") | `If (pi, "js-string")) as i ->
+                  | `Weakdef -> { fragment with weakdef = true }
+                  | `Always -> { fragment with always = true }
+                  | (`Ifnot "js-string" | `If "js-string") as i ->
                       let b =
                         match i with
                         | `If _ -> true
@@ -176,11 +124,11 @@ let parse_from_lex ~filename lex =
                       if Option.is_some fragment.js_string
                       then Format.eprintf "Duplicated js-string in %s\n" (loc pi);
                       { fragment with js_string = Some b }
-                  | `If (pi, name) when Option.is_some (Target_env.of_string name) ->
+                  | `If name when Option.is_some (Target_env.of_string name) ->
                       if Option.is_some fragment.fragment_target
                       then Format.eprintf "Duplicated target_env in %s\n" (loc pi);
                       { fragment with fragment_target = Target_env.of_string name }
-                  | `If (pi, name) | `Ifnot (pi, name) ->
+                  | `If name | `Ifnot name ->
                       Format.eprintf "Unkown flag %S in %s\n" name (loc pi);
                       fragment)
             in
@@ -338,7 +286,7 @@ type output =
 
 type provided =
   { id : int
-  ; pi : Parse_info.t option
+  ; pi : Parse_info.t
   ; weakdef : bool
   ; target_env : Target_env.t
   }
@@ -629,5 +577,5 @@ let all state =
 let origin ~name =
   try
     let x = Hashtbl.find provided name in
-    Option.bind x.pi ~f:(fun ploc -> ploc.Parse_info.src)
+    x.pi.Parse_info.src
   with Not_found -> None