-
Notifications
You must be signed in to change notification settings - Fork 2
/
analysis.ml
197 lines (176 loc) · 7.42 KB
/
analysis.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
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
open Spotlib.Spot
open Asttypes
type ident = Ident.t
type path = Path.t
type type_expr = Types.type_expr
type a_structure = a_structure_item list
and a_structure_item =
| A_str_value of ident * Location.t * type_expr * path option
| A_str_primitive of ident * Location.t * type_expr
| A_str_type of ident * Location.t * a_type_declaration
| A_str_exception of ident * Location.t * type_expr list
| A_str_exn_rebind of ident * Location.t * path * type_expr list
| A_str_module of ident * Location.t * a_module(*_expr *)
| A_str_modtype of ident * Location.t (* * a_module(*_type *) *)
| A_str_class of ident * Location.t * a_class(*_declaration *)
| A_str_class_type of ident * Location.t * a_class(*_type_declaration *)
| A_str_include of a_module * Location.t * a_signature
and a_type_declaration =
{ a_typ_params: string option list;
a_typ_kind: a_type_kind;
a_typ_private: private_flag;
a_typ_manifest: type_expr option; }
and a_type_kind =
| A_type_abstract
| A_type_variant of (ident * Location.t * type_expr list) list
| A_type_record of (ident * Location.t * mutable_flag * type_expr) list
and a_module(*_expr *) =
| A_mod_ident of path
| A_mod_structure of a_structure
| A_mod_functor of ident (* * Location.t * a_module(*_type*)*) * a_module(*_expr*)
| A_mod_apply of a_module(*_expr*) * a_module(*_expr*)
(* | A_mod_constraint of a_module(*_expr*) * a_module(*_type*) *)
| A_mod_unpack
and a_class = {
a_cl_virt : virtual_flag;
a_cl_params : string list;
a_cl_new : type_expr; (* class c x = object end has 'a -> object end *)
a_cl_inherits : type_expr list;
a_cl_methods : (ident * Location.t * private_flag * virtual_flag * type_expr) list
}
and a_signature = a_signature_item list
and a_signature_item =
| A_sig_value of Ident.t
| A_sig_type of Ident.t
| A_sig_exception of Ident.t
| A_sig_module of Ident.t
| A_sig_modtype of Ident.t
| A_sig_class of Ident.t
| A_sig_class_type of Ident.t
open Typedtree
open List
let rec structure s =
s.str_items |> concat_map @@ fun x -> match x.str_desc with
| Tstr_eval _ -> []
| Tstr_value (_, list) ->
concat_map (fun (p,e) ->
let rec extract (p, eo) =
let alias eo = match eo with
| Some { exp_desc = Texp_ident (p, _, _) } -> Some p
| _ -> None
in
match p.pat_desc with
| Tpat_tuple ps ->
begin match eo with
| Some { exp_desc= Texp_tuple es } ->
concat_map extract (combine ps (map (fun x -> Some x) es))
| _ ->
concat_map extract (map (fun p -> p, None) ps)
end
| Tpat_var (id, {loc}) ->
[ A_str_value (id, loc, p.pat_type, alias eo) ]
| Tpat_alias (p, id, {loc}) ->
A_str_value (id, loc, p.pat_type, alias eo)
:: extract (p, eo)
| Tpat_construct (_, _, ps, _)
| Tpat_array ps ->
concat_map extract (map (fun p -> (p, None)) ps)
| Tpat_variant (_, Some p, _) ->
extract (p, None)
| Tpat_record (xs, _) ->
concat_map extract (map (fun (_, _, p) -> (p, None)) xs)
| Tpat_or (p1, p2, _) ->
extract (p1, None) @ extract (p2, None)
| Tpat_lazy p -> extract (p, None)
| Tpat_any
| Tpat_constant _
| Tpat_variant (_, None, _) -> []
in
extract (p, Some e)) list
| Tstr_primitive (id, {loc}, vdesc) ->
[ A_str_primitive (id, loc, vdesc.val_val.val_type) ]
| Tstr_type xs ->
xs |> map @@ fun (id, {loc}, td) ->
A_str_type (id, loc,
{ a_typ_params = map (Option.map (fun {txt} -> txt)) td.typ_params;
a_typ_kind = assert false;
a_typ_private = td.typ_private;
a_typ_manifest = Option.map (fun x -> x.ctyp_type) td.typ_manifest })
| Tstr_exception (id, {loc}, {exn_params}) ->
[ A_str_exception (id, loc, map (fun x -> x.ctyp_type) exn_params) ]
| Tstr_exn_rebind (id, {loc}, p, longid) ->
(* CR jfuruse: Redundant calculation. Tstr_exn_rebind should carry the arguments *)
let (_path, arg) = Typedecl.transl_exn_rebind x.str_env loc longid.txt in
[ A_str_exn_rebind (id, loc, p, arg.exn_args) ]
| Tstr_module (id, {loc}, mexp) ->
[ A_str_module (id, loc, module_expr mexp) ]
| Tstr_recmodule xs ->
xs |> map @@ fun (id, {loc}, _mty, mexp) ->
A_str_module (id, loc, let _m = module_expr mexp in assert false)
| Tstr_modtype (id, {loc}, _mty) ->
[ A_str_modtype (id, loc) ]
| Tstr_open _ -> []
| Tstr_class xs ->
xs |> map @@ fun (cd, _, _) -> class_declaration cd
| Tstr_class_type xs ->
xs |> map @@ fun (id, {loc}, ctd) ->
A_str_class_type (id, loc, class_type_declaration ctd)
| Tstr_include (mexp, sg) ->
[ A_str_include (module_expr mexp, x.str_loc, ty_signature sg) ]
and module_expr mexp =
match mexp.mod_desc with
| Tmod_ident (p, _) -> A_mod_ident p
| Tmod_structure str -> A_mod_structure (structure str)
| Tmod_functor (id, _, _mty, mexp) -> A_mod_functor (id, module_expr mexp)
| Tmod_apply (mexp1, mexp2, _) -> A_mod_apply (module_expr mexp1, module_expr mexp2)
| Tmod_constraint (mexp, _mty, _, _) -> module_expr mexp
| Tmod_unpack _ -> A_mod_unpack
(*
and module_type mty =
match mty.mty_desc with
| Tmty_ident (p, _) -> A_mod_ident p
| Tmty_signature sg -> signature sg
| Tmty_functor (id, {loc}, _mty, mty) ->
A_mod_functor (id, module_type mty)
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr
*)
and class_declaration cd =
let id = cd.ci_id_class in
let loc = cd.ci_id_name.loc in
let newty =
let cd = cd.ci_decl in
let last = Btype.newgenty (Tconstr (cd.cty_path, cd.cty_params, ref Types.Mnil)) in
let rec new_ty last = function
| Types.Cty_constr _ -> last (* CR jfuruse: Really? TODO *)
| Cty_signature _ -> last
| Cty_fun (label, ty, clty) ->
Btype.newgenty (Tarrow (label, ty, new_ty last clty, Cok))
in
new_ty last cd.cty_type
in
let a_class = { a_cl_virt = cd.ci_virt;
a_cl_params =
fst cd.ci_params |> List.map (fun {txt} -> txt);
a_cl_new = newty;
a_cl_inherits = []; (* CR jfuruse: TODO *)
a_cl_methods = [] (* CR jfuruse: TODO *)
}
in
A_str_class ( id, loc, a_class )
and class_type_declaration _ctd = assert false
and ty_signature sg = map ty_signature_item sg
and ty_signature_item = function
| Sig_value (id, _) -> A_sig_value id
| Sig_type (id, _, _) -> A_sig_type id
| Sig_exception (id, _) -> A_sig_exception id
| Sig_module (id, _, _) -> A_sig_module id
| Sig_modtype (id, _) -> A_sig_modtype id
| Sig_class (id, _, _) -> A_sig_class id
| Sig_class_type (id, _, _) -> A_sig_class_type id
and type_kind = function
| Ttype_abstract -> A_type_abstract
| Ttype_variant xs ->
A_type_variant (map (fun (id, {loc}, ts, _) -> (id, loc, map (fun x -> x.ctyp_type) ts)) xs)
| Ttype_record xs ->
A_type_record (map (fun (id, {loc}, mf, ct, _) -> (id, loc, mf, ct.ctyp_type)) xs)