flambda-backend: Modular syntax for types (#1401)

* [minor] Rename local variable

* [minor] Formatting

* Add support for Jane-syntax in types and in constructor arguments

* Add empty `Core_type` and `Constructor_argument` Jane ASTs

* Add matches on `Jane_syntax.Core_type.of_ast`

* Respond to Richard's small comments

* Add comment warning about an unavoidably missing Jane-syntax match

* [minor] Double comma

parsing/ast_helper.ml

@@ -85,6 +85,12 @@ module Typ = struct
     let var_names = List.map (fun v -> v.txt) var_names in
     let rec loop t =
       let desc =
+        (* This *ought* to match on [Jane_syntax.Core_type.ast_of] first, but
+           that would be a dependency cycle -- [Jane_syntax] depends rather
+           crucially on [Ast_helper].  However, this just recurses looking for
+           constructors and variables, so it *should* be fine even so.  If
+           Jane-syntax embeddings ever change so that this breaks, we'll need to
+           resolve this knot. *)
         match t.ptyp_desc with
         | Ptyp_any -> Ptyp_any
         | Ptyp_var x ->

parsing/ast_iterator.ml

@@ -67,6 +67,7 @@ type iterator = {
   structure_item: iterator -> structure_item -> unit;
   structure_item_jane_syntax: iterator -> Jane_syntax.Structure_item.t -> unit;
   typ: iterator -> core_type -> unit;
+  typ_jane_syntax: iterator -> Jane_syntax.Core_type.t -> unit;
   row_field: iterator -> row_field -> unit;
   object_field: iterator -> object_field -> unit;
   type_declaration: iterator -> type_declaration -> unit;
@@ -115,9 +116,16 @@ module T = struct
     | Otag (_, t) -> sub.typ sub t
     | Oinherit t -> sub.typ sub t
 
-  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+  let iter_jst _sub : Jane_syntax.Core_type.t -> _ = function
+    | _ -> .
+
+  let iter sub ({ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs}
+                  as typ) =
     sub.location sub loc;
     sub.attributes sub attrs;
+    match Jane_syntax.Core_type.of_ast typ with
+    | Some jtyp -> sub.typ_jane_syntax sub jtyp
+    | None ->
     match desc with
     | Ptyp_any
     | Ptyp_var _ -> ()
@@ -645,6 +653,7 @@ let default_iterator =
     type_declaration = T.iter_type_declaration;
     type_kind = T.iter_type_kind;
     typ = T.iter;
+    typ_jane_syntax = T.iter_jst;
     row_field = T.row_field;
     object_field = T.object_field;
     type_extension = T.iter_type_extension;

parsing/ast_iterator.mli

@@ -70,6 +70,7 @@ type iterator = {
   structure_item: iterator -> structure_item -> unit;
   structure_item_jane_syntax: iterator -> Jane_syntax.Structure_item.t -> unit;
   typ: iterator -> core_type -> unit;
+  typ_jane_syntax: iterator -> Jane_syntax.Core_type.t -> unit;
   row_field: iterator -> row_field -> unit;
   object_field: iterator -> object_field -> unit;
   type_declaration: iterator -> type_declaration -> unit;

parsing/ast_mapper.ml

@@ -78,6 +78,7 @@ type mapper = {
   structure_item_jane_syntax: mapper ->
     Jane_syntax.Structure_item.t -> Jane_syntax.Structure_item.t;
   typ: mapper -> core_type -> core_type;
+  typ_jane_syntax: mapper -> Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t;
   type_declaration: mapper -> type_declaration -> type_declaration;
   type_extension: mapper -> type_extension -> type_extension;
   type_exception: mapper -> type_exception -> type_exception;
@@ -137,10 +138,22 @@ module T = struct
     in
     Of.mk ~loc ~attrs desc
 
-  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+  let map_jst _sub : Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t =
+    function
+    | _ -> .
+
+  let map sub ({ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs}
+                 as typ) =
     let open Typ in
     let loc = sub.location sub loc in
     let attrs = sub.attributes sub attrs in
+    match Jane_syntax.Core_type.of_ast typ with
+    | Some jtyp -> begin
+        Jane_syntax_parsing.Core_type.wrap_desc ~loc ~attrs @@
+        match sub.typ_jane_syntax sub jtyp with
+        | _ -> .
+    end
+    | None ->
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
@@ -740,6 +753,7 @@ let default_mapper =
     type_declaration = T.map_type_declaration;
     type_kind = T.map_type_kind;
     typ = T.map;
+    typ_jane_syntax = T.map_jst;
     type_extension = T.map_type_extension;
     type_exception = T.map_type_exception;
     extension_constructor = T.map_extension_constructor;

parsing/ast_mapper.mli

@@ -116,6 +116,7 @@ type mapper = {
   structure_item_jane_syntax: mapper ->
     Jane_syntax.Structure_item.t -> Jane_syntax.Structure_item.t;
   typ: mapper -> core_type -> core_type;
+  typ_jane_syntax: mapper -> Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t;
   type_declaration: mapper -> type_declaration -> type_declaration;
   type_extension: mapper -> type_extension -> type_extension;
   type_exception: mapper -> type_exception -> type_exception;

parsing/depend.ml

@@ -96,6 +96,9 @@ let handle_extension ext =
     ()
 
 let rec add_type bv ty =
+  match Jane_syntax.Core_type.of_ast ty with
+  | Some jty -> add_type_jst bv jty
+  | None ->
   match ty.ptyp_desc with
     Ptyp_any -> ()
   | Ptyp_var _ -> ()
@@ -119,6 +122,9 @@ let rec add_type bv ty =
   | Ptyp_package pt -> add_package_type bv pt
   | Ptyp_extension e -> handle_extension e
 
+and add_type_jst _bv : Jane_syntax.Core_type.t -> _ = function
+  | _ -> .
+
 and add_package_type bv (lid, l) =
   add bv lid;
   List.iter (add_type bv) (List.map (fun (_, e) -> e) l)

parsing/jane_syntax.ml

@@ -278,7 +278,7 @@ module Immutable_arrays = struct
       Pattern.make_entire_jane_syntax ~loc extension_string (fun () ->
         Ast_helper.Pat.array elts)
 
-  let of_pat expr = match expr.ppat_desc with
+  let of_pat pat = match pat.ppat_desc with
     | Ppat_array elts -> Iapat_immutable_array elts
     | _ -> failwith "Malformed immutable array pattern"
 end
@@ -347,6 +347,34 @@ module type AST = sig
   val of_ast : ast -> t option
 end
 
+module Core_type = struct
+  module M = struct
+    module AST = Jane_syntax_parsing.Core_type
+
+    type t = |
+
+    let of_ast_internal (feat : Feature.t) _typ = match feat with
+      | _ -> None
+  end
+
+  include M
+  include Make_of_ast(M)
+end
+
+module Constructor_argument = struct
+  module M = struct
+    module AST = Jane_syntax_parsing.Constructor_argument
+
+    type t = |
+
+    let of_ast_internal (feat : Feature.t) _carg = match feat with
+      | _ -> None
+  end
+
+  include M
+  include Make_of_ast(M)
+end
+
 module Expression = struct
   module M = struct
     module AST = Jane_syntax_parsing.Expression

parsing/jane_syntax.mli

@@ -173,6 +173,21 @@ end
 (******************************************)
 (* Individual syntactic categories *)
 
+(** Novel syntax in types *)
+module Core_type : sig
+  type t = |
+
+  include AST with type t := t and type ast := Parsetree.core_type
+end
+
+(** Novel syntax in constructor arguments; this isn't a core AST type,
+    but captures where [global_] and [nonlocal_] live *)
+module Constructor_argument : sig
+  type t = |
+
+  include AST with type t := t and type ast := Parsetree.core_type
+end
+
 (** Novel syntax in expressions *)
 module Expression : sig
   type t =

parsing/jane_syntax_parsing.ml

@@ -415,6 +415,45 @@ module Make_AST (AST_parameters : AST_parameters) :
       | None -> None
 end
 
+(** The AST parameters for every subset of types; embedded as
+    [[[%jane.FEATNAME] * BODY]]. *)
+module Type_AST_parameters = struct
+  type ast = core_type
+  type ast_desc = core_type_desc
+
+  (* Missing [plural] *)
+
+  let location typ = typ.ptyp_loc
+
+  let wrap_desc ?loc ~attrs = Ast_helper.Typ.mk ?loc ~attrs
+
+  let make_extension_node = Ast_helper.Typ.extension
+
+  let make_extension_use ~extension_node typ =
+    Ptyp_tuple [extension_node; typ]
+
+  let match_extension_use typ =
+    match typ.ptyp_desc with
+    | Ptyp_tuple([{ptyp_desc = Ptyp_extension ext; _}; typ]) ->
+        Some (ext, typ)
+    | _ ->
+        None
+end
+
+(** Types; embedded as [[[%jane.FEATNAME] * BODY]]. *)
+module Core_type = Make_AST(struct
+    include Type_AST_parameters
+
+    let plural = "types"
+end)
+
+(** Constructor arguments; the same as types, but used in fewer places *)
+module Constructor_argument = Make_AST(struct
+  include Type_AST_parameters
+
+  let plural = "constructor arguments"
+end)
+
 (** Expressions; embedded as [([%jane.FEATNAME] BODY)]. *)
 module Expression = Make_AST(struct
   type ast = expression
@@ -461,7 +500,7 @@ module Pattern = Make_AST(struct
     | Ppat_tuple([{ppat_desc = Ppat_extension ext; _}; pattern]) ->
         Some (ext, pattern)
     | _ ->
-       None
+        None
 end)
 
 (** Module types; embedded as [functor (_ : [%jane.FEATNAME]) -> BODY]. *)

parsing/jane_syntax_parsing.mli

@@ -169,16 +169,33 @@ end
     adding these lazily as we need them. When you add another one, make
     sure also to add special handling in [Ast_iterator] and [Ast_mapper]. *)
 
-module Expression     : AST with type ast      = Parsetree.expression
-                             and type ast_desc = Parsetree.expression_desc
-module Pattern        : AST with type ast      = Parsetree.pattern
-                             and type ast_desc = Parsetree.pattern_desc
-module Module_type    : AST with type ast      = Parsetree.module_type
-                             and type ast_desc = Parsetree.module_type_desc
-module Signature_item : AST with type ast      = Parsetree.signature_item
-                             and type ast_desc = Parsetree.signature_item_desc
-module Structure_item : AST with type ast      = Parsetree.structure_item
-                             and type ast_desc = Parsetree.structure_item_desc
+module Core_type : AST
+  with type ast      = Parsetree.core_type
+   and type ast_desc = Parsetree.core_type_desc
+
+module Constructor_argument : AST
+  with type ast      = Parsetree.core_type
+   and type ast_desc = Parsetree.core_type_desc
+
+module Expression : AST
+  with type ast      = Parsetree.expression
+   and type ast_desc = Parsetree.expression_desc
+
+module Pattern : AST
+  with type ast      = Parsetree.pattern
+   and type ast_desc = Parsetree.pattern_desc
+
+module Module_type : AST
+  with type ast      = Parsetree.module_type
+   and type ast_desc = Parsetree.module_type_desc
+
+module Signature_item : AST
+  with type ast      = Parsetree.signature_item
+   and type ast_desc = Parsetree.signature_item_desc
+
+module Structure_item : AST
+  with type ast      = Parsetree.structure_item
+   and type ast_desc = Parsetree.structure_item_desc
 
 (** Each syntactic category will include a module that meets this signature.
     Then, the [Make_of_ast] functor produces the functions that actually convert

parsing/pprintast.ml

@@ -344,7 +344,11 @@ and core_type ctxt f x =
 
 and core_type1 ctxt f x =
   if has_non_curry_attr x.ptyp_attributes then core_type ctxt f x
-  else match x.ptyp_desc with
+  else
+    match Jane_syntax.Core_type.of_ast x with
+    | Some jtyp -> core_type1_jane_syntax ctxt f jtyp
+    | None ->
+    match x.ptyp_desc with
     | Ptyp_any -> pp f "_";
     | Ptyp_var s -> tyvar f  s;
     | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
@@ -420,6 +424,9 @@ and core_type1 ctxt f x =
     | Ptyp_extension e -> extension ctxt f e
     | _ -> paren true (core_type ctxt) f x
 
+and core_type1_jane_syntax _ctxt _f : Jane_syntax.Core_type.t -> _ = function
+  | _ -> .
+
 and return_type ctxt f x =
   if x.ptyp_attributes <> [] then maybe_local_type core_type1 ctxt f x
   else maybe_local_type core_type ctxt f x

typing/typecore.ml

@@ -3460,6 +3460,9 @@ let is_local_returning_function cases =
 (* Approximate the type of an expression, for better recursion *)
 
 let rec approx_type env sty =
+  match Jane_syntax.Core_type.of_ast sty with
+  | Some jty -> approx_type_jst env jty
+  | None ->
   match sty.ptyp_desc with
   | Ptyp_arrow (p, ({ ptyp_desc = Ptyp_poly _ } as arg_sty), sty) ->
       (* CR layouts v5: value requirement here to be relaxed *)
@@ -3502,6 +3505,9 @@ let rec approx_type env sty =
      (which mentions approx_type) for why it can't be value.  *)
   | _ -> newvar Layout.any
 
+and approx_type_jst _env : Jane_syntax.Core_type.t -> _ = function
+  | _ -> .
+
 let type_pattern_approx_jane_syntax : Jane_syntax.Pattern.t -> _ = function
   | Jpat_immutable_array _ -> ()
 

typing/typetexp.ml

@@ -431,6 +431,9 @@ and transl_type_aux env policy mode styp =
     { ctyp_desc; ctyp_type; ctyp_env = env;
       ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
   in
+  match Jane_syntax.Core_type.of_ast styp with
+  | Some etyp -> transl_type_aux_jst env policy mode etyp
+  | None ->
   match styp.ptyp_desc with
     Ptyp_any ->
       let ty = TyVarEnv.new_anon_var styp.ptyp_loc env Layout.any policy in
@@ -822,6 +825,10 @@ and transl_type_aux env policy mode styp =
   | Ptyp_extension ext ->
       raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
+and transl_type_aux_jst _env _policy _mode
+      : Jane_syntax.Core_type.t -> _ = function
+  | _ -> .
+
 and transl_fields env policy o fields =
   let hfields = Hashtbl.create 17 in
   let add_typed_field loc l ty =