Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Cleanup + support attributes on type declarations (syntax: type t = ... with (:a1 expr1) (:a2 expr2) ... (:an exprn)). 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13332 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-03-01 12:44:04 +00:00
parent 666d6574d7
commit c8d3ff52a2
16 changed files with 87 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -322,7 +322,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
let (params, variance) = List.split tl in
{ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc;
ptype_variance = variance}
ptype_variance = variance; ptype_attributes = []}
;
value mkprivate' m = if m then Private else Public;
value mkprivate = fun
@ -445,7 +445,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
ptype_kind = kind;
ptype_private = priv;
ptype_manifest = Some ct;
ptype_loc = mkloc loc; ptype_variance = variance});
ptype_loc = mkloc loc; ptype_variance = variance;
ptype_attributes = [];
});
value rec mkwithc wc acc =
match wc with
@ -656,8 +658,8 @@ value varify_constructors var_names =
Ptyp_poly(string_lst, loop core_type)
| Ptyp_package longident lst ->
Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
| Ptyp_attribute (s, e, t) ->
Ptyp_attribute (s, e, loop t)
| Ptyp_attribute (t, x) ->
Ptyp_attribute (loop t, x)
| Ptyp_extension x ->
Ptyp_extension x
]

2
camlp4/boot/Camlp4.ml
View File

@ -14480,6 +14480,7 @@ module Struct =
ptype_manifest = tm;
ptype_loc = mkloc loc;
ptype_variance = variance;
ptype_attributes = [];
}
let mkprivate' m = if m then Private else Public
@ -14633,6 +14634,7 @@ module Struct =
ptype_manifest = Some ct;
ptype_loc = mkloc loc;
ptype_variance = variance;
ptype_attributes = [];
}))
let rec mkwithc wc acc =

2
ocamldoc/odoc_ast.ml
View File

@ -1054,7 +1054,7 @@ module Analyser =
Parsetree.Pstr_eval _ ->
(* don't care *)
(0, env, [])
| Parsetree.Pstr_attribute (_, _, x) ->
| Parsetree.Pstr_attribute (x, _) ->
analyse_structure_item env current_module_name loc pos_limit comment_opt x.Parsetree.pstr_desc typedtree table table_values
| Parsetree.Pstr_extension _ ->
(0, env, [])

2
otherlibs/labltk/browser/searchpos.ml
View File

@ -130,7 +130,7 @@ let rec search_pos_type t ~pos ~env =
List.iter tl ~f:(search_pos_type ~pos ~env);
add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc
| Ptyp_alias (t, _)
| Ptyp_attribute (_, _, t)
| Ptyp_attribute (t, _)
| Ptyp_poly (_, t) -> search_pos_type ~pos ~env t
| Ptyp_package (_, stl) ->
List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env)

39
parsing/ast_mapper.ml
View File

