class support

Author: hhugo

compiler/lib/dune

@@ -33,9 +33,7 @@
   --unused-token
   T_ERROR
   --unused-token
-  T_AT
-  --unused-token
-  T_POUND))
+  T_AT))
 
 (menhir
  (modules annot_parser)

compiler/lib/javascript.ml

@@ -222,12 +222,15 @@ and property_list = property list
 
 and property =
   | Property of property_name * expression
-  | PropertyGet of property_name * function_declaration
-  | PropertySet of property_name * function_declaration
-  | PropertyMethod of property_name * function_declaration
   | PropertySpread of expression
+  | PropertyMethod of property_name method_
   | CoverInitializedName of early_error * ident * initialiser
 
+and 'name method_ =
+  | MethodGet of 'name * function_declaration
+  | MethodSet of 'name * function_declaration
+  | Method of 'name * function_declaration
+
 and property_name =
   | PNI of identifier
   | PNS of Utf8_string.t
@@ -247,6 +250,7 @@ and expression =
   | ENew of expression * arguments option
   | EVar of ident
   | EFun of ident option * function_declaration
+  | EClass of ident option * class_declaration
   | EArrow of function_declaration
   | EStr of Utf8_string.t
   | ETemplate of template
@@ -276,6 +280,7 @@ and statement =
   | Block of block
   | Variable_statement of variable_declaration_kind * variable_declaration list
   | Function_declaration of ident * function_declaration
+  | Class_declaration of ident * class_declaration
   | Empty_statement
   | Expression_statement of expression
   | If_statement of expression * (statement * location) * (statement * location) option
@@ -335,6 +340,20 @@ and function_kind =
   ; generator : bool
   }
 
+and class_declaration =
+  { extends : expression option
+  ; body : class_element list
+  }
+
+and class_element =
+  | CEMethod of bool * class_element_name method_
+  | CEField of bool * class_element_name * initialiser option
+  | CEStaticBLock of statement_list
+
+and class_element_name =
+  | PropName of property_name
+  | PrivName of ident
+
 and ('a, 'b) list_with_rest =
   { list : 'a list
   ; rest : 'b option

compiler/lib/javascript.mli

@@ -169,12 +169,15 @@ and property_list = property list
 
 and property =
   | Property of property_name * expression
-  | PropertyGet of property_name * function_declaration
-  | PropertySet of property_name * function_declaration
-  | PropertyMethod of property_name * function_declaration
   | PropertySpread of expression
+  | PropertyMethod of property_name method_
   | CoverInitializedName of early_error * ident * initialiser
 
+and 'name method_ =
+  | MethodGet of 'name * function_declaration
+  | MethodSet of 'name * function_declaration
+  | Method of 'name * function_declaration
+
 and property_name =
   | PNI of identifier
   | PNS of Utf8_string.t
@@ -198,6 +201,7 @@ and expression =
   | ENew of expression * arguments option
   | EVar of ident
   | EFun of ident option * function_declaration
+  | EClass of ident option * class_declaration
   | EArrow of function_declaration
   | EStr of Utf8_string.t
   (* A UTF-8 encoded string that may contain escape sequences. *)
@@ -228,6 +232,7 @@ and statement =
   | Block of block
   | Variable_statement of variable_declaration_kind * variable_declaration list
   | Function_declaration of ident * function_declaration
+  | Class_declaration of ident * class_declaration
   | Empty_statement
   | Expression_statement of expression
   | If_statement of expression * (statement * location) * (statement * location) option
@@ -289,6 +294,20 @@ and function_kind =
   ; generator : bool
   }
 
