1 (***********************************************************************)
4 (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
6 (* Copyright 2001 Institut National de Recherche en Informatique et *)
7 (* en Automatique. All rights reserved. This file is distributed *)
8 (* under the terms of the Q Public License version 1.0. *)
10 (***********************************************************************)
14 (** Environment for finding complete names from relative names. *)
16 let print_DEBUG s
= print_string s
; print_newline
();;
18 module Name
= Odoc_name
20 (** relative name * complete name *)
21 type env_element
= Name.t
* Name.t
24 env_values
: env_element list
;
25 env_types
: env_element list
;
26 env_class_types
: env_element list
;
27 env_classes
: env_element list
;
28 env_modules
: env_element list
;
29 env_module_types
: env_element list
;
30 env_exceptions
: env_element list
;
36 env_class_types
= [] ;
39 env_module_types
= [] ;
43 (** Add a signature to an environment. *)
44 let rec add_signature env root ?rel signat
=
45 let qualify id
= Name.concat root
(Name.from_ident id
) in
47 let n = Name.from_ident id
in
50 | Some r
-> Name.concat r
n
54 Types.Tsig_value
(ident
, _
) -> { env
with env_values
= (rel_name ident
, qualify ident
) :: env
.env_values
}
55 | Types.Tsig_type
(ident
,_
,_
) -> { env
with env_types
= (rel_name ident
, qualify ident
) :: env
.env_types
}
56 | Types.Tsig_exception
(ident
, _
) -> { env
with env_exceptions
= (rel_name ident
, qualify ident
) :: env
.env_exceptions
}
57 | Types.Tsig_module
(ident
, modtype
, _
) ->
59 match modtype
with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
60 Types.Tmty_signature s
-> add_signature env
(qualify ident
) ~rel
: (rel_name ident
) s
63 { env2 with env_modules
= (rel_name ident
, qualify ident
) :: env2.env_modules
}
64 | Types.Tsig_modtype
(ident
, modtype_decl
) ->
66 match modtype_decl
with
67 Types.Tmodtype_abstract
->
69 | Types.Tmodtype_manifest modtype
->
71 (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
72 Types.Tmty_signature s
-> add_signature env
(qualify ident
) ~rel
: (rel_name ident
) s
75 { env2 with env_module_types
= (rel_name ident
, qualify ident
) :: env2.env_module_types
}
76 | Types.Tsig_class
(ident
, _
, _
) -> { env
with env_classes
= (rel_name ident
, qualify ident
) :: env
.env_classes
}
77 | Types.Tsig_cltype
(ident
, _
, _
) -> { env
with env_class_types
= (rel_name ident
, qualify ident
) :: env
.env_class_types
}
79 List.fold_left
f env signat
81 let add_exception env full_name
=
82 let simple_name = Name.simple full_name
in
83 { env
with env_exceptions
= (simple_name, full_name
) :: env
.env_exceptions
}
85 let add_type env full_name
=
86 let simple_name = Name.simple full_name
in
87 { env
with env_types
= (simple_name, full_name
) :: env
.env_types
}
89 let add_value env full_name
=
90 let simple_name = Name.simple full_name
in
91 { env
with env_values
= (simple_name, full_name
) :: env
.env_values
}
93 let add_module env full_name
=
94 let simple_name = Name.simple full_name
in
95 { env
with env_modules
= (simple_name, full_name
) :: env
.env_modules
}
97 let add_module_type env full_name
=
98 let simple_name = Name.simple full_name
in
99 { env
with env_module_types
= (simple_name, full_name
) :: env
.env_module_types
}
101 let add_class env full_name
=
102 let simple_name = Name.simple full_name
in
104 env_classes
= (simple_name, full_name
) :: env
.env_classes
;
105 (* we also add a type 'cause the class name may appear as a type *)
106 env_types
= (simple_name, full_name
) :: env
.env_types
109 let add_class_type env full_name
=
110 let simple_name = Name.simple full_name
in
112 env_class_types
= (simple_name, full_name
) :: env
.env_class_types
;
113 (* we also add a type 'cause the class type name may appear as a type *)
114 env_types
= (simple_name, full_name
) :: env
.env_types
117 let full_module_name env
n =
118 try List.assoc
n env
.env_modules
120 print_DEBUG ("Module "^
n^
" not found with env=");
121 List.iter
(fun (sn
, fn
) -> print_DEBUG ("("^sn^
", "^fn^
")")) env
.env_modules
;
124 let full_module_type_name env
n =
125 try List.assoc
n env
.env_module_types
127 print_DEBUG ("Module "^
n^
" not found with env=");
128 List.iter
(fun (sn
, fn
) -> print_DEBUG ("("^sn^
", "^fn^
")")) env
.env_modules
;
131 let full_module_or_module_type_name env
n =
132 try List.assoc
n env
.env_modules
133 with Not_found
-> full_module_type_name env
n
135 let full_type_name env
n =
137 let full = List.assoc
n env
.env_types
in
138 (** print_string ("type "^n^" is "^full);
142 (** print_string ("type "^n^" not found");
146 let full_value_name env
n =
147 try List.assoc
n env
.env_values
150 let full_exception_name env
n =
151 try List.assoc
n env
.env_exceptions
153 print_DEBUG ("Exception "^
n^
" not found with env=");
154 List.iter
(fun (sn
, fn
) -> print_DEBUG ("("^sn^
", "^fn^
")")) env
.env_exceptions
;
157 let full_class_name env
n =
158 try List.assoc
n env
.env_classes
160 print_DEBUG ("Class "^
n^
" not found with env=");
161 List.iter
(fun (sn
, fn
) -> print_DEBUG ("("^sn^
", "^fn^
")")) env
.env_classes
;
164 let full_class_type_name env
n =
165 try List.assoc
n env
.env_class_types
167 print_DEBUG ("Class type "^
n^
" not found with env=");
168 List.iter
(fun (sn
, fn
) -> print_DEBUG ("("^sn^
", "^fn^
")")) env
.env_class_types
;
171 let full_class_or_class_type_name env
n =
172 try List.assoc
n env
.env_classes
173 with Not_found
-> full_class_type_name env
n
175 let print_env_types env
=
176 List.iter
(fun (s1
,s2
) -> Printf.printf
"%s = %s\n" s1 s2
) env
.env_types
178 let subst_type env t
=
180 print_string "Odoc_env.subst_type\n";
181 print_env_types env ;
184 Printtyp.mark_loops t
;
185 let deja_vu = ref [] in
187 if List.memq t
!deja_vu then () else begin
188 deja_vu := t
:: !deja_vu;
189 Btype.iter_type_expr
iter t
;
190 match t
.Types.desc
with
191 | Types.Tconstr
(p
, [ty
], a
) when Path.same p
Predef.path_option
->
193 | Types.Tconstr
(p
, l
, a
) ->
195 Odoc_name.to_path
(full_type_name env
(Odoc_name.from_path p
)) in
196 t
.Types.desc
<- Types.Tconstr
(new_p, l
, a
)
197 | Types.Tobject
(_
, ({contents
=Some
(p
,tyl
)} as r
)) ->
199 Odoc_name.to_path
(full_type_name env
(Odoc_name.from_path p
)) in
200 r
:= Some
(new_p, tyl
)
201 | Types.Tvariant
({Types.row_name
=Some
(p
, tyl
)} as row
) ->
203 Odoc_name.to_path
(full_type_name env
(Odoc_name.from_path p
)) in
205 Types.Tvariant
{row
with Types.row_name
=Some
(new_p, tyl
)}
214 let subst_module_type env t
=
217 Types.Tmty_ident p
->
218 let new_p = Odoc_name.to_path
(full_module_type_name env
(Odoc_name.from_path p
)) in
219 Types.Tmty_ident
new_p
220 | Types.Tmty_signature _
->
222 | Types.Tmty_functor
(id
, mt1
, mt2
) ->
223 Types.Tmty_functor
(id
, iter mt1
, iter mt2
)
227 let subst_class_type env t
=
230 Types.Tcty_constr
(p
,texp_list
,ct
) ->
231 let new_p = Odoc_name.to_path
(full_type_name env
(Odoc_name.from_path p
)) in
232 let new_texp_list = List.map
(subst_type env
) texp_list
in
233 let new_ct = iter ct
in
234 Types.Tcty_constr
(new_p, new_texp_list, new_ct)
235 | Types.Tcty_signature cs
->
236 (* on ne s'occupe pas des vals et methods *)
238 | Types.Tcty_fun
(l
, texp
, ct
) ->
239 let new_texp = subst_type env texp
in
240 let new_ct = iter ct
in
241 Types.Tcty_fun
(l
, new_texp, new_ct)