ext_attrs everywhere !

Add ext_attrs to exception and fixes ext with regards to opens

Author: EmileTrotignon

lib/Ast.ml

@@ -333,15 +333,15 @@ module Structure_item = struct
         :: _ )
      |Pstr_open
         {popen_attributes= {attrs_before= atrs1; attrs_after= atrs2; _}; _}
-     |Pstr_exception
-        { ptyexn_attributes= atrs1
-        ; ptyexn_constructor= {pext_attributes= atrs2; _}
-        ; _ }
      |Pstr_modtype
         {pmtd_ext_attrs= {attrs_before= atrs1; attrs_after= atrs2; _}; _} ->
         List.exists ~f:Attr.is_doc atrs1 || List.exists ~f:Attr.is_doc atrs2
     (* three attribute lists *)
-    | Pstr_include
+    | Pstr_exception
+        { ptyexn_attributes= {attrs_before= atrs1; attrs_after= atrs2; _}
+        ; ptyexn_constructor= {pext_attributes= atrs3; _}
+        ; _ }
+     |Pstr_include
         { pincl_mod= {pmod_attributes= atrs1; _}
         ; pincl_attributes= {attrs_before= atrs2; attrs_after= atrs3; _}
         ; _ }
@@ -445,16 +445,16 @@ module Signature_item = struct
         {pmtd_ext_attrs= {attrs_before= atrs1; attrs_after= atrs2; _}; _}
      |Psig_modsubst
         {pms_ext_attrs= {attrs_before= atrs1; attrs_after= atrs2; _}; _}
-     |Psig_exception
-        { ptyexn_attributes= atrs1
-        ; ptyexn_constructor= {pext_attributes= atrs2; _}
-        ; _ }
      |Psig_open
         {popen_attributes= {attrs_before= atrs1; attrs_after= atrs2; _}; _}
       ->
         List.exists ~f:Attr.is_doc atrs1 || List.exists ~f:Attr.is_doc atrs2
     (* three attribute list *)
-    | Psig_recmodule
+    | Psig_exception
+        { ptyexn_attributes= {attrs_before= atrs1; attrs_after= atrs2; _}
+        ; ptyexn_constructor= {pext_attributes= atrs3; _}
+        ; _ }
+     |Psig_recmodule
         ( { pmd_type= {pmty_attributes= atrs1; _}
           ; pmd_ext_attrs= {attrs_before= atrs2; attrs_after= atrs3; _}
           ; _ }

lib/Exposed.ml

@@ -95,7 +95,10 @@ module Right = struct
 
   (* exception C of ... * ... * < ... > *)
   let type_exception = function
-    | {ptyexn_attributes= _ :: _; _} -> false
+    | { ptyexn_attributes=
+          {attrs_before= _ :: _; _} | {attrs_after= _ :: _; _}
+      ; _ } ->
+        false
     | {ptyexn_constructor; _} -> extension_constructor ptyexn_constructor
 
   (* val x : < ... > *)

lib/Fmt_ast.ml

@@ -587,12 +587,6 @@ let rec fmt_extension_aux c ctx ~key (ext, pld) =
       assert (not (Cmts.has_before c.cmts pstr_loc)) ;
       assert (not (Cmts.has_after c.cmts pstr_loc)) ;
       hvbox 0 (fmt_quoted_string (Ext.Key.to_string key) ext str delim)
-  | _, PStr [({pstr_loc; _} as si)], (Pld _ | Str _ | Top)
-    when Source.extension_using_sugar ~name:ext ~payload:pstr_loc ->
-      fmt_structure_item c ~last:true ~ext ~semisemi:false (sub_str ~ctx si)
-  | _, PSig [({psig_loc; _} as si)], (Pld _ | Sig _ | Top)
-    when Source.extension_using_sugar ~name:ext ~payload:psig_loc ->
-      fmt_signature_item c ~ext (sub_sig ~ctx si)
   | _, PPat (({ppat_loc; _} as pat), _), (Pld _ | Top)
     when Source.extension_using_sugar ~name:ext ~payload:ppat_loc ->
       fmt_pattern c ~ext (sub_pat ~ctx pat)
@@ -3328,7 +3322,9 @@ and fmt_type_extension c ctx
     ; ptyext_loc } =
   let c = update_config_attrs c ptyext_attributes in
   let ext = ptyext_attributes.attrs_extension in