+and class_declaration =
+  { extends : expression option
+  ; body : class_element list
+  }
+
+and class_element =
+  | CEMethod of bool * class_element_name method_
+  | CEField of bool * class_element_name * initialiser option
+  | CEStaticBLock of statement_list
+
+and class_element_name =
+  | PropName of property_name
+  | PrivName of ident
+
 and ('a, 'b) list_with_rest =
   { list : 'a list
   ; rest : 'b option

compiler/lib/js_assign.ml

@@ -322,17 +322,17 @@ class traverse record_block =
   object (m)
     inherit Js_traverse.free as super
 
-    method! block b =
+    method! record_block b =
       record_block m#state b;
-      super#block b
+      super#record_block b
   end
 
 let program' (module Strategy : Strategy) p =
   let nv = Var.count () in
   let state = Strategy.create nv in
   let mapper = new traverse (Strategy.record_block state) in
   let p = mapper#program p in
-  mapper#block Normal;
+  mapper#record_block Normal;
   let free =
     IdentSet.filter
       (function

compiler/lib/js_output.ml

@@ -284,6 +284,7 @@ struct
     | Switch_statement _
     | Try_statement _
     | Function_declaration _
+    | Class_declaration _
     | Debugger_statement -> false
 
   let starts_with ~obj ~funct ~let_identifier ~async_identifier l e =
@@ -315,6 +316,7 @@ struct
       | ERegexp _
       | EUn _
       | ENew _
+      | EClass _
       | EYield _ -> false
       | CoverCallExpressionAndAsyncArrowHead e
       | CoverParenthesizedExpressionAndArrowParameterList e -> early_error e
@@ -420,6 +422,14 @@ struct
           | { async = false; generator = true } -> "function*"
         in
         function_declaration f prefix ident i l b pc
+    | EClass (i, cl_decl) ->
+        PP.string f "class";
+        (match i with
+        | None -> ()
+        | Some i ->
+            PP.space f;
+            ident f i);
+        class_declaration f cl_decl
     | EArrow (k, p, b, pc) ->
         if Prec.(l > AssignementExpression)
         then (
@@ -796,38 +806,43 @@ struct
         PP.break f;
         expression AssignementExpression f e;
         PP.end_group f
-    | PropertyGet (n, (k, l, b, loc')) | PropertySet (n, (k, l, b, loc')) ->
-        (match k with
-        | { async = false; generator = false } -> ()
-        | _ -> assert false);
-        let prefix =
-          match p with
-          | PropertyGet _ -> "get"
-          | PropertySet _ -> "set"
-          | _ -> assert false
-        in
-        function_declaration f prefix property_name (Some n) l b loc'
-    | PropertyMethod (n, (k, l, b, loc')) ->
-        let fpn f () =
-          (match k with
-          | { async = false; generator = false } -> ()
-          | { async = false; generator = true } ->
-              PP.string f "*";
-              PP.space f
-          | { async = true; generator = false } ->
-              PP.string f "async";
-              PP.space f
-          | { async = true; generator = true } ->
-              PP.string f "async*";
-              PP.space f);
-          property_name f n
-        in
-        function_declaration f "" fpn (Some ()) l b loc'
     | PropertySpread e ->
         PP.string f "...";
         expression AssignementExpression f e
+    | PropertyMethod m -> method_ f property_name m
     | CoverInitializedName (e, _, _) -> early_error e
 
+  and method_ : 'a. _ -> (PP.t -> 'a -> unit) -> 'a method_ -> unit =
+    fun (type a) f (name : PP.t -> a -> unit) (m : a method_) ->
+     match m with
+     | MethodGet (n, (k, l, b, loc')) | MethodSet (n, (k, l, b, loc')) ->
+         (match k with
+         | { async = false; generator = false } -> ()
+         | _ -> assert false);
+         let prefix =
+           match m with
+           | MethodGet _ -> "get"
+           | MethodSet _ -> "set"
+           | _ -> assert false
+         in
+         function_declaration f prefix name (Some n) l b loc'
+     | Method (n, (k, l, b, loc')) ->
+         let fpn f () =
+           (match k with
+           | { async = false; generator = false } -> ()
+           | { async = false; generator = true } ->
+               PP.string f "*";
+               PP.space f
+           | { async = true; generator = false } ->
+               PP.string f "async";
+               PP.space f
+           | { async = true; generator = true } ->
+               PP.string f "async*";
+               PP.space f);
+           name f n
+         in
+         function_declaration f "" fpn (Some ()) l b loc'
+
   and element_list f el = comma_list f element el
 
   and element f (e : element) =
@@ -1037,6 +1052,11 @@ struct
           | { async = false; generator = true } -> "function*"
         in
         function_declaration f prefix ident (Some i) l b loc'
+    | Class_declaration (i, cl_decl) ->
+        PP.string f "class";
+        PP.space f;
+        ident f i;
+        class_declaration f cl_decl
     | Empty_statement -> PP.string f ";"
     | Debugger_statement ->
         PP.string f "debugger";
@@ -1446,6 +1466,49 @@ struct
     PP.end_group f;
     PP.end_group f
 
+  and class_declaration f x =
+    Option.iter x.extends ~f:(fun e ->
+        PP.space f;
+        PP.string f "extends";
+        PP.space f;
+        expression Expression f e);
+    PP.string f "{";
+    List.iter x.body ~f:(fun x ->
+        match x with
+        | CEMethod (static, m) ->
+            if static
+            then (
+              PP.string f "static";
+              PP.space f);
+            method_ f class_element_name m;
+            PP.break f
+        | CEField (static, n, i) ->
+            if static
+            then (
+              PP.string f "static";
+              PP.space f);
+            class_element_name f n;
+            (match i with
+            | None -> ()
+            | Some (e, loc) ->
+                PP.string f "=";
+                PP.space f;
+                output_debug_info f loc;
+                expression Expression f e);
+            PP.break f
+        | CEStaticBLock l ->
+            PP.string f "static";
+            block f l;
+            PP.break f);
+    PP.string f "}"
+
+  and class_element_name f x =
+    match x with
+    | PropName n -> property_name f n
+    | PrivName i ->
+        PP.string f "#";
+        ident f i
+
   and program f s = statement_list f s
 end