Source file deps.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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
open Ppxlib
type path = { root : Longident.t; fields : string list }
type t = { used_paths : path list; bound_names : string list }
let root_name path = Longident.name path.root
let is_qualified path =
match path.root with Lident _ -> false | Ldot _ | Lapply _ -> true
let path_to_string path = String.concat "." (root_name path :: path.fields)
let rec fields_are_prefix prefix fields =
match (prefix, fields) with
| [], _ -> true
| _ :: _, [] -> false
| p :: ps, f :: fs -> String.equal p f && fields_are_prefix ps fs
let is_prefix ~prefix ~path =
String.equal (root_name prefix) (root_name path)
&& fields_are_prefix prefix.fields path.fields
let is_strict_prefix ~prefix ~path =
List.length prefix.fields < List.length path.fields && is_prefix ~prefix ~path
let rec path_with_fields (expression : Parsetree.expression) fields :
path option =
match expression.pexp_desc with
| Pexp_ident { txt; _ } -> Some { root = txt; fields }
| Pexp_field (inner, { txt = Lident field; _ }) ->
path_with_fields inner (field :: fields)
| Pexp_constraint (inner, _) -> path_with_fields inner fields
| _ -> None
let path_of_expression expression = path_with_fields expression []
let is_operator name =
String.length name > 0
&&
let c = name.[0] in
not (Char.equal c '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))
let add_values values_rev new_values = List.rev_append new_values values_rev
let of_expression (expression : Parsetree.expression) : t =
let add_path path (paths_rev, values_rev) = (path :: paths_rev, values_rev) in
let rec collect (expression : Parsetree.expression) acc =
match expression.pexp_desc with
| Pexp_ident { txt = ident; _ } ->
add_path { root = ident; fields = [] } acc
| Pexp_let (_, value_bindings, expr) ->
let acc =
List.fold_left
(fun (paths_rev, values_rev) value ->
let binding_names = Bindings.of_pattern value.pvb_pat in
let func_params = Bindings.function_params value.pvb_expr in
let values_rev =
values_rev |> add_values binding_names |> add_values func_params
in
collect value.pvb_expr (paths_rev, values_rev))
acc value_bindings
in
collect expr acc
| Pexp_function (params, _, body) -> (
let acc = collect_params params acc in
match body with
| Pfunction_body body -> collect body acc
| Pfunction_cases (cases, _, _) -> List.fold_left collect_case acc cases
)
| Pexp_apply (fn_expr, labeled_expr) ->
let acc =
match path_of_expression fn_expr with
| Some { root = Lident name; fields = [] } when is_operator name ->
acc
| Some path -> add_path path acc
| None -> collect fn_expr acc
in
collect_all (List.map snd labeled_expr) acc
| Pexp_match (expr, cases) | Pexp_try (expr, cases) ->
List.fold_left collect_case (collect expr acc) cases
| Pexp_tuple exprs | Pexp_array exprs -> collect_all exprs acc
| Pexp_construct ({ txt = Lident "None"; _ }, _) -> acc
| Pexp_construct (_, Some expr)
| Pexp_variant (_, Some expr)
| Pexp_constraint (expr, _)
| Pexp_newtype (_, expr)
| Pexp_coerce (expr, _, _)
| Pexp_send (expr, _)
| Pexp_setinstvar (_, expr)
| Pexp_letmodule (_, _, expr)
| Pexp_letexception (_, expr)
| Pexp_assert expr
| Pexp_lazy expr
| Pexp_poly (expr, _)
| Pexp_open (_, expr) ->
collect expr acc
| Pexp_record (fields, base) ->
collect_all (Option.to_list base @ List.map snd fields) acc
| Pexp_override fields -> collect_all (List.map snd fields) acc
| Pexp_field (expr, _) -> (
match path_of_expression expression with
| Some path -> add_path path acc
| None -> collect expr acc)
| Pexp_setfield (expr1, field, expr2) ->
let written_path =
match field.txt with
| Lident name -> path_with_fields expr1 [ name ]
| _ -> None
in
let acc =
match written_path with
| Some path -> add_path path acc
| None -> collect expr1 acc
in
collect expr2 acc
| Pexp_ifthenelse (expr1, expr2, else_expr) ->
collect_all ([ expr1; expr2 ] @ Option.to_list else_expr) acc
| Pexp_sequence (expr1, expr2) | Pexp_while (expr1, expr2) ->
collect_all [ expr1; expr2 ] acc
| Pexp_for (pat, expr1, expr2, _, expr3) ->
let paths_rev, values_rev = acc in
let loop_var = Bindings.of_pattern pat in
collect_all [ expr1; expr2; expr3 ]
(paths_rev, add_values values_rev loop_var)
| Pexp_letop { let_; ands; body } ->
let acc = collect let_.pbop_exp acc in
let binding_names = Bindings.of_pattern let_.pbop_pat in
let paths_rev, values_rev =
List.fold_left
(fun acc and_op ->
let paths_rev, values_rev = collect and_op.pbop_exp acc in
let and_names = Bindings.of_pattern and_op.pbop_pat in
(paths_rev, add_values values_rev and_names))
acc ands
in
collect body (paths_rev, add_values values_rev binding_names)
| Pexp_extension _ -> (
match Platform.browser_only_payload expression with
| Some payload -> collect payload acc
| None -> (
match Platform.client_case expression with
| Some case -> collect_case acc case
| None -> acc))
| _ -> acc
and collect_all exprs acc =
List.fold_left (fun acc expr -> collect expr acc) acc exprs
and collect_case (paths_rev, values_rev) (case : Parsetree.case) =
let values_rev = add_values values_rev (Bindings.of_pattern case.pc_lhs) in
collect_all
(Option.to_list case.pc_guard @ [ case.pc_rhs ])
(paths_rev, values_rev)
and collect_params params acc =
List.fold_left
(fun acc (p : Parsetree.function_param) ->
match p.pparam_desc with
| Pparam_val (_, default_arg, pat) ->
let paths_rev, values_rev =
collect_all (Option.to_list default_arg) acc
in
(paths_rev, add_values values_rev (Bindings.of_pattern pat))
| Pparam_newtype _ -> acc)
acc params
in
let paths_rev, values_rev = collect expression ([], []) in
{ used_paths = List.rev paths_rev; bound_names = List.rev values_rev }