-  let doc, _doc_after, attrs_before, attrs_after = fmt_docstring_around_item_attrs ~force_before:true c ptyext_attributes in
+  let doc, _doc_after, attrs_before, attrs_after =
+    fmt_docstring_around_item_attrs ~force_before:true c ptyext_attributes
+  in
   let fmt_ctor ctor = hvbox 0 (fmt_extension_constructor c ctx ctor) in
   Cmts.fmt c ptyext_loc
   @@ hvbox 2
@@ -3354,17 +3350,24 @@ and fmt_type_extension c ctx
 and fmt_type_exception ~pre c ctx
     {ptyexn_attributes= item_attrs; ptyexn_constructor; ptyexn_loc} =
   let {pext_attributes= cons_attrs; _} = ptyexn_constructor in
-  let docs, item_attrs = extract_doc_attrs [] item_attrs in
+  let docs, attrs_before = extract_doc_attrs [] item_attrs.attrs_before in
+  let docs, attrs_after = extract_doc_attrs docs item_attrs.attrs_after in
   let docs, cons_attrs = extract_doc_attrs docs cons_attrs in
   let doc_before, doc_after = fmt_docstring_around_item' c docs in
   let ptyexn_constructor =
     {ptyexn_constructor with pext_attributes= cons_attrs}
   in
+  let ext = item_attrs.attrs_extension in
   Cmts.fmt c ptyexn_loc
     (hvbox 0
        ( doc_before
-       $ hvbox 2 (pre $ fmt_extension_constructor c ctx ptyexn_constructor)
-       $ fmt_item_attributes c ~pre:(Break (1, 0)) item_attrs
+       $ hvbox 2
+           ( pre
+           $ fmt_extension_suffix c ext
+           $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before
+           $ fmt "@ "
+           $ fmt_extension_constructor c ctx ptyexn_constructor )
+       $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after
        $ doc_after ) )
 
 and fmt_extension_constructor c ctx ec =
@@ -3514,7 +3517,7 @@ and fmt_signature c ctx itms =
   let ast x = Sig x in
   fmt_item_list c ctx update_config ast fmt_item itms
 
-and fmt_signature_item c ?ext {ast= si; _} =
+and fmt_signature_item c {ast= si; _} =
   protect c (Sig si)
   @@
   let fmt_cmts_before = Cmts.Toplevel.fmt_before c si.psig_loc in
@@ -3525,7 +3528,7 @@ and fmt_signature_item c ?ext {ast= si; _} =
   match si.psig_desc with
   | Psig_attribute attr -> fmt_floating_attributes_and_docstrings c [attr]
   | Psig_exception exc ->
-      let pre = str "exception" $ fmt_extension_suffix c ext $ fmt "@ " in
+      let pre = str "exception" in
       hvbox 2 (fmt_type_exception ~pre c ctx exc)
   | Psig_extension (ext, atrs) ->
       let doc_before, doc_after, atrs = fmt_docstring_around_item c atrs in
@@ -4095,8 +4098,8 @@ and fmt_type c ?eq rec_flag decls ctx =
   let ast x = Td x in
   fmt_item_list c ctx update_config ast fmt_decl decls
 
-and fmt_structure_item c ~last:last_item ?ext ~semisemi
-    {ctx= parent_ctx; ast= si} =
+and fmt_structure_item c ~last:last_item ~semisemi {ctx= parent_ctx; ast= si}
+    =
   protect c (Str si)
   @@
   let ctx = Str si in
@@ -4115,7 +4118,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi
       $ cbox 0 ~name:"eval" (fmt_expression c (sub_exp ~ctx exp))
       $ fmt_item_attributes c ~pre:Space atrs
   | Pstr_exception extn_constr ->
