Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

#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
  • Loading branch information...
commit b791d666d824cf3dff297cf4e25bca1bde3a3109 1 parent 772a843
@alainfrisch alainfrisch authored
View
3  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} =
View
12 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 }
View
4 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 ] *)
View
2  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"
View
3  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";
View
2  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
View
2  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 =
View
4 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 =
View
3  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";
View
2  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 =
View
2  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 =
View
2  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
View
4 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 =
View
4 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
Please sign in to comment.
Something went wrong with that request. Please try again.