More work on extension constructors

ocaml/parsing/ast_mapper.ml

@@ -146,8 +146,15 @@ module T = struct
     in
     Of.mk ~loc ~attrs desc
 
-  let type_vars_layouts sub (tvls : type_vars_layouts) =
-    List.map (map_opt (map_loc_txt sub sub.layout_annotation)) tvls
+  let map_bound_vars sub bound_vars =
+    let bound_var (name, layout_opt) =
+      let name = map_loc sub name in
+      let layout_opt =
+        map_opt (map_loc_txt sub sub.layout_annotation) layout_opt
+      in
+      (name, layout_opt)
+    in
+    List.map bound_var bound_vars
 
   let map_jst_layouts sub :
         Jane_syntax.Layouts.core_type -> Jane_syntax.Layouts.core_type =
@@ -156,14 +163,7 @@ module T = struct
       let layout = map_loc_txt sub sub.layout_annotation layout in
       Ltyp_var { name; layout }
     | Ltyp_poly { bound_vars; inner_type } ->
-      let bound_var (name, layout_opt) =
-        let name = map_loc sub name in
-        let layout_opt =
-          map_opt (map_loc_txt sub sub.layout_annotation) layout_opt
-        in
-        (name, layout_opt)
-      in
-      let bound_vars = List.map bound_var bound_vars in
+      let bound_vars = map_bound_vars sub bound_vars in
       let inner_type = sub.typ sub inner_type in
       Ltyp_poly { bound_vars; inner_type }
     | Ltyp_alias { aliased_type; name; layout } ->
@@ -260,16 +260,20 @@ module T = struct
     Te.mk_exception ~loc ~attrs
       (sub.extension_constructor sub ptyexn_constructor)
 
-  let map_extension_constructor_jst _sub :
-    Jane_syntax.Extension_constructor.t -> _ = function
-    | _ -> .
+  let map_extension_constructor_jst sub :
+    Jane_syntax.Extension_constructor.t -> Jane_syntax.Extension_constructor.t =
+    function
+    | Jext_layout (Lext_decl(vars, args, res)) ->
+      let vars = map_bound_vars sub vars in
+      let args = map_constructor_arguments sub args in
+      let res = map_opt (sub.typ sub) res in
+      Jext_layout (Lext_decl(vars, args, res))
 
   let map_extension_constructor_kind sub = function
-      Pext_decl(vars, ctl, cto, layouts) ->
+      Pext_decl(vars, ctl, cto) ->
         Pext_decl(List.map (map_loc sub) vars,
                   map_constructor_arguments sub ctl,
-                  map_opt (sub.typ sub) cto,
-                  type_vars_layouts sub layouts)
+                  map_opt (sub.typ sub) cto)
     | Pext_rebind li ->
         Pext_rebind (map_loc sub li)
 
@@ -281,11 +285,11 @@ module T = struct
     let loc = sub.location sub pext_loc in
     let name = map_loc sub pext_name in
     match Jane_syntax.Extension_constructor.of_ast ext with
-    | Some (jext, attrs) -> begin
-      let _attrs = sub.attributes sub attrs in
-      match sub.extension_constructor_jane_syntax sub jext with
-      | _ -> .
-    end
+    | Some (jext, attrs) ->
+      let attrs = sub.attributes sub attrs in
+      let jext = sub.extension_constructor_jane_syntax sub jext in
+      Jane_syntax.Extension_constructor.extension_constructor_of
+        ~loc ~name ~attrs jext
     | None ->
     let attrs = sub.attributes sub pext_attributes in
     Te.constructor ~loc ~attrs

ocaml/parsing/depend.ml

@@ -99,6 +99,10 @@ let handle_extension ext =
    prefixes. *)
 let add_layout _bv (_layout : Asttypes.layout_annotation) = ()
 
+let add_vars_layouts bv vars_layouts =
+  let add_one (_, layout) = Option.iter (add_layout bv) layout in
+  List.iter add_one vars_layouts
+
 let rec add_type bv ty =
   match Jane_syntax.Core_type.of_ast ty with
   | Some (jty, _attrs) -> add_type_jst bv jty
