From 92cb754f960cedd1d66dae904d04b16d3c2b2d6a Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 21 Dec 2023 11:56:34 +0800 Subject: [PATCH] Add class_infos to Ast.t --- lib/Ast.ml | 105 +++++++++++------------------ lib/Ast.mli | 2 + lib/Fmt_ast.ml | 20 +++--- vendor/parser-extended/printast.ml | 4 ++ 4 files changed, 59 insertions(+), 72 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 3a49937408..b136d912e3 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -636,6 +636,8 @@ module T = struct | Typ of core_type | Td of type_declaration | Cty of class_type + | Cd of class_declaration + | Ctd of class_type_declaration | Pat of pattern | Exp of expression | Fp of function_param @@ -670,6 +672,9 @@ module T = struct | Cl cl -> Format.fprintf fs "Cl:@\n%a" Printast.class_expr cl | Mty mt -> Format.fprintf fs "Mty:@\n%a" Printast.module_type mt | Cty cty -> Format.fprintf fs "Cty:@\n%a" Printast.class_type cty + | Cd cd -> Format.fprintf fs "Cd:@\n%a" Printast.class_declaration cd + | Ctd ctd -> + Format.fprintf fs "Ctd:@\n%a" Printast.class_type_declaration ctd | Mod m -> Format.fprintf fs "Mod:@\n%a" Printast.module_expr m | Sig s -> Format.fprintf fs "Sig:@\n%a" Printast.signature_item s | Str s | Tli (`Item s) -> @@ -703,6 +708,8 @@ let attributes = function | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs | Cl x -> x.pcl_attributes + | Cd x -> x.pci_attributes + | Ctd x -> x.pci_attributes | Mty x -> x.pmty_attributes | Mod x -> x.pmod_attributes | Sig _ -> [] @@ -727,6 +734,8 @@ let location = function | Mb x -> x.pmb_loc | Md x -> x.pmd_loc | Cl x -> x.pcl_loc + | Cd x -> x.pci_loc + | Ctd x -> x.pci_loc | Mty x -> x.pmty_loc | Mod x -> x.pmod_loc | Sig x -> x.psig_loc @@ -906,15 +915,20 @@ end = struct let check_typexn {ptyexn_constructor; _} = check_ext ptyexn_constructor in - let check_class_type l = - List.exists l ~f:(fun {pci_expr= {pcty_desc; _}; pci_params; _} -> - List.exists pci_params ~f:(fun (t, _) -> t == typ) - || - match pcty_desc with - | Pcty_constr (_, l) -> List.exists l ~f:(fun x -> x == typ) - | Pcty_arrow (t, _) -> - List.exists t ~f:(fun x -> x.pap_type == typ) - | _ -> false ) + let check_class_type {pci_expr= {pcty_desc; _}; pci_params; _} = + List.exists pci_params ~f:(fun (t, _) -> t == typ) + || + match pcty_desc with + | Pcty_constr (_, l) -> List.exists l ~f:(fun x -> x == typ) + | Pcty_arrow (t, _) -> List.exists t ~f:(fun x -> x.pap_type == typ) + | _ -> false + in + let check_class_expr {pci_expr= {pcl_desc; _}; pci_params; _} = + List.exists pci_params ~f:(fun (t, _) -> t == typ) + || + match pcl_desc with + | Pcl_constr (_, l) -> List.exists l ~f:(fun x -> x == typ) + | _ -> false in let check_value_constraint = function | Pvc_constraint {typ= typ'; _} -> typ' == typ @@ -1017,6 +1031,8 @@ end = struct | Pcl_open _ -> false | Pcl_extension _ -> false | Pcl_structure _ -> false ) + | Cd ctx -> assert (check_class_expr ctx) + | Ctd ctx -> assert (check_class_type ctx) | Mty _ -> assert false | Mod ctx -> ( match ctx.pmod_desc with @@ -1031,8 +1047,6 @@ end = struct | Psig_typesubst _ -> assert false | Psig_typext typext -> assert (check_typext typext) | Psig_exception ext -> assert (check_typexn ext) - | Psig_class_type l -> assert (check_class_type l) - | Psig_class l -> assert (check_class_type l) | _ -> assert false ) | Str ctx -> ( match ctx.pstr_desc with @@ -1040,15 +1054,6 @@ end = struct | Pstr_type (_, _) -> assert false | Pstr_typext typext -> assert (check_typext typext) | Pstr_exception ext -> assert (check_typexn ext) - | Pstr_class l -> - assert ( - List.exists l ~f:(fun {pci_expr= {pcl_desc; _}; pci_params; _} -> - List.exists pci_params ~f:(fun (t, _) -> t == typ) - || - match pcl_desc with - | Pcl_constr (_, l) -> List.exists l ~f:(fun x -> x == typ) - | _ -> false ) ) - | Pstr_class_type l -> assert (check_class_type l) | Pstr_extension ((_, PTyp t), _) -> assert (t == typ) | Pstr_extension (_, _) -> assert false | Pstr_value {pvbs_bindings; _} -> @@ -1099,15 +1104,6 @@ end = struct assert_no_raise ~f:check_typ ~dump xtyp let check_cty {ctx; ast= cty} = - let check_class_type l = - List.exists l ~f:(fun {pci_expr; _} -> - let rec loop x = - x == cty - || - match x.pcty_desc with Pcty_arrow (_, x) -> loop x | _ -> false - in - loop pci_expr ) - in match (ctx : t) with | Exp _ -> assert false | Fp _ -> assert false @@ -1117,25 +1113,8 @@ end = struct | Mb _ -> assert false | Md _ -> assert false | Pld _ -> assert false - | Str ctx -> ( - match ctx.pstr_desc with - | Pstr_class_type l -> assert (check_class_type l) - | Pstr_class l -> - assert ( - List.exists l ~f:(fun {pci_expr; _} -> - let rec loop x = - match x.pcl_desc with - | Pcl_fun (_, x) -> loop x - | Pcl_constraint (_, x) -> x == cty - | _ -> false - in - loop pci_expr ) ) - | _ -> assert false ) - | Sig ctx -> ( - match ctx.psig_desc with - | Psig_class_type l -> assert (check_class_type l) - | Psig_class l -> assert (check_class_type l) - | _ -> assert false ) + | Str _ -> assert false + | Sig _ -> assert false | Cty {pcty_desc; _} -> ( match pcty_desc with | Pcty_arrow (_, t) -> assert (t == cty) @@ -1159,6 +1138,8 @@ end = struct | Pcl_constraint (_, x) -> x == cty | Pcl_extension _ -> false | Pcl_open _ -> false ) + | Cd _ -> assert false + | Ctd ctx -> assert (ctx.pci_expr == cty) | Clf _ -> assert false | Ctf {pctf_desc; _} -> assert ( @@ -1187,21 +1168,7 @@ end = struct | Mb _ -> assert false | Md _ -> assert false | Pld _ -> assert false - | Str ctx -> ( - match ctx.pstr_desc with - | Pstr_class l -> - assert ( - List.exists l ~f:(fun {pci_expr; _} -> - let rec loop x = - cl == x - || - match x.pcl_desc with - | Pcl_fun (_, x) -> loop x - | Pcl_constraint (x, _) -> loop x - | _ -> false - in - loop pci_expr ) ) - | _ -> assert false ) + | Str _ -> assert false | Sig _ -> assert false | Cty _ -> assert false | Top -> assert false @@ -1220,6 +1187,8 @@ end = struct | Pcl_open (_, x) -> x == cl | Pcl_constr _ -> false | Pcl_extension _ -> false ) + | Cd ctx -> assert (ctx.pci_expr == cl) + | Ctd _ -> assert false | Clf {pcf_desc; _} -> assert ( match pcf_desc with Pcf_inherit (_, x, _) -> x == cl | _ -> false ) @@ -1327,6 +1296,8 @@ end = struct | Pcl_extension (_, ext) -> check_extensions ext | Pcl_open _ -> false ) | Cty _ -> assert false + | Cd _ -> assert false + | Ctd _ -> assert false | Mty _ | Mod _ | Sig _ -> assert false | Str str -> ( match str.pstr_desc with @@ -1477,6 +1448,8 @@ end = struct in assert (loop ctx) | Cty _ -> assert false + | Cd _ -> assert false + | Ctd _ -> assert false | Ctf _ -> assert false | Clf {pcf_desc; _} -> assert ( @@ -1703,6 +1676,10 @@ end = struct |{ctx= _; ast= Bo _} |{ctx= Td _; ast= _} |{ctx= _; ast= Td _} + |{ctx= Cd _; ast= _} + |{ctx= _; ast= Cd _} + |{ctx= Ctd _; ast= _} + |{ctx= _; ast= Ctd _} |{ ctx= Cl _ ; ast= ( Pld _ | Top | Tli _ | Pat _ | Mty _ | Mod _ | Sig _ | Str _ @@ -1792,7 +1769,7 @@ end = struct | Pcl_structure _ -> Some Apply | _ -> None ) | Top | Pat _ | Mty _ | Mod _ | Sig _ | Str _ | Tli _ | Clf _ | Ctf _ - |Rep | Mb _ | Md _ -> + |Rep | Mb _ | Md _ | Cd _ | Ctd _ -> None (** [ambig_prec {ctx; ast}] holds when [ast] is ambiguous in its context diff --git a/lib/Ast.mli b/lib/Ast.mli index d2f87f4cd2..0faf28ac21 100644 --- a/lib/Ast.mli +++ b/lib/Ast.mli @@ -108,6 +108,8 @@ type t = | Typ of core_type | Td of type_declaration | Cty of class_type + | Cd of class_declaration + | Ctd of class_type_declaration | Pat of pattern | Exp of expression | Fp of function_param diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index c88723b295..1f5dffe93e 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -3734,15 +3734,16 @@ and fmt_signature_item c ?ext {ast= si; _} = | Psig_type (rec_flag, decls) -> fmt_type c ?ext rec_flag decls ctx | Psig_typext te -> fmt_type_extension ?ext c ctx te | Psig_value vd -> fmt_value_description ?ext c ctx vd - | Psig_class cl -> fmt_class_types ?ext c ctx ~pre:"class" ~sep:":" cl + | Psig_class cl -> fmt_class_types ?ext c ~pre:"class" ~sep:":" cl | Psig_class_type cl -> - fmt_class_types ?ext c ctx ~pre:"class type" ~sep:"=" cl + fmt_class_types ?ext c ~pre:"class type" ~sep:"=" cl | Psig_typesubst decls -> fmt_type c ?ext ~eq:":=" Recursive decls ctx -and fmt_class_types ?ext c ctx ~pre ~sep cls = +and fmt_class_types ?ext c ~pre ~sep cls = list_fl cls (fun ~first ~last:_ cl -> update_config_maybe_disabled c cl.pci_loc cl.pci_attributes @@ fun c -> + let ctx = Ctd cl in let doc_before, doc_after, atrs = let force_before = not (Cty.is_simple cl.pci_expr) in fmt_docstring_around_item ~force_before c cl.pci_attributes @@ -3766,15 +3767,18 @@ and fmt_class_types ?ext c ctx ~pre ~sep cls = $ hovbox 0 @@ Cmts.fmt c cl.pci_loc (doc_before $ class_types $ doc_after) ) -and fmt_class_exprs ?ext c ctx cls = +and fmt_class_exprs ?ext c cls = hvbox 0 @@ list_fl cls (fun ~first ~last:_ cl -> update_config_maybe_disabled c cl.pci_loc cl.pci_attributes @@ fun c -> + let ctx = Cd cl in let xargs, xbody = Sugar.cl_fun c.cmts (sub_cl ~ctx cl.pci_expr) in let ty, e = match xbody.ast with - | {pcl_desc= Pcl_constraint (e, t); _} -> (Some t, sub_cl ~ctx e) + | {pcl_desc= Pcl_constraint (e, t); _} as ce -> + let ctx = Cl ce in + (Some (sub_cty ~ctx t), sub_cl ~ctx e) | _ -> (None, xbody) in let doc_before, doc_after, atrs = @@ -3798,7 +3802,7 @@ and fmt_class_exprs ?ext c ctx cls = match ty with | Some ty -> let pro = pro $ fmt " :@ " in - fmt_class_type c ~pro (sub_cty ~ctx ty) + fmt_class_type c ~pro ty | None -> pro in hovbox 2 @@ -4332,8 +4336,8 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi $ fmt_item_attributes c ~pre:Space atrs $ doc_after ) | Pstr_class_type cl -> - fmt_class_types ?ext c ctx ~pre:"class type" ~sep:"=" cl - | Pstr_class cls -> fmt_class_exprs ?ext c ctx cls + fmt_class_types ?ext c ~pre:"class type" ~sep:"=" cl + | Pstr_class cls -> fmt_class_exprs ?ext c cls and fmt_let c ~ext ~rec_flag ~bindings ~parens ~fmt_atrs ~fmt_expr ~body_loc ~has_attr ~indent_after_in = diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 4bad010f59..2ce19e6557 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -1214,3 +1214,7 @@ let function_param ppf x = function_param 0 ppf x let value_constraint ppf x = value_constraint 0 ppf x let binding_op ppf x = binding_op 0 ppf x + +let class_declaration ppf x = class_declaration 0 ppf x + +let class_type_declaration ppf x = class_type_declaration 0 ppf x