Skip to content

Commit

Permalink
Add class_infos to Ast.t
Browse files Browse the repository at this point in the history
  • Loading branch information
@gpetiot
gpetiot committed Dec 21, 2023
1 parent 11460fa commit 92cb754
Show file tree
Hide file tree
Showing 4 changed files with 59 additions and 72 deletions.
105 changes: 41 additions & 64 deletions lib/Ast.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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) ->
Expand Down Expand Up @@ -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 _ -> []
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -1031,24 +1047,13 @@ 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
| Pstr_primitive {pval_type= t1; _} -> assert (typ == t1)
| 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; _} ->
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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 (
Expand Down Expand Up @@ -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
Expand All @@ -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 )
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 (
Expand Down Expand Up @@ -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 _
Expand Down Expand Up @@ -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
Expand Down
2 changes: 2 additions & 0 deletions lib/Ast.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
20 changes: 12 additions & 8 deletions lib/Fmt_ast.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
4 changes: 4 additions & 0 deletions vendor/parser-extended/printast.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

0 comments on commit 92cb754

Please sign in to comment.