@@ -133,14 +137,12 @@ and add_type_jst_layouts bv : Jane_syntax.Layouts.core_type -> _ = function
   | Ltyp_var { name = _; layout } ->
     add_layout bv layout
   | Ltyp_poly { bound_vars; inner_type } ->
-    List.iter
-      (fun (_, layout) -> Option.iter (add_layout bv) layout) bound_vars;
+    add_vars_layouts bv bound_vars;
     add_type bv inner_type
   | Ltyp_alias { aliased_type; name = _; layout } ->
     add_type bv aliased_type;
     add_layout bv layout
 
-
 and add_package_type bv (lid, l) =
   add bv lid;
   List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
@@ -171,16 +173,19 @@ let add_type_declaration bv td =
   | Ptype_open -> () in
   add_tkind td.ptype_kind
 
-let add_extension_constructor_jst _bv _attrs :
+let add_extension_constructor_jst bv :
   Jane_syntax.Extension_constructor.t -> _ = function
-  | _ -> .
+  | Jext_layout (Lext_decl (vars_layouts, args, res)) ->
+    add_vars_layouts bv vars_layouts;
+    add_constructor_arguments bv args;
+    Option.iter (add_type bv) res
 
 let add_extension_constructor bv ext =
   match Jane_syntax.Extension_constructor.of_ast ext with
-  | Some (jext, attrs) -> add_extension_constructor_jst bv attrs jext
+  | Some (jext, _attrs) -> add_extension_constructor_jst bv jext
   | None ->
   match ext.pext_kind with
-    Pext_decl(_, args, rty, _) ->
+    Pext_decl(_, args, rty) ->
       add_constructor_arguments bv args;
       Option.iter (add_type bv) rty
   | Pext_rebind lid -> add bv lid

ocaml/parsing/jane_syntax.ml

@@ -753,7 +753,9 @@ module Layouts = struct
   (*******************************************************)
   (* Encoding extension constructor *)
 
-  let extension_constructor_of ~loc ~name ~attrs ext =
+  let extension_constructor_of ~loc ~name ~attrs ?info ?docs ext =
+    (* using optional parameters to hook into existing defaulting
+       in Ast_helper.Te.decl, which seems unwise to duplicate *)
     let module Ast_of = Ast_of (Extension_constructor) (Ext) in
     let exception No_wrap_necessary of Parsetree.extension_constructor in
     try
@@ -763,7 +765,9 @@ module Layouts = struct
             match ext with
             | Lext_decl (bound_vars, args, res) ->
               let vars, layouts = List.split bound_vars in
-              let ext_ctor = Ast_helper.Te.decl ~attrs ~vars ~args ?res name in
+              let ext_ctor =
+                Ast_helper.Te.decl ~attrs ~vars ~args ?info ?docs ?res name
+              in
               if List.for_all Option.is_none layouts
               then raise (No_wrap_necessary ext_ctor)
               else
@@ -928,4 +932,8 @@ module Extension_constructor = struct
     | _ -> None
 
   let of_ast = Extension_constructor.make_of_ast ~of_ast_internal
+
+  let extension_constructor_of ~loc ~name ~attrs ?info ?docs = function
+    | Jext_layout lext ->
+      Layouts.extension_constructor_of ~loc ~name ~attrs ?info ?docs lext
 end

ocaml/parsing/jane_syntax.mli

@@ -160,6 +160,8 @@ module Layouts : sig
     loc:Location.t ->
     name:string Location.loc ->
     attrs:Parsetree.attributes ->
+    ?info:Docstrings.info ->
+    ?docs:Docstrings.docs ->
     extension_constructor ->
     Parsetree.extension_constructor
 end
@@ -322,5 +324,10 @@ module Extension_constructor : sig
 
   include AST with type t := t * Parsetree.attributes
                and type ast := Parsetree.extension_constructor
+
+  val extension_constructor_of :
+    loc:Location.t -> name:string Location.loc -> attrs:Parsetree.attributes ->
+    ?info:Docstrings.info -> ?docs:Docstrings.docs -> t ->
+    Parsetree.extension_constructor
 end
 

