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
198
199
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Fabrice Le Fessant, INRIA Saclay *)
(* *)
(* Copyright 2012 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Generate an .annot file from a .cmt file. *)
open Asttypes
open Typedtree
let bind_variables scope =
object
inherit Tast_iter.iter as super
method! pattern pat =
super # pattern pat;
match pat.pat_desc with
| Tpat_var (id, _) | Tpat_alias (_, id, _) ->
Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, Annot.Idef scope))
| _ -> ()
end
let bind_bindings scope bindings =
let o = bind_variables scope in
List.iter (fun (p, _) -> o # pattern p) bindings
let bind_cases l =
List.iter
(fun {c_lhs; c_guard; c_rhs} ->
let loc =
let open Location in
match c_guard with
| None -> c_rhs.exp_loc
| Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start}
in
(bind_variables loc) # pattern c_lhs) l
let iterator rebuild_env =
object(this)
val scope = Location.none (* scope of the surrounding structure *)
inherit Tast_iter.iter as super
method! class_expr node =
Stypes.record (Stypes.Ti_class node);
super # class_expr node
method! module_expr node =
Stypes.record (Stypes.Ti_mod node);
Tast_iter.module_expr {< scope = node.mod_loc >} node
method! expression exp =
begin match exp.exp_desc with
| Texp_ident (path, _, _) ->
let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
let env =
if rebuild_env then
try
Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
with Envaux.Error err ->
Format.eprintf "%a@." Envaux.report_error err;
exit 2
else
exp.exp_env
in
let annot =
try
let desc = Env.find_value path env in
let dloc = desc.Types.val_loc in
if dloc.Location.loc_ghost then Annot.Iref_external
else Annot.Iref_internal dloc
with Not_found ->
Annot.Iref_external
in
Stypes.record
(Stypes.An_ident (exp.exp_loc, full_name , annot))
| Texp_let (Recursive, bindings, _) ->
bind_bindings exp.exp_loc bindings
| Texp_let (Nonrecursive, bindings, body) ->
bind_bindings body.exp_loc bindings
| Texp_function (_, f, _)
| Texp_match (_, f, _)
| Texp_try (_, f) ->
bind_cases f
| _ -> ()
end;
Stypes.record (Stypes.Ti_expr exp);
super # expression exp
method! pattern pat =
super # pattern pat;
Stypes.record (Stypes.Ti_pat pat)
method private structure_item_rem s rem =
begin match s with
| {str_desc = Tstr_value (rec_flag, bindings, _); str_loc = loc} ->
let open Location in
let doit loc_start = bind_bindings {scope with loc_start} bindings in
begin match rec_flag, rem with
| Recursive, _ -> doit loc.loc_start
| Nonrecursive, [] -> doit loc.loc_end
| Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start
end
| _ ->
()
end;
Stypes.record_phrase s.str_loc;
super # structure_item s
method! structure_item s =
(* This will be used for Partial_structure_item.
We don't have here the location of the "next" item,
this will give a slightly different scope for the non-recursive
binding case. *)
this # structure_item_rem s []
method! structure l =
let rec loop = function
| str :: rem -> this # structure_item_rem str rem; loop rem
| [] -> ()
in
loop l.str_items
(* TODO: support binding for Tcl_fun, Tcl_let, etc *)
end
let binary_part iter x =
let open Cmt_format in
match x with
| Partial_structure x -> iter # structure x
| Partial_structure_item x -> iter # structure_item x
| Partial_expression x -> iter # expression x
| Partial_pattern x -> iter # pattern x
| Partial_class_expr x -> iter # class_expr x
| Partial_signature x -> iter # signature x
| Partial_signature_item x -> iter # signature_item x
| Partial_module_type x -> iter # module_type x
let gen_annot target_filename filename {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} =
let open Cmt_format in
Envaux.reset_cache ();
Config.load_path := cmt_loadpath;
let target_filename =
match target_filename with
| None -> Some (filename ^ ".annot")
| Some "-" -> None
| Some filename -> target_filename
in
let iterator = iterator cmt_use_summaries in
match cmt_annots with
| Implementation typedtree ->
iterator # structure typedtree;
Stypes.dump target_filename
| Interface _ ->
Printf.fprintf stderr "Cannot generate annotations for interface file\n%!";
exit 2
| Partial_implementation parts ->
Array.iter (binary_part iterator) parts;
Stypes.dump target_filename
| _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
let gen_ml target_filename filename cmt =
let (printer, ext) =
match cmt.Cmt_format.cmt_annots with
| Cmt_format.Implementation typedtree ->
(fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), ".ml"
| Cmt_format.Interface typedtree ->
(fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), ".mli"
| _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
in
let target_filename = match target_filename with
None -> Some (filename ^ ext)
| Some "-" -> None
| Some filename -> target_filename
in
let oc = match target_filename with
None -> None
| Some filename -> Some (open_out filename) in
let ppf = match oc with
None -> Format.std_formatter
| Some oc -> Format.formatter_of_out_channel oc in
printer ppf;
Format.pp_print_flush ppf ();
match oc with
None -> flush stdout
| Some oc -> close_out oc
|
