Source file type_enclosing.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
open Std
let log_section = "type-enclosing"
let {Logger.log} = Logger.for_section log_section
type type_info =
| Modtype of Env.t * Types.module_type
| Type of Env.t * Types.type_expr
| Type_decl of Env.t * Ident.t * Types.type_declaration
| String of string
type typed_enclosings =
(Location.t * type_info * Query_protocol.is_tail_position) list
let from_nodes ~path =
let aux (env, node, tail) =
let open Browse_raw in
let ret x = Some (Mbrowse.node_loc node, x, tail) in
match[@ocaml.warning "-9"] node with
| Expression {exp_type = t}
| Pattern {pat_type = t}
| Core_type {ctyp_type = t}
| Value_description { val_desc = { ctyp_type = t } } ->
ret (Type (env, t))
| Type_declaration { typ_id = id; typ_type = t} ->
ret (Type_decl (env, id, t))
| Module_expr {mod_type = Types.Mty_for_hole} -> None
| Module_expr {mod_type = m}
| Module_type {mty_type = m}
| Module_binding {mb_expr = {mod_type = m}}
| Module_declaration {md_type = {mty_type = m}}
| Module_type_declaration {mtd_type = Some {mty_type = m}}
| Module_binding_name {mb_expr = {mod_type = m}}
| Module_declaration_name {md_type = {mty_type = m}}
| Module_type_declaration_name {mtd_type = Some {mty_type = m}} ->
ret (Modtype (env, m))
| Class_field
{ cf_desc =
Tcf_method
(_, _,
Tcfk_concrete
(_, {exp_type})) } ->
begin match Types.get_desc exp_type with
| Tarrow (_, _, t, _) -> ret (Type (env, t))
| _ -> None
end
| Class_field
{ cf_desc =
Tcf_val (_, _, _, Tcfk_concrete (_, {exp_type = t }), _) } ->
ret (Type (env, t))
| Class_field { cf_desc =
Tcf_method (_, _, Tcfk_virtual {ctyp_type = t }) } ->
ret (Type (env, t))
| Class_field { cf_desc =
Tcf_val (_, _, _, Tcfk_virtual {ctyp_type = t }, _) } ->
ret (Type (env, t))
| Binding_op { bop_op_type; _ } -> ret (Type(env, bop_op_type))
| _ -> None
in
List.filter_map ~f:aux path
let from_reconstructed ~nodes ~cursor ~verbosity exprs =
let open Browse_raw in
let env, node = Mbrowse.leaf_node nodes in
log ~title:"from_reconstructed" "node = %s\nexprs = [%s]"
(Browse_raw.string_of_node node)
(String.concat ~sep:";" (List.map exprs ~f:(fun l ->
l.Location.txt))
);
let include_lident = match node with
| Pattern _ -> false
| _ -> true
in
let include_uident = match node with
| Module_binding _
| Module_binding_name _
| Module_declaration _
| Module_declaration_name _
| Module_type_declaration _
| Module_type_declaration_name _
-> false
| _ -> true
in
let get_context lident =
Context.inspect_browse_tree
~cursor
(Longident.parse lident)
[nodes]
in
let f =
fun {Location. txt = source; loc} ->
let context = get_context source in
Option.iter context ~f:(fun ctx ->
log ~title:"from_reconstructed" "source = %s; context = %s"
source (Context.to_string ctx));
match context with
| Some (Context.Constructor (cd, loc)) ->
log ~title:"from_reconstructed" "ctx: constructor %s"
cd.cstr_name;
let ppf, to_string = Format.to_string () in
Type_utils.print_constr ~verbosity env ppf cd;
Some (loc, String (to_string ()), `No)
| Some (Context.Label { lbl_name; lbl_arg; _ }) ->
log ~title:"from_reconstructed" "ctx: label %s" lbl_name;
let ppf, to_string = Format.to_string () in
Type_utils.print_type_with_decl ~verbosity env ppf lbl_arg;
Some (loc, String (to_string ()), `No)
| Some Context.Constant -> None
| _ ->
let context = Option.value ~default:Context.Expr context in
match source with
| "" ->
log ~title:"from_reconstructed" "no reconstructed identifier";
None
| source when not include_lident && Char.is_lowercase source.[0] ->
log ~title:"from_reconstructed" "skipping lident";
None
| source when not include_uident && Char.is_uppercase source.[0] ->
log ~title:"from_reconstructed" "skipping uident";
None
| source ->
try
let ppf, to_string = Format.to_string () in
if Type_utils.type_in_env ~verbosity ~context env ppf source then (
log ~title:"from_reconstructed" "typed %s" source;
Some (loc, String (to_string ()), `No)
)
else (
log ~title:"from_reconstructed" "FAILED to type %s" source;
None
)
with _ ->
None
in
List.filter_map exprs ~f