ocaml/parsing/parser.mly

@@ -3591,7 +3591,7 @@ generic_constructor_declaration(opening):
   d = generic_constructor_declaration(opening)
     {
       let cid, vars, args, res, attrs, loc, info = d in
-      Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info
+      Type.constructor cid ~vars:(List.split vars) ~args ?res ~attrs ~loc ~info
     }
 ;
 str_exception_declaration:
@@ -3619,35 +3619,38 @@ sig_exception_declaration:
   vars_args_res = generalized_constructor_arguments
   attrs2 = attributes
   attrs = post_item_attributes
-    { let vars, args, res = vars_args_res in
+    { let vars_layouts, args, res = vars_args_res in
       let loc = make_loc ($startpos, $endpos(attrs2)) in
       let docs = symbol_docs $sloc in
-      Te.mk_exception ~attrs
-        (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
-      , ext }
+      let ext_ctor =
+        Jane_syntax.Layouts.extension_constructor_of
+          ~loc ~name:id ~attrs:(attrs1 @ attrs2) ~docs
+          (Lext_decl (vars_layouts, args, res))
+      in
+      Te.mk_exception ~attrs ext_ctor, ext }
 ;
 %inline let_exception_declaration:
     mkrhs(constr_ident) generalized_constructor_arguments attributes
-      { let vars, args, res = $2 in
+      { let vars_layouts, args, res = $2 in
         Jane_syntax.Layouts.extension_constructor_of
             ~loc:(make_loc $sloc)
             ~name:$1
             ~attrs:$3
-            (Lext_decl (vars, args, res)) }
+            (Lext_decl (vars_layouts, args, res)) }
 ;
 
 generalized_constructor_arguments:
-    /*empty*/                     { (([],[]),Pcstr_tuple [],None) }
-  | OF constructor_arguments      { (([],[]),$2,None) }
+    /*empty*/                     { ([],Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ([],$2,None) }
   | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
-                                  { (([],[]),$2,Some $4) }
+                                  { ([],$2,Some $4) }
   | COLON typevar_list DOT constructor_arguments MINUSGREATER atomic_type
      %prec below_HASH
-                                  { (List.split $2,$4,Some $6) }
+                                  { ($2,$4,Some $6) }
   | COLON atomic_type %prec below_HASH
-                                  { (([],[]),Pcstr_tuple [],Some $2) }
+                                  { ([],Pcstr_tuple [],Some $2) }
   | COLON typevar_list DOT atomic_type %prec below_HASH
-                                  { (List.split $2,Pcstr_tuple [],Some $4) }
+                                  { ($2,Pcstr_tuple [],Some $4) }
 ;
 
 %inline atomic_type_gbl:
@@ -3725,8 +3728,9 @@ label_declaration_semi:
 %inline extension_constructor_declaration(opening):
   d = generic_constructor_declaration(opening)
     {
-      let cid, vars, args, res, attrs, loc, info = d in
-      Te.decl cid ~vars ~args ?res ~attrs ~loc ~info
+      let name, vars_layouts, args, res, attrs, loc, info = d in
+      Jane_syntax.Layouts.extension_constructor_of
+        ~loc ~attrs ~info ~name (Lext_decl(vars_layouts, args, res))
     }
 ;
 extension_constructor_rebind(opening):

ocaml/typing/typedecl.ml

@@ -1528,40 +1528,53 @@ let transl_type_decl env rec_flag sdecl_list =
   (final_decls, final_env)
 
 (* Translating type extensions *)
-let transl_extension_constructor_jst ~scope:_ _env _type_path _type_params
-      _typext_params _priv _id _attrs : Jane_syntax.Extension_constructor.t -> _ =
-  function
-  | _ -> .
+let transl_extension_constructor_decl
+      env type_path typext_params loc id (svars : _ Either.t) sargs sret_type =
+  (* XXX layouts: remove this *)
+  let svars, slays = match svars with
+    | Left svars -> svars, List.map (fun _ -> None) svars
+    | Right svars_slays -> List.split svars_slays
+  in
+  let targs, tret_type, args, ret_type =
+    make_constructor env loc
+      ~cstr_path:(Pident id) ~type_path typext_params
+      svars slays sargs sret_type
+  in
+  let num_args =
+    match targs with
+    | Cstr_tuple args -> List.length args
+    | Cstr_record _ -> 1
+  in
+  let layouts = Array.make num_args (Layout.any ~why:Dummy_layout) in
+  let args, constant =
+    update_constructor_arguments_layouts env loc args layouts
+  in
+  let strip_locs sv sl = sv.txt, Option.map Location.get_txt sl in
+  let vars = List.map2 strip_locs svars slays in
+  args, layouts, constant, ret_type,
+  Text_decl(vars, targs, tret_type)
+
+let transl_extension_constructor_jst env type_path _type_params
+      typext_params _priv loc id _attrs :
+  Jane_syntax.Extension_constructor.t -> _ = function
+  | Jext_layout (Lext_decl(vars_layouts, args, res)) ->
+    transl_extension_constructor_decl
+      env type_path typext_params loc id (Right vars_layouts) args res
 
 let transl_extension_constructor ~scope env type_path type_params
                                  typext_params priv sext =
   let id = Ident.create_scoped ~scope sext.pext_name.txt in
+  let loc = sext.pext_loc in
   let args, arg_layouts, constant, ret_type, kind =
     match Jane_syntax.Extension_constructor.of_ast sext with
     | Some (jext, attrs) ->
       transl_extension_constructor_jst
-        ~scope env type_path type_params typext_params priv id attrs jext
+        env type_path type_params typext_params priv loc id attrs jext
     | None ->
     match sext.pext_kind with
-      Pext_decl(svars, sargs, sret_type, slays) ->
-        let targs, tret_type, args, ret_type =
-          make_constructor env sext.pext_loc
-            ~cstr_path:(Pident id) ~type_path typext_params
-            svars slays sargs sret_type
-        in
-        let num_args =
-          match targs with
-          | Cstr_tuple args -> List.length args
-          | Cstr_record _ -> 1
-        in
-        let layouts = Array.make num_args (Layout.any ~why:Dummy_layout) in
-        let args, constant =
-          update_constructor_arguments_layouts env sext.pext_loc args layouts
-        in
-        let strip_locs sv sl = sv.txt, Option.map Location.get_txt sl in
-        let vars = List.map2 strip_locs svars slays in
-          args, layouts, constant, ret_type,
-          Text_decl(vars, targs, tret_type)
+      Pext_decl(svars, sargs, sret_type) ->
+      transl_extension_constructor_decl
+        env type_path typext_params loc id (Left svars) sargs sret_type
     | Pext_rebind lid ->
         let usage : Env.constructor_usage =
           if priv = Public then Env.Exported else Env.Exported_private

ocaml/typing/untypeast.ml

@@ -294,15 +294,17 @@ let extension_constructor sub ext =
   let loc = sub.location sub ext.ext_loc in
   let add_loc x = mkloc x loc in
   let attrs = sub.attributes sub ext.ext_attributes in
-  Te.constructor ~loc ~attrs
-    (map_loc sub ext.ext_name)
-    (match ext.ext_kind with
-      | Text_decl (vs, args, ret) ->
-          let vs, ls = List.split vs in
-          Pext_decl (List.map add_loc vs, constructor_arguments sub args,
-                     Option.map (sub.typ sub) ret, List.map (Option.map add_loc) ls)
-      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
-    )
+  let name = map_loc sub ext.ext_name in
+  match ext.ext_kind with
+  | Text_decl (vs, args, ret) ->
+    let one_var (v, l) = add_loc v, Option.map add_loc l in
+    let vs = List.map one_var vs in
+    let args = constructor_arguments sub args in
+    let ret = Option.map (sub.typ sub) ret in
+    Jane_syntax.Layouts.extension_constructor_of
+      ~loc ~name ~attrs (Lext_decl (vs, args, ret))
+  | Text_rebind (_p, lid) ->
+    Te.constructor ~loc ~attrs name (Pext_rebind (map_loc sub lid))
 
 let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
   let loc = sub.location sub pat.pat_loc in