-      let pre = str "exception" $ fmt_extension_suffix c ext $ fmt "@ " in
+      let pre = str "exception" in
       hvbox 2 ~name:"exn" (fmt_type_exception ~pre c ctx extn_constr)
   | Pstr_include {pincl_mod; pincl_attributes= attributes; pincl_loc} ->
       update_config_maybe_disabled_attrs c pincl_loc attributes
@@ -4133,9 +4136,8 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi
         fmt_or_k
           (is_override popen_override)
           ( str "open!"
-          $ fmt_if (Option.is_some attributes.attrs_extension) "@ "
-          $ opt ext (fun _ -> str " " $ fmt_extension_suffix c ext) )
-          (str "open" $ fmt_extension_suffix c ext)
+          $ fmt_if (Option.is_some attributes.attrs_extension) "@ " )
+          (str "open")
       in
       fmt_module_statement c ~attributes ~keyword (sub_mod ~ctx popen_expr)
   | Pstr_primitive vd -> fmt_value_description c ctx vd

test/passing/tests/js_source.ml.ocp

@@ -184,7 +184,7 @@ class type%foo [@foo] x = x
 
 external%foo [@foo] x : _ = ""
 
-exception%foo X [@foo]
+exception%foo [@foo] X
 
 module%foo [@foo] M = M
 
@@ -206,7 +206,7 @@ module type S = sig
 
   type%foo [@foo] t += T
 
-  exception%foo X [@foo]
+  exception%foo [@foo] X
 
   module%foo [@foo] M : S
 

test/passing/tests/js_source.ml.ref

@@ -184,7 +184,7 @@ class type%foo [@foo] x = x
 
 external%foo [@foo] x : _ = ""
 
-exception%foo X [@foo]
+exception%foo [@foo] X
 
 module%foo [@foo] M = M
 
@@ -206,7 +206,7 @@ module type S = sig
 
   type%foo [@foo] t += T
 
-  exception%foo X [@foo]
+  exception%foo [@foo] X
 
   module%foo [@foo] M : S
 

test/passing/tests/source.ml.ref

@@ -224,7 +224,7 @@ class type%foo [@foo] x = x
 
 external%foo [@foo] x : _ = ""
 
-exception%foo X [@foo]
+exception%foo [@foo] X
 
 module%foo [@foo] M = M
 
@@ -249,7 +249,7 @@ module type S = sig
 
   type%foo [@foo] t += T
 
-  exception%foo X [@foo]
+  exception%foo [@foo] X
 
   module%foo [@foo] M : S
 

vendor/parser-extended/ast_helper.ml

@@ -519,12 +519,12 @@ module Te = struct
      ptyext_attributes = add_docs_attrs' docs attrs;
     }
 
-  let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+  let mk_exception ?(loc = !default_loc) ?(attrs = Attr.ext_attrs ()) ?(docs = empty_docs)
       constructor =
     {
      ptyexn_constructor = constructor;
      ptyexn_loc = loc;
-     ptyexn_attributes = add_docs_attrs docs attrs;
+     ptyexn_attributes = add_docs_attrs' docs attrs;
     }
 
   let constructor ?(loc = !default_loc) ?(attrs = [])

vendor/parser-extended/ast_helper.mli

@@ -235,7 +235,7 @@ module Te:
       ?params:(core_type * variance_and_injectivity) list ->
       ?priv:private_flag -> lid -> extension_constructor list -> type_extension
 
-    val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+    val mk_exception: ?loc:loc -> ?attrs:ext_attrs -> ?docs:docs ->
       extension_constructor -> type_exception
 
     val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->

vendor/parser-extended/ast_mapper.ml

