diff options
Diffstat (limited to 'parsing')
| -rw-r--r-- | parsing/ast_helper.ml | 23 | ||||
| -rw-r--r-- | parsing/ast_helper.mli | 18 | ||||
| -rw-r--r-- | parsing/ast_mapper.ml | 37 | ||||
| -rw-r--r-- | parsing/parser.mly | 2 | ||||
| -rw-r--r-- | parsing/parsetree.mli | 8 | ||||
| -rw-r--r-- | parsing/pprintast.ml | 3 | ||||
| -rw-r--r-- | parsing/printast.ml | 4 |
7 files changed, 57 insertions, 38 deletions
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index d87353e13..e5720bbf3 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -162,14 +162,21 @@ module Str = struct end module Cl = struct - let mk ?(loc = Location.none) d = {pcl_desc = d; pcl_loc = loc} - - let constr ?loc a b = mk ?loc (Pcl_constr (a, b)) - let structure ?loc a = mk ?loc (Pcl_structure a) - let fun_ ?loc a b c d = mk ?loc (Pcl_fun (a, b, c, d)) - let apply ?loc a b = mk ?loc (Pcl_apply (a, b)) - let let_ ?loc a b c = mk ?loc (Pcl_let (a, b, c)) - let constraint_ ?loc a b = mk ?loc (Pcl_constraint (a, b)) + let mk ?(loc = Location.none) ?(attrs = []) d = + { + pcl_desc = d; + pcl_loc = loc; + pcl_attributes = attrs; + } + let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) + let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) end module Cty = struct diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 4e134982b..5dc4714f3 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -160,14 +160,16 @@ module Str: end module Cl: sig - val mk: ?loc:Location.t -> class_expr_desc -> class_expr - - val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> class_expr - val structure: ?loc:Location.t -> class_structure -> class_expr - val fun_: ?loc:Location.t -> label -> expression option -> pattern -> class_expr -> class_expr - val apply: ?loc:Location.t -> class_expr -> (label * expression) list -> class_expr - val let_: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr - val constraint_: ?loc:Location.t -> class_expr -> class_type -> class_expr + val mk: ?loc:Location.t -> ?attrs:attribute list -> class_expr_desc -> class_expr + val attr: class_expr -> attribute -> class_expr + + val constr: ?loc:Location.t -> ?attrs:attribute list -> Longident.t loc -> core_type list -> class_expr + val structure: ?loc:Location.t -> ?attrs:attribute list -> class_structure -> class_expr + val fun_: ?loc:Location.t -> ?attrs:attribute list -> label -> expression option -> pattern -> class_expr -> class_expr + val apply: ?loc:Location.t -> ?attrs:attribute list -> class_expr -> (label * expression) list -> class_expr + val let_: ?loc:Location.t -> ?attrs:attribute list -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr + val constraint_: ?loc:Location.t -> ?attrs:attribute list -> class_expr -> class_type -> class_expr + val extension: ?loc:Location.t -> ?attrs:attribute list -> extension -> class_expr end module Cty: sig diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 5656fec9a..36773b802 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -87,14 +87,14 @@ module CT = struct (sub # typ t) (sub # class_type ct) - let map_field sub {pctf_desc = desc; pctf_loc = loc} = + let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = let open Ctf in let loc = sub # location loc in match desc with - | Pctf_inherit ct -> inherit_ ~loc (sub # class_type ct) - | Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t) - | Pctf_method (s, p, v, t) -> method_ ~loc s p v (sub # typ t) - | Pctf_constraint (t1, t2) -> constraint_ ~loc (sub # typ t1) (sub # typ t2) + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct) + | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t) + | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t) + | Pctf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} = Csig.mk @@ -257,40 +257,41 @@ end module CE = struct (* Value expressions for the class language *) - let map sub {pcl_loc = loc; pcl_desc = desc} = + let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = let open Cl in let loc = sub # location loc in match desc with - | Pcl_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys) + | Pcl_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) | Pcl_structure s -> - structure ~loc (sub # class_structure s) + structure ~loc ~attrs (sub # class_structure s) | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc lab + fun_ ~loc ~attrs lab (map_opt (sub # expr) e) (sub # pat p) (sub # class_expr ce) | Pcl_apply (ce, l) -> - apply ~loc (sub # class_expr ce) (List.map (map_snd (sub # expr)) l) + apply ~loc ~attrs (sub # class_expr ce) (List.map (map_snd (sub # expr)) l) | Pcl_let (r, pel, ce) -> - let_ ~loc r + let_ ~loc ~attrs r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # class_expr ce) | Pcl_constraint (ce, ct) -> - constraint_ ~loc (sub # class_expr ce) (sub # class_type ct) + constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct) + | Pcl_extension x -> extension ~loc ~attrs (sub # extension x) let map_kind sub = function | Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e) | Cfk_virtual t -> Cfk_virtual (sub # typ t) - let map_field sub {pcf_desc = desc; pcf_loc = loc} = + let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = let open Cf in let loc = sub # location loc in match desc with - | Pcf_inherit (o, ce, s) -> inherit_ ~loc o (sub # class_expr ce) s - | Pcf_val (s, m, k) -> val_ ~loc (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> method_ ~loc (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> constraint_ ~loc (sub # typ t1) (sub # typ t2) - | Pcf_initializer e -> initializer_ ~loc (sub # expr e) + | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr ce) s + | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) + | Pcf_method (s, p, k) -> method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) + | Pcf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e) let map_structure sub {pcstr_self; pcstr_fields} = { diff --git a/parsing/parser.mly b/parsing/parser.mly index 7b56d7f2f..ff62117e8 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -771,6 +771,8 @@ class_expr: { mkclass(Pcl_apply($1, List.rev $2)) } | LET rec_flag let_bindings IN class_expr { mkclass(Pcl_let ($2, List.rev $3, $5)) } + | class_expr attribute + { Cl.attr $1 $2 } ; class_simple_expr: LBRACKET core_type_comma_list RBRACKET class_longident diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 7f6e2c1bb..2abc78dcd 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -209,8 +209,11 @@ and class_type_declaration = class_type class_infos (* Value expressions for the class language *) and class_expr = - { pcl_desc: class_expr_desc; - pcl_loc: Location.t } + { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attribute list; + } and class_expr_desc = Pcl_constr of Longident.t loc * core_type list @@ -219,6 +222,7 @@ and class_expr_desc = | Pcl_apply of class_expr * (label * expression) list | Pcl_let of rec_flag * (pattern * expression) list * class_expr | Pcl_constraint of class_expr * class_type + | Pcl_extension of extension and class_structure = { pcstr_self: pattern; diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index aa812542e..b7c2e5cbd 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -818,8 +818,7 @@ class printer ()= object(self:'self) pp f "(%a@ :@ %a)" self#class_expr ce self#class_type ct - - + | Pcl_extension _ -> assert false method module_type f x = match x.pmty_desc with diff --git a/parsing/printast.ml b/parsing/printast.ml index 731fa48d9..87d9ee23d 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -463,6 +463,7 @@ and class_type_declaration i ppf x = and class_expr i ppf x = line i ppf "class_expr %a\n" fmt_location x.pcl_loc; + attributes i ppf x.pcl_attributes; let i = i+1 in match x.pcl_desc with | Pcl_constr (li, l) -> @@ -489,6 +490,9 @@ and class_expr i ppf x = line i ppf "Pcl_constraint\n"; class_expr i ppf ce; class_type i ppf ct; + | Pcl_extension (s, arg) -> + line i ppf "Pcl_extension \"%s\"\n" s; + expression i ppf arg and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = line i ppf "class_structure\n"; |