flambda-backend: Parsing new mode syntax (ocaml-flambda#2235)

boot/menhir/parser.mli

@@ -129,6 +129,8 @@ type token =
   | BAR
   | BANG
   | BACKQUOTE
+  | ATAT
+  | AT
   | ASSERT
   | AS
   | ANDOP of (string)

parsing/ast_iterator.ml

@@ -814,6 +814,11 @@ let default_iterator =
     value_description =
       (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
                  pval_attributes} ->
+        let modes, ptyp_attributes =
+          Jane_syntax.Mode_expr.maybe_of_attrs pval_type.ptyp_attributes
+        in
+        Option.iter (this.modes this) modes;
+        let pval_type = {pval_type with ptyp_attributes} in
         iter_loc this pval_name;
         this.typ this pval_type;
         this.location this pval_loc;
@@ -962,7 +967,7 @@ let default_iterator =
       this.location this a.attr_loc
     );
     attributes = (fun this l -> List.iter (this.attribute this) l);
-    (* [ast_iterator] should not know about the structure of mode expressions *)
+    (* CR zqian: should go into the modes and at least iterate the locations. *)
     modes = (fun _this _m -> ());
     payload =
       (fun this -> function

parsing/ast_mapper.ml

@@ -93,6 +93,7 @@ type mapper = {
     Jane_syntax.Structure_item.t -> Jane_syntax.Structure_item.t;
   typ_jane_syntax: mapper -> Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t;
 
+  modes : mapper -> Jane_syntax.Mode_expr.t -> Jane_syntax.Mode_expr.t;
 }
 
 let map_fst f (x, y) = (f x, y)
@@ -925,9 +926,26 @@ let default_mapper =
     value_description =
       (fun this {pval_name; pval_type; pval_prim; pval_loc;
                  pval_attributes} ->
+        let modes, ptyp_attributes =
+          Jane_syntax.Mode_expr.maybe_of_attrs pval_type.ptyp_attributes
+        in
+        let pval_type = { pval_type with ptyp_attributes } in
+        let pval_type = this.typ this pval_type in
+        let attr =
+          match modes with
+          | None -> None
+          | Some modes ->
+              let modes = this.modes this modes in
+              Jane_syntax.Mode_expr.attr_of modes
+        in
+        let pval_type =
+          match attr with
+          | None -> pval_type
+          | Some attr -> {pval_type with ptyp_attributes = attr :: pval_type.ptyp_attributes}
+        in
         Val.mk
           (map_loc this pval_name)
-          (this.typ this pval_type)
+          pval_type
           ~attrs:(this.attributes this pval_attributes)
           ~loc:(this.location this pval_loc)
           ~prim:pval_prim
@@ -1096,6 +1114,9 @@ let default_mapper =
     signature_item_jane_syntax = MT.map_signature_item_jst;
     structure_item_jane_syntax = M.map_structure_item_jst;
     typ_jane_syntax = T.map_jst;
+
+    (* CR zqian: should go into the modes and at least map the locations. *)
+    modes = (fun _this m -> m);
   }
 
 let extension_of_error {kind; main; sub} =

parsing/ast_mapper.mli

@@ -131,6 +131,7 @@ type mapper = {
     Jane_syntax.Structure_item.t -> Jane_syntax.Structure_item.t;
   typ_jane_syntax: mapper -> Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t;
 
+  modes : mapper -> Jane_syntax.Mode_expr.t -> Jane_syntax.Mode_expr.t;
 }
 (** A mapper record implements one "method" per syntactic category,
     using an open recursion style: each method takes as its first

parsing/jane_syntax.ml

@@ -452,6 +452,10 @@ module Mode_expr = struct
     let const' = (const : Const.t :> _ Location.loc) in
     Location.mkloc [const] const'.loc
 
+  let concat mode0 mode1 =
+    let txt = mode0.txt @ mode1.txt in
+    Location.mknoloc txt
+
   let feature : Feature.t = Language_extension Mode
 
   let attribute_or_extension_name =

parsing/jane_syntax.mli

@@ -140,6 +140,11 @@ module Mode_expr : sig
   (** The mode expression containing a single mode constant. *)
   val singleton : Const.t -> t
 
+  (** Merging two mode expressions. This will be hard to define as mode
+      expressions gets complex. Currently it's for merging legacy and new syntax
+      *)
+  val concat : t -> t -> t
+
   (** Extract the mode attribute (if any) from a list of attributes; also
       returns the rest of the attributes; Raises if multiple relevant attributes
       are found *)

parsing/lexer.mll

@@ -752,6 +752,8 @@ rule token = parse
             { PREFIXOP op }
   | ['=' '<' '>' '|' '&' '$'] symbolchar * as op
             { INFIXOP0 op }
+  | "@" { AT }
+  | "@@" { ATAT }
   | ['@' '^'] symbolchar * as op
             { INFIXOP1 op }
   | ['+' '-'] symbolchar * as op