#6387: allow attributes on variants in polymorphic variant types.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14712 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

parsing/ast_mapper.ml

@@ -79,7 +79,8 @@ module T = struct
   (* Type expressions for the core language *)
 
   let row_field sub = function
-    | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub.typ sub) tl)
+    | Rtag (l, attrs, b, tl) ->
+        Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
     | Rinherit t -> Rinherit (sub.typ sub t)
 
   let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =

parsing/parser.mly

@@ -257,8 +257,8 @@ let varify_constructors var_names t =
     {t with ptyp_desc = desc}
   and loop_row_field  =
     function
-      | Rtag(label,flag,lst) ->
-          Rtag(label,flag,List.map loop lst)
+      | Rtag(label,attrs,flag,lst) ->
+          Rtag(label,attrs,flag,List.map loop lst)
       | Rinherit t ->
           Rinherit (loop t)
   in
@@ -1777,10 +1777,10 @@ row_field:
   | simple_core_type                            { Rinherit $1 }
 ;
 tag_field:
-    name_tag OF opt_ampersand amper_type_list
-      { Rtag ($1, $3, List.rev $4) }
-  | name_tag
-      { Rtag ($1, true, []) }
+    name_tag attributes OF opt_ampersand amper_type_list
+      { Rtag ($1, $2, $4, List.rev $5) }
+  | name_tag attributes
+      { Rtag ($1, $2, true, []) }
 ;
 opt_ampersand:
     AMPERSAND                                   { true }

parsing/parsetree.mli

@@ -115,7 +115,7 @@ and package_type = Longident.t loc * (Longident.t loc * core_type) list
        *)
 
 and row_field =
-  | Rtag of label * bool * core_type list
+  | Rtag of label * attributes * bool * core_type list
         (* [`A]                   ( true,  [] )
            [`A of T]              ( false, [T] )
            [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
@@ -125,6 +125,8 @@ and row_field =
             constant (empty) constructor.
           - '&' occurs when several types are used for the same constructor
             (see 4.2 in the manual)
+
+          - TODO: switch to a record representation, and keep location
         *)
   | Rinherit of core_type
         (* [ T ] *)

parsing/pprintast.ml

@@ -286,7 +286,7 @@ class printer  ()= object(self:'self)
     | Ptyp_variant (l, closed, low) ->
         let type_variant_helper f x =
           match x with
-          | Rtag (l, _, ctl) -> pp f "@[<2>%a%a@]"  self#string_quot l
+          | Rtag (l, _attrs, _, ctl) -> pp f "@[<2>%a%a@]"  self#string_quot l
                 (fun f l -> match l with
                 |[] -> ()
                 | _ -> pp f "@;of@;%a"

parsing/printast.ml

@@ -823,8 +823,9 @@ and label_x_expression i ppf (l,e) =
 
 and label_x_bool_x_core_type_list i ppf x =
   match x with
-    Rtag (l, b, ctl) ->
+    Rtag (l, attrs, b, ctl) ->
       line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+      attributes (i+1) ppf attrs;
       list (i+1) core_type ppf ctl
   | Rinherit (ct) ->
       line i ppf "Rinherit\n";

tools/depend.ml

@@ -48,7 +48,7 @@ let rec add_type bv ty =
   | Ptyp_alias(t, s) -> add_type bv t
   | Ptyp_variant(fl, _, _) ->
       List.iter
-        (function Rtag(_,_,stl) -> List.iter (add_type bv) stl
+        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
           | Rinherit sty -> add_type bv sty)
         fl
   | Ptyp_poly(_, t) -> add_type bv t

tools/tast_iter.ml

@@ -302,7 +302,7 @@ let class_structure sub cs =
 
 let row_field sub rf =
   match rf with
-  | Ttag (_label, _bool, list) -> List.iter (sub # core_type) list
+  | Ttag (_label, _attrs, _bool, list) -> List.iter (sub # core_type) list
   | Tinherit ct -> sub # core_type ct
 
 let class_field sub cf =

tools/untypeast.ml

@@ -554,8 +554,8 @@ and untype_class_structure cs =
 
 and untype_row_field rf =
   match rf with
-    Ttag (label, bool, list) ->
-      Rtag (label, bool, List.map untype_core_type list)
+    Ttag (label, attrs, bool, list) ->
+      Rtag (label, attrs, bool, List.map untype_core_type list)
   | Tinherit ct -> Rinherit (untype_core_type ct)
 
 and untype_class_field cf =

typing/printtyped.ml

@@ -804,8 +804,9 @@ and ident_x_loc_x_expression_def i ppf (l,_, e) =
 
 and label_x_bool_x_core_type_list i ppf x =
   match x with
-    Ttag (l, b, ctl) ->
+    Ttag (l, attrs, b, ctl) ->
       line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+      attributes (i+1) ppf attrs;
       list (i+1) core_type ppf ctl
   | Tinherit (ct) ->
       line i ppf "Rinherit\n";

typing/typedtree.ml

@@ -361,7 +361,7 @@ and package_type = {
 }
 
 and row_field =
-    Ttag of label * bool * core_type list
+    Ttag of label * attributes * bool * core_type list
   | Tinherit of core_type
 
 and value_description =

typing/typedtree.mli

@@ -360,7 +360,7 @@ and package_type = {
 }
 
 and row_field =
-    Ttag of label * bool * core_type list
+    Ttag of label * attributes * bool * core_type list
   | Tinherit of core_type
 
 and value_description =

typing/typedtreeIter.ml

@@ -531,7 +531,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
     and iter_row_field rf =
       match rf with
-        Ttag (label, bool, list) ->
+        Ttag (label, _attrs, bool, list) ->
           List.iter iter_core_type list
       | Tinherit ct -> iter_core_type ct
 

typing/typedtreeMap.ml

@@ -576,8 +576,8 @@ module MakeMap(Map : MapArgument) = struct
 
   and map_row_field rf =
     match rf with
-        Ttag (label, bool, list) ->
-          Ttag (label, bool, List.map map_core_type list)
+        Ttag (label, attrs, bool, list) ->
+          Ttag (label, attrs, bool, List.map map_core_type list)
       | Tinherit ct -> Tinherit (map_core_type ct)
 
   and map_class_field cf =

typing/typetexp.ml

@@ -508,7 +508,7 @@ let rec transl_type env policy styp =
           Hashtbl.add hfields h (l,f)
       in
       let add_field = function
-          Rtag (l, c, stl) ->
+          Rtag (l, attrs, c, stl) ->
             name := None;
             let tl = List.map (transl_type env policy) stl in
             let f = match present with
@@ -523,7 +523,7 @@ let rec transl_type env policy styp =
                       Rpresent (Some st.ctyp_type)
             in
             add_typed_field styp.ptyp_loc l f;
-              Ttag (l,c,tl)
+              Ttag (l,attrs,c,tl)
         | Rinherit sty ->
             let cty = transl_type env policy sty in
             let ty = cty.ctyp_type in