diff options
-rw-r--r-- | camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml | 2 | ||||
-rw-r--r-- | camlp4/boot/Camlp4.ml | 2 | ||||
-rw-r--r-- | experimental/frisch/extension_points.txt | 4 | ||||
-rw-r--r-- | ocamldoc/odoc_sig.ml | 1 | ||||
-rw-r--r-- | otherlibs/labltk/browser/searchpos.ml | 1 | ||||
-rw-r--r-- | parsing/ast_helper.ml | 15 | ||||
-rw-r--r-- | parsing/ast_helper.mli | 10 | ||||
-rw-r--r-- | parsing/ast_mapper.ml | 9 | ||||
-rw-r--r-- | parsing/parser.mly | 6 | ||||
-rw-r--r-- | parsing/parsetree.mli | 8 | ||||
-rw-r--r-- | parsing/pprintast.ml | 1 | ||||
-rw-r--r-- | parsing/printast.ml | 4 | ||||
-rw-r--r-- | tools/depend.ml | 1 | ||||
-rw-r--r-- | tools/untypeast.ml | 4 | ||||
-rw-r--r-- | typing/printtyped.ml | 1 | ||||
-rw-r--r-- | typing/typeclass.ml | 23 | ||||
-rw-r--r-- | typing/typedtree.ml | 11 | ||||
-rw-r--r-- | typing/typedtree.mli | 11 |
18 files changed, 79 insertions, 35 deletions
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 459002293..e8231caff 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -67,7 +67,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []}; value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; - value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; + value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []}; value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []}; value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []}; value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []}; diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 2ce1832ce..dadd2d133 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -14185,7 +14185,7 @@ module Struct = let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; } - let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; } + let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []} let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []} diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt index 33d904f8e..da24f7452 100644 --- a/experimental/frisch/extension_points.txt +++ b/experimental/frisch/extension_points.txt @@ -13,7 +13,7 @@ a dots (whitespaces are allowed around the dots). In the Parsetree, the identifier is represented as a single string (without spaces). Attributes on expressions, type expressions, module expressions, module type expressions, -patterns, class expressions (TODO: class type expressions): +patterns, class expressions, class type expressions: ... [@id expr] @@ -84,7 +84,7 @@ expression (written expr below). Two syntaxes exist for extension node: As expressions, type expressions, module expressions, module type expressions, -patterns, class expressions (TODO: class type expressions): +patterns, class expressions, class type expressions: [%id expr] diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 18a5bf5c6..4d361ad2b 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -456,6 +456,7 @@ module Analyser = ic_class = None ; ic_text = text_opt ; } + | Parsetree.Pcty_extension _ -> assert false in let (inher_l, eles) = f (pos_end + maybe_more) q in (inh :: inher_l , eles_comments @ eles) diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 8d252edbd..7dda53ba0 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -153,6 +153,7 @@ let rec search_pos_class_type cl ~pos ~env = | Pcty_fun (_, ty, cty) -> search_pos_type ty ~pos ~env; search_pos_class_type cty ~pos ~env + | Pcty_extension _ -> () end let search_pos_type_decl td ~pos ~env = diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index e5720bbf3..853c647f0 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -180,11 +180,18 @@ module Cl = struct end module Cty = struct - let mk ?(loc = Location.none) d = {pcty_desc = d; pcty_loc = loc} + let mk ?(loc = Location.none) ?(attrs = []) d = + { + pcty_desc = d; + pcty_loc = loc; + pcty_attributes = attrs; + } + let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - let constr ?loc a b = mk ?loc (Pcty_constr (a, b)) - let signature ?loc a = mk ?loc (Pcty_signature a) - let fun_ ?loc a b c = mk ?loc (Pcty_fun (a, b, c)) + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) + let fun_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_fun (a, b, c)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) end module Ctf = struct diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 5dc4714f3..13fa0a720 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -173,11 +173,13 @@ module Cl: end module Cty: sig - val mk: ?loc:Location.t -> class_type_desc -> class_type + val mk: ?loc:Location.t -> ?attrs:attribute list -> class_type_desc -> class_type + val attr: class_type -> attribute -> class_type - val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> class_type - val signature: ?loc:Location.t -> class_signature -> class_type - val fun_: ?loc:Location.t -> label -> core_type -> class_type -> class_type + val constr: ?loc:Location.t -> ?attrs:attribute list -> Longident.t loc -> core_type list -> class_type + val signature: ?loc:Location.t -> ?attrs:attribute list -> class_signature -> class_type + val fun_: ?loc:Location.t -> ?attrs:attribute list -> label -> core_type -> class_type -> class_type + val extension: ?loc:Location.t -> ?attrs:attribute list -> extension -> class_type end module Ctf: sig diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 36773b802..b83d29547 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -76,16 +76,17 @@ end module CT = struct (* Type expressions for the class language *) - let map sub {pcty_loc = loc; pcty_desc = desc} = + let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = let open Cty in let loc = sub # location loc in match desc with - | Pcty_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys) - | Pcty_signature x -> signature ~loc (sub # class_signature x) + | Pcty_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x) | Pcty_fun (lab, t, ct) -> - fun_ ~loc lab + fun_ ~loc ~attrs lab (sub # typ t) (sub # class_type ct) + | Pcty_extension x -> extension ~loc ~attrs (sub # extension x) let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = let open Ctf in diff --git a/parsing/parser.mly b/parsing/parser.mly index ff62117e8..526ca84f1 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -773,6 +773,8 @@ class_expr: { mkclass(Pcl_let ($2, List.rev $3, $5)) } | class_expr attribute { Cl.attr $1 $2 } + | extension + { mkclass(Pcl_extension $1) } ; class_simple_expr: LBRACKET core_type_comma_list RBRACKET class_longident @@ -877,6 +879,10 @@ class_type: { mkcty(Pcty_fun($1, $3, $5)) } | simple_core_type_or_tuple_no_attr MINUSGREATER class_type { mkcty(Pcty_fun("", $1, $3)) } + | class_type attribute + { Cty.attr $1 $2 } + | extension + { mkcty(Pcty_extension $1) } ; class_signature: LBRACKET core_type_comma_list RBRACKET clty_longident diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 2abc78dcd..68ce63300 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -176,13 +176,17 @@ and constructor_declaration = (* Type expressions for the class language *) and class_type = - { pcty_desc: class_type_desc; - pcty_loc: Location.t } + { + pcty_desc: class_type_desc; + pcty_loc: Location.t; + pcty_attributes: attribute list; + } and class_type_desc = Pcty_constr of Longident.t loc * core_type list | Pcty_signature of class_signature | Pcty_fun of label * core_type * class_type + | Pcty_extension of extension and class_signature = { pcsig_self: core_type; diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index b7c2e5cbd..25e3bd6a0 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -738,6 +738,7 @@ class printer ()= object(self:'self) | Pcty_fun (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) self#type_with_label (l,co) self#class_type cl + | Pcty_extension _ -> assert false (* [class type a = object end] *) diff --git a/parsing/printast.ml b/parsing/printast.ml index 87d9ee23d..8f9b52672 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -402,6 +402,7 @@ and type_kind i ppf x = and class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.pcty_loc; + attributes i ppf x.pcty_attributes; let i = i+1 in match x.pcty_desc with | Pcty_constr (li, l) -> @@ -414,6 +415,9 @@ and class_type i ppf x = line i ppf "Pcty_fun \"%s\"\n" l; core_type i ppf co; class_type i ppf cl; + | Pcty_extension (s, arg) -> + line i ppf "Pcty_extension \"%s\"\n" s; + expression i ppf arg and class_signature i ppf cs = line i ppf "class_signature %a\n" fmt_location cs.pcsig_loc; diff --git a/tools/depend.ml b/tools/depend.ml index aa2c51839..bec72ecec 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -88,6 +88,7 @@ let rec add_class_type bv cty = List.iter (add_class_type_field bv) fieldl | Pcty_fun(_, ty1, cty2) -> add_type bv ty1; add_class_type bv cty2 + | Pcty_extension _ -> () and add_class_type_field bv pctf = match pctf.pctf_desc with diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 4e92f8de2..e327af0f6 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -456,7 +456,9 @@ and untype_class_type ct = Pcty_fun (label, untype_core_type ct, untype_class_type cl) in { pcty_desc = desc; - pcty_loc = ct.cltyp_loc } + pcty_loc = ct.cltyp_loc; + pcty_attributes = ct.cltyp_attributes; + } and untype_class_signature cs = { diff --git a/typing/printtyped.ml b/typing/printtyped.ml index c5905bb8f..eff21f9d7 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -416,6 +416,7 @@ and type_kind i ppf x = and class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.cltyp_loc; + attributes i ppf x.cltyp_attributes; let i = i+1 in match x.cltyp_desc with | Tcty_constr (li, _, l) -> diff --git a/typing/typeclass.ml b/typing/typeclass.ml index ceba5435c..c629d2f1a 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -53,9 +53,6 @@ open Typedtree let ctyp desc typ env loc = { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] } -let cltyp desc typ env loc = - { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env } - (**********************) (* Useful constants *) @@ -442,7 +439,15 @@ and class_signature env sty sign loc = } and class_type env scty = - let loc = scty.pcty_loc in + let cltyp desc typ = + { + cltyp_desc = desc; + cltyp_type = typ; + cltyp_loc = scty.pcty_loc; + cltyp_env = env; + cltyp_attributes = scty.pcty_attributes; + } + in match scty.pcty_desc with Pcty_constr (lid, styl) -> let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in @@ -467,20 +472,22 @@ and class_type env scty = ) styl params in let typ = Cty_constr (path, params, clty) in - cltyp (Tcty_constr ( path, lid , ctys)) typ env loc + cltyp (Tcty_constr ( path, lid , ctys)) typ | Pcty_signature pcsig -> let clsig = class_signature env pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in let typ = Cty_signature clsig.csig_type in - cltyp (Tcty_signature clsig) typ env loc + cltyp (Tcty_signature clsig) typ | Pcty_fun (l, sty, scty) -> let cty = transl_simple_type env false sty in let ty = cty.ctyp_type in let clty = class_type env scty in let typ = Cty_fun (l, ty, clty.cltyp_type) in - cltyp (Tcty_fun (l, cty, clty)) typ env loc + cltyp (Tcty_fun (l, cty, clty)) typ + | Pcty_extension (s, _arg) -> + raise (Error (scty.pcty_loc, env, Extension s)) let class_type env scty = delayed_meth_specs := []; @@ -827,7 +834,7 @@ and class_expr cl_num val_env met_env scl = cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env; - cl_attributes = scl.pcl_attributes; + cl_attributes = []; (* attributes are kept on the inner cl node *) } | Pcl_structure cl_str -> let (desc, ty) = diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 912f60845..8829fabee 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -380,10 +380,13 @@ and constructor_declaration = } and class_type = - { cltyp_desc: class_type_desc; - cltyp_type : Types.class_type; - cltyp_env : Env.t; (* BINANNOT ADDED *) - cltyp_loc: Location.t } + { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attribute list; + } and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list diff --git a/typing/typedtree.mli b/typing/typedtree.mli index b42967884..9b84a6f8d 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -380,10 +380,13 @@ and constructor_declaration = } and class_type = - { cltyp_desc: class_type_desc; - cltyp_type : Types.class_type; - cltyp_env : Env.t; (* BINANNOT ADDED *) - cltyp_loc: Location.t } + { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attribute list; + } and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list |