@ -19,7 +19,6 @@ open Asttypes
(* First, some helpers to build AST fragments *)
let map_flatten f l = List.flatten (List.map f l)
let map_snd f (x, y) = (x, f y)
let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
let map_opt f = function None -> None | Some x -> Some (f x)
@ -41,8 +40,8 @@ module T = struct
let variant ?loc a b c = mk ?loc (Ptyp_variant (a, b, c))
let poly ?loc a b = mk ?loc (Ptyp_poly (a, b))
let package ?loc a b = mk ?loc (Ptyp_package (a, b))
let attribute ?loc a b c = mk ?loc (Ptyp_attribute (a, b, c))
let extension ?loc a b = mk ?loc (Ptyp_extension (a, b))
let attribute ?loc a b = mk ?loc (Ptyp_attribute (a, b))
let extension ?loc a = mk ?loc (Ptyp_extension a)
let field_type ?(loc = Location.none) x = {pfield_desc = x; pfield_loc = loc}
let field ?loc s t =
@ -80,8 +79,8 @@ module T = struct
| Ptyp_variant (rl, b, ll) -> variant ~loc (List.map (row_field sub) rl) b ll
| Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t)
| Ptyp_package (lid, l) -> package ~loc (map_loc sub lid) (List.map (map_tuple (map_loc sub) (sub # typ)) l)
| Ptyp_attribute (s, arg, body) -> attribute ~loc s (sub # expr arg) (sub # typ body)
| Ptyp_extension (s, arg) -> extension ~loc s (sub # expr arg)
| Ptyp_attribute (body, x) -> attribute ~loc (sub # typ body) (sub # attribute x)
| Ptyp_extension x -> extension ~loc (sub # extension x)
let map_type_declaration sub td =
{td with
@ -92,6 +91,7 @@ module T = struct
ptype_kind = sub # type_kind td.ptype_kind;
ptype_manifest = map_opt (sub # typ) td.ptype_manifest;
ptype_loc = sub # location td.ptype_loc;
ptype_attributes = List.map (sub # attribute) td.ptype_attributes;
}
let map_type_kind sub = function
@ -235,10 +235,10 @@ module M = struct
let class_ ?loc a = mk_item ?loc (Pstr_class a)
let class_type ?loc a = mk_item ?loc (Pstr_class_type a)
let include_ ?loc a = mk_item ?loc (Pstr_include a)
let attribute ?loc a b c = mk_item ?loc (Pstr_attribute (a, b, c))
let extension ?loc a b = mk_item ?loc (Pstr_extension (a, b))
let attribute ?loc a b = mk_item ?loc (Pstr_attribute (a, b))
let extension ?loc a = mk_item ?loc (Pstr_extension a)
let rec map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
let loc = sub # location loc in
match desc with
| Pstr_eval x -> eval ~loc (sub # expr x)
@ -254,8 +254,8 @@ module M = struct
| Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
| Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
| Pstr_include e -> include_ ~loc (sub # module_expr e)
| Pstr_attribute (s, arg, body) -> attribute ~loc s (sub # expr arg) (map_structure_item sub body) (* not very nice, because sub # structure_item can return a list -- to be cleaned up *)
| Pstr_extension (s, arg) -> extension ~loc s (sub # expr arg)
| Pstr_attribute (body, x) -> attribute ~loc (sub # structure_item body) (sub # attribute x)
| Pstr_extension x -> extension ~loc (sub # extension x)
end
module E = struct
@ -296,8 +296,8 @@ module E = struct
let newtype ?loc a b = mk ?loc (Pexp_newtype (a, b))
let pack ?loc a = mk ?loc (Pexp_pack a)
let open_ ?loc a b = mk ?loc (Pexp_open (a, b))
let attribute ?loc a b c = mk ?loc (Pexp_attribute (a, b, c))
let extension ?loc a b = mk ?loc (Pexp_extension (a, b))
let attribute ?loc a b = mk ?loc (Pexp_attribute (a, b))
let extension ?loc a = mk ?loc (Pexp_extension a)
let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc)
let apply_nolabs ?loc f el = apply ?loc f (List.map (fun e -> ("", e)) el)
@ -339,8 +339,8 @@ module E = struct
| Pexp_newtype (s, e) -> newtype ~loc s (sub # expr e)
| Pexp_pack me -> pack ~loc (sub # module_expr me)
| Pexp_open (lid, e) -> open_ ~loc (map_loc sub lid) (sub # expr e)
| Pexp_attribute (s, arg, body) -> attribute ~loc s (sub # expr arg) (sub # expr body)
| Pexp_extension (s, arg) -> extension ~loc s (sub # expr arg)
| Pexp_attribute (body, x) -> attribute ~loc (sub # expr body) (sub # attribute x)
| Pexp_extension x -> extension ~loc (sub # extension x)
end
module P = struct
@ -461,12 +461,12 @@ class mapper =
object(this)
method implementation (input_name : string) ast = (input_name, this # structure ast)
method interface (input_name: string) ast = (input_name, this # signature ast)
method structure l = map_flatten (this # structure_item) l
method structure_item si = [ M.map_structure_item this si ]
method structure l = List.map (this # structure_item) l
method structure_item si = M.map_structure_item this si
method module_expr = M.map this
method signature l = map_flatten (this # signature_item) l
method signature_item si = [ MT.map_signature_item this si ]
method signature l = List.map (this # signature_item) l
method signature_item si = MT.map_signature_item this si
method module_type = MT.map this
method with_constraint c = MT.map_with_constraint this c
@ -498,6 +498,9 @@ class mapper =
method exception_declaration tl = List.map (this # typ) tl
method location l = l
method extension (s, e) = (s, this # expr e)
method attribute (s, e) = (s, this # expr e)
end
class type main_entry_points =

6
parsing/ast_mapper.mli
View File

@ -37,14 +37,16 @@ class mapper:
method module_type: module_type -> module_type
method pat: pattern -> pattern
method signature: signature -> signature
method signature_item: signature_item -> signature_item list
method signature_item: signature_item -> signature_item
method structure: structure -> structure
method structure_item: structure_item -> structure_item list
method structure_item: structure_item -> structure_item
method typ: core_type -> core_type
method type_declaration: type_declaration -> type_declaration
method type_kind: type_kind -> type_kind
method value_description: value_description -> value_description
method with_constraint: with_constraint -> with_constraint
method attribute: attribute -> attribute
method extension: extension -> extension
end
class type main_entry_points =

26
parsing/parser.mly
View File

@ -273,8 +273,8 @@ let varify_constructors var_names t =
Ptyp_poly(string_lst, loop core_type)
| Ptyp_package(longident,lst) ->
Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
| Ptyp_attribute (s, arg, t) ->
Ptyp_attribute (s, arg, loop t)
| Ptyp_attribute (t, x) ->
Ptyp_attribute (loop t, x)
| Ptyp_extension (s, arg) ->
Ptyp_extension (s, arg)
in
@ -612,7 +612,7 @@ structure_item:
| DOTDOT extension
{ mkstr (Pstr_extension $2) }
| structure_item DOTDOT attribute
{ mkstr(Pstr_attribute (fst $3, snd $3, $1)) }
{ mkstr(Pstr_attribute ($1, $3)) }
;
module_binding:
EQUAL module_expr
@ -1073,7 +1073,7 @@ expr:
| OBJECT class_structure error
{ unclosed "object" 1 "end" 3 }
| simple_expr attribute
{ mkexp (Pexp_attribute(fst $2, snd $2, $1)) }
{ mkexp (Pexp_attribute($1, $2)) }
;
opt_expr:
expr { $1 }
@ -1384,7 +1384,7 @@ type_declarations:
;
type_declaration:
optional_type_parameters LIDENT type_kind constraints
optional_type_parameters LIDENT type_kind constraints type_declaration_attribute
{ let (params, variance) = List.split $1 in
let (kind, private_flag, manifest) = $3 in
(mkrhs $2 2, {ptype_params = params;
@ -1393,7 +1393,13 @@ type_declaration:
ptype_private = private_flag;
ptype_manifest = manifest;
ptype_variance = variance;
ptype_loc = symbol_rloc() }) }
ptype_attributes = $5;
ptype_loc = symbol_rloc();
}) }
;
type_declaration_attribute:
WITH attributes { $2 }
| { [] }
;
constraints:
constraints CONSTRAINT constrain { $3 :: $1 }
@ -1501,6 +1507,7 @@ with_constraint:
ptype_manifest = Some $5;
ptype_private = $4;
ptype_variance = variance;
ptype_attributes = [];
ptype_loc = symbol_rloc()}) }
/* used label_longident instead of type_longident to disallow
functor applications in type path */
@ -1513,6 +1520,7 @@ with_constraint:
ptype_manifest = Some $5;
ptype_private = Public;
ptype_variance = variance;
ptype_attributes = [];
ptype_loc = symbol_rloc()}) }
| MODULE mod_longident EQUAL mod_ext_longident
{ (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
@ -1564,7 +1572,7 @@ simple_core_type:
| LPAREN core_type_comma_list RPAREN %prec below_SHARP
{ match $2 with [sty] -> sty | _ -> raise Parse_error }
| simple_core_type attribute
{ mktyp (Ptyp_attribute(fst $2, snd $2, $1)) }
{ mktyp (Ptyp_attribute($1, $2)) }
;
simple_core_type2:
QUOTE ident
@ -1616,6 +1624,10 @@ extension:
attribute:
| LPAREN COLON LIDENT opt_expr RPAREN { ($3, $4) }
;
attributes:
| { [] }
| attribute attributes { $1 :: $2 }
;
package_type:
mty_longident { (mkrhs $1 1, []) }
| mty_longident WITH package_type_cstrs { (mkrhs $1 1, $3) }

9
parsing/parsetree.mli
View File

@ -16,7 +16,7 @@ open Asttypes
(* Extension points *)
type 'a attribute = string * expression * 'a
type attribute = string * expression
and extension = string * expression
@ -38,7 +38,7 @@ and core_type_desc =
| Ptyp_variant of row_field list * bool * label list option
| Ptyp_poly of string list * core_type
| Ptyp_package of package_type
| Ptyp_attribute of core_type attribute
| Ptyp_attribute of (core_type * attribute)
| Ptyp_extension of extension
@ -127,7 +127,7 @@ and expression_desc =
| Pexp_newtype of string * expression
| Pexp_pack of module_expr
| Pexp_open of Longident.t loc * expression
| Pexp_attribute of expression attribute
| Pexp_attribute of (expression * attribute)
| Pexp_extension of extension
(* Value descriptions *)
@ -147,6 +147,7 @@ and type_declaration =
ptype_private: private_flag;
ptype_manifest: core_type option;
ptype_variance: (bool * bool) list;
ptype_attributes: attribute list;
ptype_loc: Location.t }
and type_kind =
@ -301,7 +302,7 @@ and structure_item_desc =
| Pstr_class of class_declaration list
| Pstr_class_type of class_type_declaration list
| Pstr_include of module_expr
| Pstr_attribute of structure_item attribute
| Pstr_attribute of structure_item * attribute
| Pstr_extension of extension
(* Toplevel phrases *)

13
parsing/pprintast.ml
View File

@ -299,8 +299,8 @@ class printer ()= object(self:'self)
|_ ->
pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid
(self#list aux ~sep:"@ and@ ") cstrs)
| Ptyp_attribute (s, arg, body) ->
pp f "@[<2>(@@%s@ %a)@ %a@]" s self#expression arg self#core_type body
| Ptyp_attribute (body, (s, arg)) ->
pp f "@[<2>%a@ (:%s@ %a)@]" self#core_type body s self#expression arg
| Ptyp_extension (s, arg) ->
pp f "@[<2>(&%s@ %a)@]" s self#expression arg
| _ -> self#paren true self#core_type f x
@ -621,8 +621,8 @@ class printer ()= object(self:'self)
self#expression e
| Pexp_variant (l,Some eo) ->
pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
| Pexp_attribute (s, arg, body) ->
pp f "@[<2>(@@%s@ %a)@ %a@]" s self#expression arg self#expression body
| Pexp_attribute (body, (s, arg)) ->
pp f "@[<2>%a@ (:%s@ %a)@]" self#expression body s self#expression arg
| Pexp_extension (s, arg) ->
pp f "@[<2>(&%s@ %a)@]" s self#expression arg
| _ -> self#expression1 f x
@ -1091,8 +1091,8 @@ class printer ()= object(self:'self)
(fun f l2 -> List.iter (text_x_modtype_x_module f) l2) l2
| _ -> assert false
end
| Pstr_attribute (s, arg, body) ->
pp f "@[<2>%a@ ::%s@ %a@]" self#structure_item body s self#expression arg
| Pstr_attribute (body, (s, arg)) ->
pp f "@[<2>%a@ (:%s@ %a)@]" self#structure_item body s self#expression arg
| Pstr_extension (s, arg) ->
pp f "@[<2>&(%s@ %a)@]" s self#expression arg
@ -1157,6 +1157,7 @@ class printer ()= object(self:'self)
(fun f (ct1,ct2,_) ->
pp f "@[<hov2>constraint@ %a@ =@ %a@]"
self#core_type ct1 self#core_type ct2 )) x.ptype_cstrs ;
(* TODO: attributes *)
end
method case_list f (l:(pattern * expression) list) :unit=
let aux f (p,e) =

13
parsing/printast.ml
View File

@ -163,7 +163,7 @@ let rec core_type i ppf x =
| Ptyp_package (s, l) ->
line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
list i package_with ppf l;
| Ptyp_attribute (s, arg, body) ->
| Ptyp_attribute (body, (s, arg)) ->
line i ppf "Ptyp_attribute \"%s\"\n" s;
expression i ppf arg;
core_type i ppf body
@ -344,7 +344,7 @@ and expression i ppf x =
| Pexp_open (m, e) ->
line i ppf "Pexp_open \"%a\"\n" fmt_longident_loc m;
expression i ppf e
| Pexp_attribute (s, arg, body) ->
| Pexp_attribute (body, (s, arg)) ->
line i ppf "Pexp_attribute \"%s\"\n" s;
expression i ppf arg;
expression i ppf body
@ -376,6 +376,13 @@ and type_declaration i ppf x =
line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
line i ppf "ptype_manifest =\n";
option (i+1) core_type ppf x.ptype_manifest;
line i ppf "ptype_attributes = \n";
List.iter
(fun (s, arg) ->
line (i + 1) ppf "attribute \"%s\"\n" s;
expression (i + 1) ppf arg;
)
x.ptype_attributes
and type_kind i ppf x =
match x with
@ -669,7 +676,7 @@ and structure_item i ppf x =
| Pstr_include me ->
line i ppf "Pstr_include";
module_expr i ppf me
| Pstr_attribute (s, arg, body) ->
| Pstr_attribute (body, (s, arg)) ->
line i ppf "Pstr_attribute \"%s\"\n" s;
expression i ppf arg;
structure_item i ppf body

6
tools/depend.ml
View File

@ -53,7 +53,7 @@ let rec add_type bv ty =
fl
| Ptyp_poly(_, t) -> add_type bv t
| Ptyp_package pt -> add_package_type bv pt
| Ptyp_attribute (_, _, e) -> add_type bv e
| Ptyp_attribute (e, _) -> add_type bv e
| Ptyp_extension _ -> ()
and add_package_type bv (lid, l) =
@ -177,7 +177,7 @@ let rec add_expr bv exp =
| Pexp_newtype (_, e) -> add_expr bv e
| Pexp_pack m -> add_module bv m
| Pexp_open (m, e) -> addmodule bv m; add_expr bv e
| Pexp_attribute (_, _, e) -> add_expr bv e
| Pexp_attribute (e, _) -> add_expr bv e
| Pexp_extension _ -> ()
and add_pat_expr_list bv pel =
@ -289,7 +289,7 @@ and add_struct_item bv item =
List.iter (add_class_type_declaration bv) cdtl; bv
| Pstr_include modl ->
add_module bv modl; bv
| Pstr_attribute (_, _, e) -> add_struct_item bv e
| Pstr_attribute (e, _) -> add_struct_item bv e
| Pstr_extension _ -> bv
and add_use_file bv top_phrs =

2
tools/ocamlprof.ml
View File

@ -283,7 +283,7 @@ and rw_exp iflag sexp =
| Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
| Pexp_open (_, e) -> rewrite_exp iflag e
| Pexp_pack (smod) -> rewrite_mod iflag smod
| Pexp_attribute (_, _, e) -> rewrite_exp iflag e
| Pexp_attribute (e, _) -> rewrite_exp iflag e
| Pexp_extension _ -> ()
and rewrite_ifbody iflag ghost sifbody =

1
tools/untypeast.ml
View File

@ -120,6 +120,7 @@ and untype_type_declaration decl =
None -> None
| Some ct -> Some (untype_core_type ct));
ptype_variance = decl.typ_variance;
ptype_attributes = []; (* TODO *)
ptype_loc = decl.typ_loc;
}

6
typing/typecore.ml
View File

@ -140,7 +140,7 @@ let iter_expression f e =
| Pexp_assert e
| Pexp_setinstvar (_, e)
| Pexp_send (e, _)
| Pexp_attribute (_, _, e) (* we don't iterate on the attribute argument *)
| Pexp_attribute (e, _) (* we don't iterate on the attribute argument *)
| Pexp_constraint (e, _, _)
| Pexp_field (e, _) -> expr e
| Pexp_when (e1, e2)
@ -179,7 +179,7 @@ let iter_expression f e =
| Pstr_module (_, me) -> module_expr me
| Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
| Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
| Pstr_attribute (_, _, e) -> structure_item e
| Pstr_attribute (i, _) -> structure_item i
and class_expr ce =
@ -2686,7 +2686,7 @@ and type_expect_ ?in_function env sexp ty_expected =
{ exp with
exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra;
}
| Pexp_attribute (_s, _arg, body) ->
| Pexp_attribute (body, (_s, _arg)) ->
let exp = type_expect env body ty_expected in
(*
{ exp with

2
typing/typemod.ml
View File

@ -1119,7 +1119,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
sg @ sig_rem,
final_env)
| Pstr_attribute (_, _, st) ->
| Pstr_attribute (st, _) ->
type_struct env srem (* keep attribute in the typedtree? *)
| Pstr_extension (s, _arg) ->
raise (Error (loc, env, Extension s))

3
typing/typetexp.ml
View File

@ -142,6 +142,7 @@ let create_package_mty fake loc env (p, l) =
ptype_private = Asttypes.Public;
ptype_manifest = if fake then None else Some t;
ptype_variance = [];
ptype_attributes = [];
ptype_loc = loc} in
{pmty_desc=Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]);
pmty_loc=loc}
@ -560,7 +561,7 @@ let rec transl_type env policy styp =
pack_fields = ptys;
pack_txt = p;
}) ty env loc
| Ptyp_attribute (_, _, st) ->
| Ptyp_attribute (st, _) ->
transl_type env policy st (* keep attribute in the typedtree? *)
| Ptyp_extension (s, _arg) ->
raise (Error (loc, env, Extension s))