@@ -257,7 +257,7 @@ module T = struct
   let map_type_exception sub
       {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
     let loc = sub.location sub ptyexn_loc in
-    let attrs = sub.attributes sub ptyexn_attributes in
+    let attrs = sub.ext_attrs sub ptyexn_attributes in
     Te.mk_exception ~loc ~attrs
       (sub.extension_constructor sub ptyexn_constructor)
 

vendor/parser-extended/parser.mly

@@ -71,16 +71,12 @@ let mkconst ~loc c = Const.mk ~loc:(make_loc loc) c
 
 let pstr_type (nr, tys) =
    Pstr_type (nr, tys)
-let pstr_exception (te, ext) =
-  (Pstr_exception te, ext)
 
 let psig_type (nr, tys) =
   Psig_type (nr, tys)
 let psig_typesubst (nr, tys) =
   assert (nr = Recursive); (* see [no_nonrec_flag] *)
   Psig_typesubst tys
-let psig_exception (te, ext) =
-  (Psig_exception te, ext)
 
 let mkctf ~loc ?attrs ?docs d =
   Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
@@ -133,8 +129,6 @@ let mkpatvar ~loc name =
 let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
 let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
 let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
-let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
-let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
 
 let mkinfix arg1 op arg2 =
   Pexp_infix(op, arg1, arg2)
@@ -287,22 +281,6 @@ let wrap_mod_attrs ~loc:_ attrs body =
 let wrap_mty_attrs ~loc:_ attrs body =
   {body with pmty_attributes = attrs @ body.pmty_attributes}
 
-let wrap_str_ext ~loc body ext =
-  match ext with
-  | None -> body
-  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
-
-let wrap_mkstr_ext ~loc (item, ext) =
-  wrap_str_ext ~loc (mkstr ~loc item) ext
-
-let wrap_sig_ext ~loc body ext =
-  match ext with
-  | None -> body
-  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
-
-let wrap_mksig_ext ~loc (item, ext) =
-  wrap_sig_ext ~loc (mksig ~loc item) ext
-
 let mk_quotedext ~loc (id, idloc, str, strloc, delim) =
   let exp_id = mkloc id idloc in
   let const = Const.mk ~loc:strloc (Pconst_string (str, strloc, delim)) in
@@ -1241,10 +1219,8 @@ structure_item:
         { Pstr_typext $1 }
     | type_declarations
         { pstr_type $1 }
-    )
-  | wrap_mkstr_ext(
-     str_exception_declaration
-        { pstr_exception $1 }
+    | str_exception_declaration
+        { Pstr_exception $1 }
     )
     { $1 }
 ;
@@ -1497,11 +1473,8 @@ signature_item:
         { psig_typesubst $1 }
     | open_description
         { Psig_open $1 }
-    )
-    { $1 }
-  | wrap_mksig_ext(
-      sig_exception_declaration
-        { psig_exception $1 }
+    | str_exception_declaration 
+        { Psig_exception $1 }
     )
     { $1 }
 
@@ -2866,32 +2839,34 @@ str_exception_declaration:
     { $1 }
 | EXCEPTION
   ext = ext
-  attrs1 = attributes
+  before = attributes
   id = mkrhs(constr_ident)
   EQUAL
   lid = mkrhs(constr_longident)
-  attrs2 = attributes
-  attrs = post_item_attributes
+  attrs_inside = attributes
+  after = post_item_attributes
   { let loc = make_loc $sloc in
     let docs = symbol_docs $sloc in
+    let attrs = Attr.ext_attrs ~before ~after ?ext () in
     Te.mk_exception ~attrs
-      (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
-    , ext }
+      (Te.rebind id lid ~attrs:attrs_inside ~loc ~docs)
+  }
 ;
 sig_exception_declaration:
   EXCEPTION
   ext = ext
-  attrs1 = attributes
+  before = attributes
   id = mkrhs(constr_ident)
   vars_args_res = generalized_constructor_arguments
-  attrs2 = attributes
-  attrs = post_item_attributes
+  attrs_inside = attributes
+  after = post_item_attributes
     { let vars, args, res = vars_args_res in
-      let loc = make_loc ($startpos, $endpos(attrs2)) in
+      let loc = make_loc ($startpos, $endpos(attrs_inside)) in
       let docs = symbol_docs $sloc in
+      let attrs = Attr.ext_attrs ~before ~after ?ext () in
       Te.mk_exception ~attrs
-        (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
-      , ext }
+        (Te.decl id ~vars ~args ?res ~attrs:attrs_inside ~loc ~docs)
+    }
 ;
 %inline let_exception_declaration:
     mkrhs(constr_ident) generalized_constructor_arguments attributes