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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Environment for finding complete names from relative names. *)
module Name = Odoc_name
(** relative name * complete name *)
type env_element = Name.t * Name.t
type env = {
env_values : env_element list ;
env_types : env_element list ;
env_class_types : env_element list ;
env_classes : env_element list ;
env_modules : env_element list ;
env_module_types : env_element list ;
env_extensions : env_element list ;
}
let empty = {
env_values = [] ;
env_types = [] ;
env_class_types = [] ;
env_classes = [] ;
env_modules = [] ;
env_module_types = [] ;
env_extensions = [] ;
}
(** Add a signature to an environment. *)
let rec add_signature env root ?rel signat =
let qualify id = Name.concat root (Name.from_ident id) in
let rel_name id =
let n = Name.from_ident id in
match rel with
None -> n
| Some r -> Name.concat r n
in
let f env item =
match item with
Types.Sig_value (ident, _, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values }
| Types.Sig_type (ident,_,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types }
| Types.Sig_typext (ident, _, _, _) -> { env with env_extensions = (rel_name ident, qualify ident) :: env.env_extensions }
| Types.Sig_module (ident, _, md, _, _) ->
let env2 =
match md.Types.md_type with (* FIXME: we don't have signature for identifiers *)
Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
| _ -> env
in
{ env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules }
| Types.Sig_modtype (ident, modtype_decl, _) ->
let env2 =
match modtype_decl.Types.mtd_type with
None ->
env
| Some modtype ->
match modtype with
(* FIXME: we don't have signature for identifiers *)
Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
| _ -> env
in
{ env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types }
| Types.Sig_class (ident, _, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes }
| Types.Sig_class_type (ident, _, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types }
in
List.fold_left f env signat
let add_extension env full_name =
let simple_name = Name.simple full_name in
{ env with env_extensions = (simple_name, full_name) :: env.env_extensions }
let add_type env full_name =
let simple_name = Name.simple full_name in
{ env with env_types = (simple_name, full_name) :: env.env_types }
let add_value env full_name =
let simple_name = Name.simple full_name in
{ env with env_values = (simple_name, full_name) :: env.env_values }
let add_module env full_name =
let simple_name = Name.simple full_name in
{ env with env_modules = (simple_name, full_name) :: env.env_modules }
let add_module_type env full_name =
let simple_name = Name.simple full_name in
{ env with env_module_types = (simple_name, full_name) :: env.env_module_types }
let add_class env full_name =
let simple_name = Name.simple full_name in
{ env with
env_classes = (simple_name, full_name) :: env.env_classes ;
(* we also add a type 'cause the class name may appear as a type *)
env_types = (simple_name, full_name) :: env.env_types
}
let add_class_type env full_name =
let simple_name = Name.simple full_name in
{ env with
env_class_types = (simple_name, full_name) :: env.env_class_types ;
(* we also add a type 'cause the class type name may appear as a type *)
env_types = (simple_name, full_name) :: env.env_types
}
let full_module_name env n =
try List.assoc n env.env_modules
with Not_found -> n
let full_module_type_name env n =
try List.assoc n env.env_module_types
with Not_found -> n
let full_module_or_module_type_name env n =
try List.assoc n env.env_modules
with Not_found -> full_module_type_name env n
let full_type_name env n =
try
let full = List.assoc n env.env_types in
(* print_string ("type "^n^" is "^full);
print_newline ();*)
full
with Not_found ->
(* print_string ("type "^n^" not found");
print_newline ();*)
n
let full_value_name env n =
try List.assoc n env.env_values
with Not_found -> n
let full_extension_constructor_name env n =
try List.assoc n env.env_extensions
with Not_found -> n
let full_class_name env n =
try List.assoc n env.env_classes
with Not_found -> n
let full_class_type_name env n =
try List.assoc n env.env_class_types
with Not_found -> n
let full_class_or_class_type_name env n =
try List.assoc n env.env_classes
with Not_found -> full_class_type_name env n
let subst_type env t =
(*
print_string "Odoc_env.subst_type\n";
print_env_types env ;
print_newline ();
*)
let deja_vu = ref [] in
let rec iter t =
if List.memq t !deja_vu then () else begin
deja_vu := t :: !deja_vu;
Btype.iter_type_expr iter t;
let open Types in
match get_desc t with
| Tconstr (p, [_], _) when Path.same p Predef.path_option ->
()
| Tconstr (p, l, a) ->
let new_p =
Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
set_type_desc t (Tconstr (new_p, l, a))
| Tpackage (p, fl) ->
let new_p =
Odoc_name.to_path
(full_module_type_name env (Odoc_name.from_path p)) in
set_type_desc t (Tpackage (new_p, fl))
| Tobject (_, ({contents=Some(p,tyl)} as r)) ->
let new_p =
Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
r := Some (new_p, tyl)
| Tvariant row ->
begin match row_name row with
| Some (p, tyl) ->
let new_p =
Odoc_name.to_path (full_type_name env (Odoc_name.from_path p))
in
set_type_desc t (Tvariant (set_row_name row (Some(new_p, tyl))))
| None -> ()
end
| _ ->
()
end
in
iter t;
t
let subst_module_type env t =
let rec iter t =
let open Types in
match t with
Mty_ident p ->
let new_p =
Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p))
in
Mty_ident new_p
| Mty_alias _
| Mty_signature _ ->
t
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
| Mty_functor (Named (name, mt1), mt2) ->
Mty_functor (Named (name, iter mt1), iter mt2)
in
iter t
let subst_class_type env t =
let rec iter t =
let open Types in
match t with
Cty_constr (p,texp_list,ct) ->
let new_p =
Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
let new_texp_list = List.map (subst_type env) texp_list in
let new_ct = iter ct in
Cty_constr (new_p, new_texp_list, new_ct)
| Cty_signature _ ->
(* we don't handle vals and methods *)
t
| Cty_arrow (l, texp, ct) ->
let new_texp = subst_type env texp in
let new_ct = iter ct in
Cty_arrow (l, new_texp, new_ct)
in
iter t
|
