Source file envaux.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
open Env
type error =
Module_not_found of Path.t
exception Error of error
let env_cache =
(Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
let reset_cache ~preserve_persistent_env =
Hashtbl.clear env_cache;
Env.reset_cache ~preserve_persistent_env
let rec env_from_summary ~allow_missing_modules sum subst =
try
Hashtbl.find env_cache (sum, subst)
with Not_found ->
let env =
match sum with
Env_empty ->
Env.empty
| Env_value(s, id, desc, mode) ->
let desc =
Subst.Lazy.of_value_description desc
|> Subst.Lazy.value_description subst
in
Env.add_value_lazy ~mode id desc (env_from_summary ~allow_missing_modules s subst)
| Env_type(s, id, desc) ->
Env.add_type ~check:false id
(Subst.type_declaration subst desc)
(env_from_summary ~allow_missing_modules s subst)
| Env_extension(s, id, desc) ->
Env.add_extension ~check:false ~rebind:false id
(Subst.extension_constructor subst desc)
(env_from_summary ~allow_missing_modules s subst)
| Env_module(s, id, pres, desc, mode, locks) ->
let desc =
Subst.Lazy.module_decl Keep subst (Subst.Lazy.of_module_decl desc)
in
Env.add_module_declaration_lazy ~update_summary:true id pres desc
~mode ~locks (env_from_summary ~allow_missing_modules s subst)
| Env_modtype(s, id, desc) ->
let desc =
Subst.Lazy.modtype_decl Keep subst (Subst.Lazy.of_modtype_decl desc)
in
Env.add_modtype_lazy ~update_summary:true id desc
(env_from_summary ~allow_missing_modules s subst)
| Env_class(s, id, desc) ->
Env.add_class id (Subst.class_declaration subst desc)
(env_from_summary ~allow_missing_modules s subst)
| Env_cltype (s, id, desc) ->
Env.add_cltype id (Subst.cltype_declaration subst desc)
(env_from_summary ~allow_missing_modules s subst)
| Env_open(s, path) ->
let env = env_from_summary ~allow_missing_modules s subst in
let path' = Subst.module_path subst path in
if allow_missing_modules then
(try Env.open_signature_by_path path' env with
| Not_found -> env)
else
(try Env.open_signature_by_path path' env with
| Not_found -> raise (Error (Module_not_found path')))
| Env_functor_arg(Env_module(s, id, pres, desc, mode, locks), id')
when Ident.same id id' ->
let desc =
Subst.Lazy.module_decl Keep subst (Subst.Lazy.of_module_decl desc)
in
Env.add_module_declaration_lazy ~update_summary:true id pres desc
~mode ~locks
~arg:true (env_from_summary ~allow_missing_modules s subst)
| Env_functor_arg _ -> assert false
| Env_constraints(s, map) ->
StagedPath.Map.fold
(fun { stage; path } info ->
Env.add_local_constraint ~stage (Subst.type_path subst path)
(Subst.type_declaration subst info))
map (env_from_summary ~allow_missing_modules s subst)
| Env_copy_types s ->
let env = env_from_summary ~allow_missing_modules s subst in
Env.make_copy_of_types env env
| Env_persistent (s, id) ->
let env = env_from_summary ~allow_missing_modules s subst in
Env.add_persistent_structure id env
| Env_value_unbound (s, str, reason) ->
let env = env_from_summary ~allow_missing_modules s subst in
Env.enter_unbound_value str reason env
| Env_module_unbound (s, str, reason) ->
let env = env_from_summary ~allow_missing_modules s subst in
Env.enter_unbound_module str reason env
| Env_jkind (s, id, desc) ->
let env = env_from_summary ~allow_missing_modules s subst in
Env.add_jkind ~check:false id (Subst.jkind_declaration subst desc) env
in
Hashtbl.add env_cache (sum, subst) env;
env
let env_of_only_summary ?(allow_missing_modules = false) env =
Env.env_of_only_summary (env_from_summary ~allow_missing_modules) env
open Format_doc
module Style = Misc.Style
let report_error_doc ppf = function
| Module_not_found p ->
fprintf ppf "@[Cannot find module %a@].@."
(Style.as_inline_code Printtyp.path) p
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error_doc err)
| _ -> None
)
let report_error = Format_doc.compat report_error_doc